From ca9f53e4133f185f353a6d9e13257cddfd621ec2 Mon Sep 17 00:00:00 2001 From: Daniel Gröber Date: Wed, 25 Sep 2019 17:09:17 +0200 Subject: Add support for symlink farming as a workaround for Stack We want to be able to have the build tool use exactly the compiler and related executables we choose. Stack doesn't really like that mode of operation and insists on getting everything from PATH itself so this commit adds support for creating a temporary symlink farm to convince Stack to use the executables we want it to use. --- cabal-helper.cabal | 23 ++++++- lib/Distribution/Helper.hs | 64 ++----------------- os/posix/Symlink.hs | 2 + os/win/Symlink.hs | 3 + src/CabalHelper/Compiletime/Cabal.hs | 9 +++ src/CabalHelper/Compiletime/CompPrograms.hs | 99 +++++++++++++++++++++++++++++ src/CabalHelper/Compiletime/Types.hs | 7 +- tests/ProgramsTest.hs | 76 ++++++++++++++++++++++ 8 files changed, 222 insertions(+), 61 deletions(-) create mode 100644 os/posix/Symlink.hs create mode 100644 os/win/Symlink.hs create mode 100644 src/CabalHelper/Compiletime/CompPrograms.hs create mode 100644 tests/ProgramsTest.hs diff --git a/cabal-helper.cabal b/cabal-helper.cabal index 384a849..db777ad 100644 --- a/cabal-helper.cabal +++ b/cabal-helper.cabal @@ -120,10 +120,13 @@ common build-deps , temporary < 1.3 && >= 1.2.1 , time < 1.9 && >= 1.6.0.1 , transformers < 0.6 && >= 0.5.2.0 - if !os(windows) + , utf8-string < 1.1 && >= 1.0.1.1 + if os(windows) + build-depends: Win32 < 2.9 && >= 2.8.3.0 + else build-depends: unix < 2.8 && >= 2.7.2.1 build-depends: unix-compat < 0.6 && >= 0.4.3.1 - , utf8-string < 1.1 && >= 1.0.1.1 + if flag(dev) ghc-options: -Wall @@ -132,6 +135,7 @@ library c-h-internal import: build-deps, extensions exposed-modules: CabalHelper.Compiletime.Cabal + CabalHelper.Compiletime.CompPrograms CabalHelper.Compiletime.Compat.Environment CabalHelper.Compiletime.Compat.Version CabalHelper.Compiletime.Compat.Parsec @@ -153,6 +157,12 @@ library c-h-internal Paths_cabal_helper autogen-modules: Paths_cabal_helper + exposed-modules: + Symlink + if os(windows) + hs-source-dirs: os/win + else + hs-source-dirs: os/posix hs-source-dirs: src library @@ -174,7 +184,14 @@ test-suite compile-test ghc-options: -Wall build-depends: c-h-internal - +test-suite programs-test + import: build-deps, extensions + type: exitcode-stdio-1.0 + main-is: ProgramsTest.hs + hs-source-dirs: tests + ghc-options: -Wall + build-depends: c-h-internal + , pretty-show test-suite ghc-session import: build-deps, extensions diff --git a/lib/Distribution/Helper.hs b/lib/Distribution/Helper.hs index 8a3781c..806bf54 100644 --- a/lib/Distribution/Helper.hs +++ b/lib/Distribution/Helper.hs @@ -147,6 +147,7 @@ import qualified CabalHelper.Compiletime.Program.Stack as Stack import qualified CabalHelper.Compiletime.Program.GHC as GHC import qualified CabalHelper.Compiletime.Program.CabalInstall as CabalInstall import CabalHelper.Compiletime.Cabal +import CabalHelper.Compiletime.CompPrograms import CabalHelper.Compiletime.Log import CabalHelper.Compiletime.Process import CabalHelper.Compiletime.Sandbox @@ -160,14 +161,6 @@ import CabalHelper.Compiletime.Compat.Version import Distribution.System (buildPlatform) import Distribution.Text (display) -import Distribution.Verbosity (Verbosity, silent, normal, verbose, deafening) -import Distribution.Simple.GHC as GHC (configure) - -import qualified Distribution.Simple.Program as ProgDb - ( lookupProgram, lookupKnownProgram, programPath - , configureProgram, userMaybeSpecifyPath - , ghcProgram, ghcPkgProgram, haddockProgram ) -import qualified Distribution.Simple.Program.Db as ProgDb -- $type-conventions -- Throughout the API we use the following conventions for type variables: @@ -754,55 +747,12 @@ getConfProgs qe = do -- | Fixup program paths as appropriate for current project-type and bring -- 'Programs' into scope as an implicit parameter. configurePrograms :: QueryEnvI c pt -> PreInfo pt -> IO Programs -configurePrograms QueryEnv{..} pre_info = withVerbosity $ do - guessCompProgramPaths $ case pre_info of - PreInfoStack projPaths -> - Stack.patchCompPrograms projPaths qePrograms - _ -> qePrograms - where - -- | Determine ghc-pkg path from ghc path - guessCompProgramPaths :: Verbose => Programs -> IO Programs - guessCompProgramPaths progs - | same ghcProgram progs dprogs = return progs - guessCompProgramPaths progs = do - let v = getCabalVerbosity - mGhcPath0 | same ghcProgram progs dprogs = Nothing - | otherwise = Just $ ghcProgram progs - mGhcPkgPath0 | same ghcPkgProgram progs dprogs = Nothing - | otherwise = Just $ ghcPkgProgram progs - (_compiler, _mplatform, progdb) - <- GHC.configure - v - mGhcPath0 - mGhcPkgPath0 - ProgDb.defaultProgramDb - let getProg p = ProgDb.programPath <$> ProgDb.lookupProgram p progdb - mghcPath1 = getProg ProgDb.ghcProgram - mghcPkgPath1 = getProg ProgDb.ghcPkgProgram - ghc = fromMaybe (ghcProgram progs) mghcPath1 - ghc_pkg = fromMaybe (ghcPkgProgram progs) mghcPkgPath1 - return progs - { ghcProgram = ghc - , ghcPkgProgram = ghc_pkg - , stackEnv = stackEnv progs ++ - -- TODO: this is a cludge, need to make a symlink farm for - -- stack instead. Note: Haddock also has to be in the compiler - -- dir. - [("PATH", EnvPrepend $ takeDirectory ghc ++ [searchPathSeparator])] - , cabalUnitArgs = cabalUnitArgs progs ++ - maybeToList (("--with-ghc="++) <$> mghcPath1) ++ - maybeToList (("--with-ghc-pkg="++) <$> mghcPkgPath1) - } - - same f o o' = f o == f o' - dprogs = defaultPrograms - -getCabalVerbosity :: Verbose => Verbosity -getCabalVerbosity - | ?verbose 2 = normal - | ?verbose 3 = verbose - | ?verbose 4 = deafening - | otherwise = silent +configurePrograms qe@QueryEnv{..} pre_info = withVerbosity $ do + patchBuildToolProgs (projTypeOfQueryEnv qe) <=< guessCompProgramPaths $ + case pre_info of + PreInfoStack projPaths -> + Stack.patchCompPrograms projPaths qePrograms + _ -> qePrograms newtype Helper pt = Helper { runHelper :: Unit pt -> [String] -> IO [Maybe ChResponse] } diff --git a/os/posix/Symlink.hs b/os/posix/Symlink.hs new file mode 100644 index 0000000..6d97072 --- /dev/null +++ b/os/posix/Symlink.hs @@ -0,0 +1,2 @@ +module Symlink (createSymbolicLink) where +import System.Posix.Files (createSymbolicLink) diff --git a/os/win/Symlink.hs b/os/win/Symlink.hs new file mode 100644 index 0000000..335f1c4 --- /dev/null +++ b/os/win/Symlink.hs @@ -0,0 +1,3 @@ +module Symlink (createSymbolicLink) where +import System.Win32.SymbolicLink (createSymbolicLinkFile) +createSymbolicLink = createSymbolicLinkFile diff --git a/src/CabalHelper/Compiletime/Cabal.hs b/src/CabalHelper/Compiletime/Cabal.hs index c8afab8..d39761d 100644 --- a/src/CabalHelper/Compiletime/Cabal.hs +++ b/src/CabalHelper/Compiletime/Cabal.hs @@ -37,6 +37,8 @@ import System.FilePath import System.IO import Text.Printf +import Distribution.Verbosity (Verbosity, silent, normal, verbose, deafening) + import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 @@ -285,3 +287,10 @@ parseSetupHeader header = case BS8.words header of <*> parsePkgIdBS setupId <*> parsePkgIdBS compId _ -> Nothing + +getCabalVerbosity :: Verbose => Verbosity +getCabalVerbosity + | ?verbose 2 = normal + | ?verbose 3 = verbose + | ?verbose 4 = deafening + | otherwise = silent diff --git a/src/CabalHelper/Compiletime/CompPrograms.hs b/src/CabalHelper/Compiletime/CompPrograms.hs new file mode 100644 index 0000000..020bab4 --- /dev/null +++ b/src/CabalHelper/Compiletime/CompPrograms.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE GADTs #-} + +module CabalHelper.Compiletime.CompPrograms where + +import Data.List +import Data.Maybe +import System.Directory +import System.FilePath +import System.IO.Temp + +import CabalHelper.Compiletime.Types +import CabalHelper.Compiletime.Cabal (getCabalVerbosity) +import Symlink (createSymbolicLink) + +import Distribution.Simple.GHC as GHC (configure) + +import qualified Distribution.Simple.Program as ProgDb + ( lookupProgram, lookupKnownProgram, programPath + , configureProgram, userMaybeSpecifyPath + , ghcProgram, ghcPkgProgram, haddockProgram ) +import qualified Distribution.Simple.Program.Db as ProgDb + +-- | Determine ghc-pkg/haddock path from ghc path +guessCompProgramPaths :: Verbose => Programs -> IO Programs +guessCompProgramPaths progs = do + let v = getCabalVerbosity + getMaybeProg' = getMaybeProg progs + progdb = + ProgDb.userMaybeSpecifyPath "ghc" (getMaybeProg' ghcProgram) $ + ProgDb.userMaybeSpecifyPath "ghc-pkg" (getMaybeProg' ghcPkgProgram) $ + ProgDb.userMaybeSpecifyPath "haddock" (getMaybeProg' haddockProgram) $ + ProgDb.defaultProgramDb + (_compiler, _mplatform, progdb1) <- GHC.configure v Nothing Nothing progdb + let Just haddockKnownProgram = ProgDb.lookupKnownProgram "haddock" progdb1 + progdb2 <- ProgDb.configureProgram v haddockKnownProgram progdb1 + let getProg p = ProgDb.programPath <$> ProgDb.lookupProgram p progdb2 + return progs + { ghcProgram = + fromMaybe (ghcProgram progs) $ getProg ProgDb.ghcProgram + , ghcPkgProgram = + fromMaybe (ghcPkgProgram progs) $ getProg ProgDb.ghcPkgProgram + , haddockProgram = + fromMaybe (haddockProgram progs) $ getProg ProgDb.haddockProgram + } + +getMaybeProg :: Programs -> (Programs -> FilePath) -> Maybe FilePath +getMaybeProg progs fn + | fn progs == fn defaultPrograms = Nothing + | otherwise = Just (fn progs) + +patchBuildToolProgs :: SProjType pt -> Programs -> IO Programs +patchBuildToolProgs (SCabal _) progs = return progs + { cabalUnitArgs = concat + [ maybeToList (("--with-ghc="++) <$> getMaybeProg progs ghcProgram) + , maybeToList (("--with-ghc-pkg="++) <$> getMaybeProg progs ghcPkgProgram) + , maybeToList (("--with-haddock="++) <$> getMaybeProg progs haddockProgram) + ] ++ cabalUnitArgs progs + } +patchBuildToolProgs SStack progs + -- optimization; if none of the program paths are non-default we don't + -- even have to add anything to PATH. + | ghcProgram progs == "ghc" + , ghcPkgProgram progs == "ghc-pkg" + , haddockProgram progs == "haddock" + = return progs + + -- optimization; if all paths are unqualified and have the same version + -- postfix Stack's default behaviour works for us. + | [ghc] <- splitPath (ghcProgram progs) + , [ghcPkg] <- splitPath (ghcPkgProgram progs) + , [haddock] <- splitPath (haddockProgram progs) + , Just ver <- stripPrefix "ghc-" ghc + , Just ver == stripPrefix "ghc-pkg-" ghcPkg + , Just ver == stripPrefix "haddock-" haddock + = return progs +patchBuildToolProgs SStack progs = do + -- otherwise fall back to creating a symlink farm + -- + -- This is of course all quite horrible and we would much prefer just + -- being able to pass executable paths straight through to stack but + -- currently there is no option to let us do that. + withSystemTempDirectory "cabal-helper-symlinks" $ \bindir -> do + createProgSymlink bindir $ ghcProgram progs + createProgSymlink bindir $ ghcPkgProgram progs + createProgSymlink bindir $ haddockProgram progs + return $ progs + { stackEnv = + [("PATH", EnvPrepend $ bindir ++ [searchPathSeparator])] ++ + stackEnv progs + } + +createProgSymlink :: FilePath -> FilePath -> IO () +createProgSymlink bindir target + | [exe] <- splitPath target = do + Just exe_path <- findExecutable exe + createSymbolicLink exe_path (bindir takeFileName target) + | otherwise = do + cwd <- getCurrentDirectory + createSymbolicLink (cwd target) (bindir takeFileName target) diff --git a/src/CabalHelper/Compiletime/Types.hs b/src/CabalHelper/Compiletime/Types.hs index 6591513..94e5c8e 100644 --- a/src/CabalHelper/Compiletime/Types.hs +++ b/src/CabalHelper/Compiletime/Types.hs @@ -562,12 +562,17 @@ data Programs = Programs , ghcPkgProgram :: !FilePath -- ^ The path to the @ghc-pkg@ program. If not changed it will be derived -- from the path to 'ghcProgram'. + + , haddockProgram :: !FilePath + -- ^ The path to the @haddock@ program. If not changed it will be + -- derived from the path to 'ghcProgram'. } deriving (Eq, Ord, Show, Read, Generic, Typeable) -- | By default all programs use their unqualified names, i.e. they will be -- searched for on @PATH@. defaultPrograms :: Programs -defaultPrograms = Programs "cabal" [] [] "stack" [] [] [] "ghc" "ghc-pkg" +defaultPrograms = + Programs "cabal" [] [] "stack" [] [] [] "ghc" "ghc-pkg" "haddock" data EnvOverride = EnvPrepend String diff --git a/tests/ProgramsTest.hs b/tests/ProgramsTest.hs new file mode 100644 index 0000000..467c1cc --- /dev/null +++ b/tests/ProgramsTest.hs @@ -0,0 +1,76 @@ +{-| This test checks if 'guessCompProgramPaths'\'s behaviour makes sense +-} + +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + +import Control.Monad +import Data.List +import System.Directory +import System.Environment +import System.Exit +import System.FilePath +import System.IO.Temp +import Text.Show.Pretty + +import CabalHelper.Compiletime.Types +import CabalHelper.Compiletime.CompPrograms +import Symlink (createSymbolicLink) + +main :: IO () +main = do + prog_name <- getProgName + args <- getArgs + case prog_name of + "programs-test" + | "ghc":ver:rest <- args -> ghc ver rest + | "ghc-pkg":ver:rest <- args -> ghc_pkg ver rest + | "haddock":ver:rest <- args -> haddock ver rest + | otherwise -> do_test + _ + | Just ver <- stripPrefix "ghc-pkg-" prog_name -> ghc_pkg ver args + | Just ver <- stripPrefix "ghc-" prog_name -> ghc ver args + | Just ver <- stripPrefix "haddock-" prog_name -> haddock ver args + where + ghc _ver ["--info"] = putStrLn "[]" -- seems we can get away with that :) + ghc ver ["--numeric-version"] = putStrLn ver + ghc _ver ["--supported-languages"] = return () + + ghc_pkg ver ["--version"] = + putStrLn $ "GHC package manager version " ++ ver + + haddock _ver ["--version"] = + putStrLn $ -- cabal isn't very picky about haddock versions so we just + -- hardocde it here + "Haddock version 2.20.0, (c) Simon Marlow 2006" ++ + "Ported to use the GHC API by David Waern 2006-2008" + +do_test :: IO () +do_test = do + prog <- canonicalizePath =<< getExecutablePath + + withSystemTempDirectory "c-h-programs-test" $ \tmpdir -> do + + forM_ ["8.6.5", "8.4.4"] $ \ver -> do + + let ghc = tmpdir "ghc-" ++ ver + let ghc_pkg = tmpdir "ghc-pkg-" ++ ver + let haddock = tmpdir "haddock-" ++ ver + let progs = defaultPrograms { ghcProgram = ghc } + + createSymbolicLink prog ghc + createSymbolicLink prog ghc_pkg + createSymbolicLink prog haddock + + let ?verbose = (==4) + + progs' <- guessCompProgramPaths progs + + pPrint (ghc, ghc_pkg, haddock) -- expected + pPrint progs' -- actual + + when (not $ and [ ghcPkgProgram progs' == ghc_pkg + , haddockProgram progs' == haddock + ]) + exitFailure + + putStr "\n\n" -- cgit v1.2.3