From fbdc40affeeb41c3aaf357cceab9829a6c00e36b Mon Sep 17 00:00:00 2001 From: Daniel Gröber Date: Sun, 26 Aug 2018 19:24:03 +0200 Subject: Remove wrapper, integrate functionality into the library The use of a wrapper executable to compile the real helper was a design mistake originally intended to isolate the calling application from a dependency on the Cabal library completely. This isolation turned out to be rather tedious and thus was ignored soon, the wrapper remained though. Due to the way cabal-install installs components of a package into seperate install trees when using new-install finding the wrapper exe reliably has become pretty much impossible without huge effort. Hence we remove it and integrate the functionality into the library instead. --- lib/Distribution/Helper.hs | 365 +++++++++++++++++++++------------------------ 1 file changed, 169 insertions(+), 196 deletions(-) (limited to 'lib/Distribution/Helper.hs') diff --git a/lib/Distribution/Helper.hs b/lib/Distribution/Helper.hs index 1d93b84..622972a 100644 --- a/lib/Distribution/Helper.hs +++ b/lib/Distribution/Helper.hs @@ -14,10 +14,9 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . -{-# LANGUAGE CPP, RecordWildCards, FlexibleContexts, ConstraintKinds, +{-# LANGUAGE RecordWildCards, FlexibleContexts, ConstraintKinds, GeneralizedNewtypeDeriving, DeriveDataTypeable, DeriveGeneric, DeriveFunctor, - NamedFieldPuns, OverloadedStrings - #-} + NamedFieldPuns, OverloadedStrings, ViewPatterns #-} {-| Module : Distribution.Helper @@ -80,7 +79,7 @@ module Distribution.Helper ( , NeedsBuildOutput(..) -- * General information - , buildPlatform + , Distribution.Helper.buildPlatform -- * Stuff that cabal-install really should export , Distribution.Helper.getSandboxPkgDb @@ -90,10 +89,6 @@ module Distribution.Helper ( , reconfigure , writeAutogenFiles - -- * $libexec related error handling - , LibexecNotFoundError(..) - , libexecNotFoundError - -- * Reexports , module Data.Functor.Apply ) where @@ -105,46 +100,40 @@ import Control.Monad.IO.Class import Control.Monad.State.Strict import Control.Monad.Reader import Control.Exception as E -import Data.Char import Data.List import Data.Maybe -import qualified Data.Map as Map +import qualified Data.Map.Strict as Map import Data.Version -import Data.Typeable +import qualified Data.Text as Text import Data.Function import Data.Functor.Apply -import Distribution.System (buildOS, OS(Windows)) import System.Environment import System.FilePath hiding ((<.>)) -import qualified System.FilePath as FP import System.Directory import System.Process -import System.IO.Unsafe import Text.Printf -import GHC.Generics +import Text.Show.Pretty import Prelude -import Paths_cabal_helper (getLibexecDir) + +import CabalHelper.Compiletime.Compile +import CabalHelper.Compiletime.Types import CabalHelper.Shared.InterfaceTypes import CabalHelper.Shared.Sandbox --- | Paths or names of various programs we need. -data Programs = Programs { - -- | The path to the @cabal@ program. - cabalProgram :: FilePath, - -- | The path to the @ghc@ program. - ghcProgram :: FilePath, +import Distribution.System (buildPlatform) +import Distribution.Text (display) +import Distribution.Verbosity (silent, deafening) +import Distribution.Package (packageName, packageVersion) +import Distribution.Simple.GHC as GHC (configure) + +import qualified CabalHelper.Compiletime.Compat.ProgramDb as ProgDb + ( defaultProgramDb, programPath, lookupProgram, ghcProgram, ghcPkgProgram) +import CabalHelper.Compiletime.Compat.Version +import CabalHelper.Shared.Common - -- | The path to the @ghc-pkg@ program. If - -- not changed it will be derived from the path to 'ghcProgram'. - ghcPkgProgram :: FilePath - } deriving (Eq, Ord, Show, Read, Generic, Typeable) --- | Default all programs to their unqualified names, i.e. they will be searched --- for on @PATH@. -defaultPrograms :: Programs -defaultPrograms = Programs "cabal" "ghc" "ghc-pkg" -- | Environment for running a 'Query'. The real constructor is not exposed, -- the field accessors are however. See below. Use the 'mkQueryEnv' smart @@ -353,35 +342,41 @@ reconfigure readProc progs cabalOpts = do readHelper :: (MonadIO m, MonadQuery m) => [String] -> m [Maybe ChResponse] readHelper args = ask >>= \qe -> liftIO $ do - out <- either error id <$> invokeHelper qe args + out <- invokeHelper qe args let res = read out liftIO $ evaluate res `E.catch` \se@(SomeException _) -> do md <- lookupEnv' "CABAL_HELPER_DEBUG" let msg = "readHelper: exception: '" ++ show se ++ "'" - error $ msg ++ case md of + panicIO $ msg ++ case md of Nothing -> ", for more information set the environment variable CABAL_HELPER_DEBUG" Just _ -> ", output: '"++ out ++"'" -invokeHelper :: QueryEnv -> [String] -> IO (Either String String) -invokeHelper QueryEnv {..} args = do - let progArgs = [ "--with-ghc=" ++ ghcProgram qePrograms - , "--with-ghc-pkg=" ++ ghcPkgProgram qePrograms - , "--with-cabal=" ++ cabalProgram qePrograms - ] - exe <- findLibexecExe - let args' = progArgs ++ "v1-style":qeProjectDir:qeDistDir:args - out <- qeReadProcess exe args' "" - (Right <$> evaluate out) `E.catch` \(SomeException _) -> - return $ Left $ concat - ["invokeHelper", ": ", exe, " " - , intercalate " " (map show args') - , " failed" - ] - -getPackageId :: MonadQuery m => m (String, Version) -getPackageId = ask >>= \QueryEnv {..} -> do - [ Just (ChResponseVersion pkgName pkgVer) ] <- readHelper [ "package-id" ] - return (pkgName, pkgVer) +invokeHelper :: QueryEnv -> [String] -> IO String +invokeHelper QueryEnv {..} args0 = do + let opts = defaultCompileOptions + { oPrograms = qePrograms + , oCabalPkgDb = PackageDbDir <$> qeCabalPkgDb } + + opts' <- overrideVerbosityEnvVar =<< guessProgramPaths opts + + exe <- wrapperV1 opts' qeProjectDir qeDistDir + + let args1 = qeProjectDir : qeDistDir : args0 + + out <- qeReadProcess exe args1 "" + evaluate out `E.catch` \(SomeException _) -> + panicIO $ concat + ["invokeHelper", ": ", exe, " " + , intercalate " " (map show args1) + , " failed!" + ] + +getPackageId :: (MonadQuery m, MonadIO m) => m (String, Version) +getPackageId = ask >>= \QueryEnv {..} -> liftIO $ do + let v = silent + [cfile] <- filter isCabalFile <$> getDirectoryContents qeProjectDir + gpd <- readPackageDescription v (qeProjectDir cfile) + return $ (display (packageName gpd), toDataVersion (packageVersion gpd)) getSomeConfigState :: MonadQuery m => m SomeLocalBuildInfo getSomeConfigState = ask >>= \QueryEnv {..} -> do @@ -439,151 +434,129 @@ writeAutogenFiles qe = liftIO $ void $ invokeHelper qe ["write-autogen-files"] -- | Get the path to the sandbox package-db in a project -getSandboxPkgDb :: (FilePath -> [String] -> String -> IO String) - -> String - -- ^ Cabal build platform, i.e. @buildPlatform@ - -> Version - -- ^ GHC version (@cProjectVersion@ is your friend) - -> IO (Maybe FilePath) -getSandboxPkgDb readProc = - CabalHelper.Shared.Sandbox.getSandboxPkgDb $ unsafePerformIO $ buildPlatform readProc - -buildPlatform :: (FilePath -> [String] -> String -> IO String) -> IO String -buildPlatform readProc = do - exe <- findLibexecExe - CabalHelper.Shared.Sandbox.dropWhileEnd isSpace <$> readProc exe ["print-build-platform"] "" - --- | This exception is thrown by all 'runQuery' functions if the internal --- wrapper executable cannot be found. You may catch this and present the user --- an appropriate error message however the default is to print --- 'libexecNotFoundError'. -data LibexecNotFoundError = LibexecNotFoundError String FilePath - deriving (Typeable) -instance Exception LibexecNotFoundError -instance Show LibexecNotFoundError where - show (LibexecNotFoundError exe dir) = - libexecNotFoundError exe dir "https://github.com/DanielG/cabal-helper/issues" - -findLibexecExe :: IO FilePath -findLibexecExe = do - libexecdir <- getLibexecDir - let exeName = "cabal-helper-wrapper" - exe = libexecdir exeName FP.<.> exeExtension' - - exists <- doesFileExist exe - - if exists - then return exe - else do - mdir <- tryFindCabalHelperTreeDistDir - dir <- case mdir of - Nothing -> - throwIO $ LibexecNotFoundError exeName libexecdir - Just dir -> - return dir - - return $ dir "build" exeName exeName - -findPlanJson :: FilePath -> IO (Maybe FilePath) -findPlanJson base = - findFile (map ( "cache") $ parents base) "plan.json" - -parents :: FilePath -> [FilePath] -parents path = takeWhile (not . (`elem` ["", "."]) . dropDrive) dirs - where dirs = iterate takeDirectory path - -data DistDir = DistDir { ddType :: DistDirType, unDistDir :: FilePath } - deriving (Eq, Ord, Read, Show) -data DistDirType = NewBuildDist | OldBuildDist - deriving (Eq, Ord, Read, Show) - -tryFindCabalHelperTreeDistDir :: IO (Maybe FilePath) -tryFindCabalHelperTreeDistDir = do - exe <- canonicalizePath =<< getExecutablePath' - mplan <- findPlanJson exe - let mdistdir = takeDirectory . takeDirectory <$> mplan - cwd <- getCurrentDirectory - - let candidates = sortBy (compare `on` ddType) $ concat - [ maybeToList $ DistDir NewBuildDist <$> mdistdir - , [ DistDir OldBuildDist $ (!!3) $ iterate takeDirectory exe ] - , if takeFileName exe == "ghc" -- we're probably in ghci; try CWD - then [ DistDir NewBuildDist $ cwd "dist-newstyle" - , DistDir NewBuildDist $ cwd "dist" - , DistDir OldBuildDist $ cwd "dist" - ] - else [] - ] - - distdirs - <- filterM isDistDir candidates - >>= mapM toOldBuildDistDir - - return $ fmap unDistDir $ join $ listToMaybe $ distdirs - -isCabalHelperSourceDir :: FilePath -> IO Bool -isCabalHelperSourceDir dir = - doesFileExist $ dir "cabal-helper.cabal" - -isDistDir :: DistDir -> IO Bool -isDistDir (DistDir NewBuildDist dir) = - doesFileExist (dir "cache" "plan.json") -isDistDir (DistDir OldBuildDist dir) = - doesFileExist (dir "setup-config") - -toOldBuildDistDir :: DistDir -> IO (Maybe DistDir) -toOldBuildDistDir (DistDir NewBuildDist dir) = do - PlanJson {pjUnits} <- decodePlanJson $ dir "cache" "plan.json" - let munit = find isCabalHelperUnit $ Map.elems pjUnits - return $ DistDir OldBuildDist <$> join ((\Unit { uDistDir = mdistdir } -> mdistdir) <$> munit) - where - isCabalHelperUnit - Unit { uPId = PkgId (PkgName n) _ - , uType = UnitTypeLocal - , uComps - } | n == "cabal-helper" && - Map.member (CompNameExe "cabal-helper-wrapper") uComps - = True - isCabalHelperUnit _ = False -toOldBuildDistDir x = return $ Just x - - - - -libexecNotFoundError :: String -- ^ Name of the executable we were trying to - -- find - -> FilePath -- ^ Path to @$libexecdir@ - -> String -- ^ URL the user will be directed towards to - -- report a bug. - -> String -libexecNotFoundError exe dir reportBug = printf - ( "Could not find $libexecdir/%s\n" - ++"\n" - ++"If you are a cabal-helper developer you can set the environment variable\n" - ++"`cabal_helper_libexecdir' to override $libexecdir[1]. The following will\n" - ++"work in the cabal-helper source tree:\n" - ++"\n" - ++" $ export cabal_helper_libexecdir=$PWD/dist/build/%s\n" - ++"\n" - ++"[1]: %s\n" - ++"\n" - ++"If you don't know what I'm talking about something went wrong with your\n" - ++"installation. Please report this problem here:\n" - ++"\n" - ++" %s") exe exe dir reportBug - -getExecutablePath' :: IO FilePath -getExecutablePath' = -#if MIN_VERSION_base(4,6,0) - getExecutablePath -#else - getProgName -#endif +getSandboxPkgDb + :: String + -- ^ Cabal build platform, i.e. @buildPlatform@ + -> Version + -- ^ GHC version (@cProjectVersion@ is your friend) + -> FilePath + -- ^ Path to the project directory, i.e. a directory containing a + -- @cabal.sandbox.config@ file + -> IO (Maybe FilePath) +getSandboxPkgDb buildPlat ghc_ver projdir = + CabalHelper.Shared.Sandbox.getSandboxPkgDb buildPlat ghc_ver projdir + +buildPlatform :: String +buildPlatform = display Distribution.System.buildPlatform lookupEnv' :: String -> IO (Maybe String) lookupEnv' k = lookup k <$> getEnvironment -exeExtension' :: FilePath -exeExtension' - | Windows <- buildOS = "exe" - | otherwise = "" + +guessProgramPaths :: CompileOptions -> IO CompileOptions +guessProgramPaths opts = do + let v | oVerbose opts = deafening + | otherwise = silent + + 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 + + progs' = progs + { ghcProgram = fromMaybe (ghcProgram progs) mghcPath1 + , ghcPkgProgram = fromMaybe (ghcProgram progs) mghcPkgPath1 + } + return opts { oPrograms = progs' } + where + same f o o' = f o == f o' + progs = oPrograms opts + dprogs = defaultPrograms + +overrideVerbosityEnvVar :: CompileOptions -> IO CompileOptions +overrideVerbosityEnvVar opts = do + x <- lookup "CABAL_HELPER_DEBUG" <$> getEnvironment + return $ case x of + Just _ -> opts { oVerbose = True } + Nothing -> opts + +wrapperV1 + :: CompileOptions + -> FilePath + -> FilePath + -> IO FilePath +wrapperV1 opts projdir distdir = do + cfgf <- canonicalizePath (distdir "setup-config") + mhdr <- getCabalConfigHeader cfgf + case (mhdr, oCabalVersion opts) of + (Nothing, _) -> panicIO $ printf "\ +\Could not read Cabal's persistent setup configuration header\n\ +\- Check first line of: %s\n\ +\- Maybe try: $ cabal configure" cfgf + (Just (hdrCabalVersion, _), Just ver) + | hdrCabalVersion /= ver -> panicIO $ printf "\ +\Cabal version %s was requested but setup configuration was\n\ +\written by version %s" (showVersion ver) (showVersion hdrCabalVersion) + (Just (hdrCabalVersion, _), _) -> do + compileHelper' opts hdrCabalVersion projdir Nothing distdir + +wrapperV2 + :: CompileOptions + -> FilePath + -> FilePath + -> UnitId + -> IO (FilePath, FilePath) +wrapperV2 opts projdir distdir unitid@(UnitId (Text.unpack -> unitid')) = do + let plan_path = distdir "cache" "plan.json" + plan@PlanJson {pjCabalLibVersion=Ver (makeDataVersion -> pjCabalLibVersion) } + <- decodePlanJson plan_path + case oCabalVersion opts of + Just ver | pjCabalLibVersion /= ver -> let + sver = showVersion ver + spjVer = showVersion pjCabalLibVersion + in panicIO $ printf "\ +\Cabal version %s was requested but plan.json was written by version %s" sver spjVer + _ -> case Map.lookup unitid $ pjUnits plan of + Just u@Unit {uType} | uType /= UnitTypeLocal -> do + panicIO $ "\ +\UnitId '"++ unitid' ++"' points to non-local unit: " ++ ppShow u + Just Unit {uDistDir=Nothing} -> panicIO $ printf "\ +\plan.json doesn't contain 'dist-dir' for UnitId '"++ unitid' ++"'" + Just Unit {uType=UnitTypeLocal, uDistDir=Just distdirv1} -> do + exe <- compileHelper' opts pjCabalLibVersion projdir (Just (plan, distdir)) distdirv1 + return (exe, distdirv1) + _ -> let + units = map (\(UnitId u) -> Text.unpack u) + $ Map.keys + $ Map.filter ((==UnitTypeLocal) . uType) + $ pjUnits plan + units_list = unlines $ map (" "++) units + in + panicIO $ "\ +\UnitId '"++ unitid' ++"' not found in plan.json, available local units:\n" ++ units_list + + +compileHelper' + :: CompileOptions + -> Version + -> FilePath + -> Maybe (PlanJson, FilePath) + -> FilePath + -> IO FilePath +compileHelper' opts pjCabalLibVersion projdir mnewstyle distdirv1 = do + eexe <- compileHelper opts pjCabalLibVersion projdir mnewstyle distdirv1 + case eexe of + Left rv -> + panicIO $ "compileHelper': compiling helper failed! (exit code "++ show rv + Right exe -> + return exe -- cgit v1.2.3