diff --git a/app/BuildEnv/Options.hs b/app/BuildEnv/Options.hs new file mode 100644 --- /dev/null +++ b/app/BuildEnv/Options.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE DataKinds #-} + +-- | +-- Module : BuildEnv.Options +-- Description : Options for the command-line interface of @build-env@ +-- +-- This module declares datatypes which specify the structure of the options +-- expected by the command-line interface of @build-env@. +module BuildEnv.Options where + +-- containers +import Data.Set + ( Set ) + +-- build-env +import BuildEnv.CabalPlan +import BuildEnv.Config + +-------------------------------------------------------------------------------- + +-- | The command-line options for the @build-env@ application. +data Opts = Opts { compiler :: Compiler + , cabal :: Cabal + , mode :: Mode + , verbosity :: Verbosity + , delTemp :: TempDirPermanence + , workDir :: FilePath + } + +-- | The mode in which to run the executable: +-- +-- - compute a build plan, +-- - fetch sources, +-- - build and register packages. +data Mode + -- | Find a build plan. + = PlanMode + { planModeInputs :: PlanInputs + , planOutput :: FilePath + -- ^ Where to output the @plan.json@ file. + } + -- | Fetch sources from a build plan. + | FetchMode + FetchDescription -- ^ what to fetch + NewOrExisting -- ^ whether to create a new directory + -- or add to an existing one + -- | Build and register packages from fetched sources. + | BuildMode Build + +-- | How to specify which packages/units to constraint/build. +data PackageData pkgs + -- | Explicit description of packages/units. + = Explicit pkgs + -- | Parse package information from the given file. + -- + -- The file contents will be interpreted as follows: + -- + -- - pinned packages: this is a @cabal.config@ freeze file, + -- which uses @cabal.project@ syntax. See 'readCabalDotConfig'. + -- + -- - seed units: this is a list of seed units to build, + -- with inline flags and constraints, and allow-newer stanzas. + -- See 'parseSeedFile'. + | FromFile FilePath + deriving stock Show + +-- | Inputs for the computation of a cabal plan. +data PlanInputs + = PlanInputs + { planUnits :: PackageData UnitSpecs + -- ^ Seed dependencies for the build plan. + , planPins :: Maybe (PackageData PkgSpecs) + -- ^ Additional package constraints. + , planAllowNewer :: AllowNewer + -- ^ Allow-newer specification. + } + deriving stock Show + +-- | Information about fetched sources: in which directory they belong, +-- and what build plan they correspond to. +data FetchDescription + = FetchDescription + { rawFetchDir :: FilePath + -- ^ Directory for fetched sources. + , fetchInputPlan :: Plan + -- ^ The build plan corresponding to the fetched sources. + } + deriving stock Show + +-- | How to obtain a plan: either by computing it, +-- or by using an existing @plan.json@ plan. +data Plan + -- | Compute a plan. + = ComputePlan + PlanInputs + -- ^ Input needed to compute the plan. + (Maybe FilePath) + -- ^ Optional filepath at which to write out the computed plan. + + -- | Use an existing @plan.json@ by reading the given file. + | UsePlan + { planJSONPath :: FilePath } + deriving stock Show + +-- | At which point to start/continue a build. +data BuildStart + -- | Fetch sources and start a new build. + = Fetch NewOrExisting + -- | Start a new build from prefetched sources. + | Prefetched + -- | Resume a previous build. + | Resume + deriving stock ( Show, Eq, Ord ) + +-- | Whether to create a new directory or use an existing directory. +data NewOrExisting + -- | Create a new directory. + = New + -- | Update an existing directory. + | Existing + deriving stock ( Show, Eq, Ord ) + +-- | Information needed to perform a build. +data Build + = Build + { buildRawPaths :: Paths Raw + -- ^ The directories relevant for the build: + -- + -- - fetched sources directory, + -- - build output directory structure + , buildStart :: BuildStart + -- ^ At which stage should the build start? + , buildBuildPlan :: Plan + -- ^ The build plan to follow. + , buildStrategy :: BuildStrategy + -- ^ How to perform the build (see 'BuildStrategy'). + , mbOnlyDepsOf :: Maybe ( Set PkgName ) + -- ^ @Just pkgs@ <=> only build @pkgs@ (and their dependencies). + -- @Nothing@ <=> build all units in the build plan. + , userUnitArgs :: ConfiguredUnit -> UnitArgs + -- ^ Extra per-unit arguments. + } diff --git a/app/BuildEnv/Parse.hs b/app/BuildEnv/Parse.hs new file mode 100644 --- /dev/null +++ b/app/BuildEnv/Parse.hs @@ -0,0 +1,486 @@ + +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : BuildEnv.Parse +-- Description : Command-line option parser for @build-env@ +-- +-- This module implements the command-line options parsing for @build-env@. +module BuildEnv.Parse ( options, runOptionsParser ) where + +-- base +import Data.Char + ( isSpace ) +import Data.Bool + ( bool ) +import System.Environment + ( getArgs ) + +-- containers +import qualified Data.Map.Strict as Map + ( empty, fromList, singleton ) +import Data.Set + ( Set ) +import qualified Data.Set as Set + ( fromList, singleton ) + +-- optparse-applicative +import Options.Applicative + +-- text +import Data.Text + ( Text ) +import qualified Data.Text as Text + ( break, pack, splitOn, unpack ) + +-- build-env +import BuildEnv.CabalPlan +import BuildEnv.Config +import BuildEnv.Options +import BuildEnv.Utils + ( splitOn ) + +-------------------------------------------------------------------------------- + +-- | Run the command-line options parser. +runOptionsParser :: FilePath -> IO Opts +runOptionsParser currWorkDir = do + args <- getArgs + handleParseResult $ execParserPure pPrefs pInfo args + where + pInfo = + info ( helper <*> options currWorkDir ) + ( fullDesc + <> header "build-env - compute, fetch and build Cabal build plans" ) + pPrefs = prefs $ + mconcat [ showHelpOnEmpty + , subparserInline + , helpShowGlobals + , multiSuffix "*" + , columns 90 ] + +-- | The command-line options parser for the 'build-env' executable. +options :: FilePath -> Parser Opts +options currWorkDir = do + mode <- optMode + compiler <- optCompiler + cabal <- optCabal + workDir <- optChangeWorkingDirectory currWorkDir + verbosity <- optVerbosity + delTemp <- optTempDirPermanence + pure $ Opts { compiler, cabal, mode, verbosity, delTemp, workDir } + +-- | Parse @ghc@ and @ghc-pkg@ paths. +optCompiler :: Parser Compiler +optCompiler = + Compiler + <$> option str + ( long "ghc" + <> value "ghc" + <> help "'ghc' executable path" + <> metavar "GHC" + ) + <*> option str + ( long "ghc-pkg" + <> value "ghc-pkg" + <> help "'ghc-pkg' executable path" + <> metavar "GHC-PKG" + ) + +-- | Parse @cabal@ path. +optCabal :: Parser Cabal +optCabal = do + cabalPath <- + option str + ( long "cabal" + <> value "cabal" + <> help "'cabal' executable path" + <> metavar "CABAL" ) + globalCabalArgs <- + many $ option str ( long "cabal-arg" + <> help "Pass argument to 'cabal'" + <> metavar "ARG" ) + pure $ Cabal { cabalPath, globalCabalArgs } + +-- | Parse a @cwd@ (change working directory) option. +optChangeWorkingDirectory :: FilePath -> Parser FilePath +optChangeWorkingDirectory currWorkDir = + option str + ( long "cwd" + <> value currWorkDir + <> help "Set working directory" + <> metavar "DIR" ) + +-- | Parse verbosity. +optVerbosity :: Parser Verbosity +optVerbosity = + Verbosity <$> + option auto + ( long "verbosity" + <> short 'v' + <> help "Verbosity" + <> metavar "INT" + <> value 1 ) + +-- | Parse whether to delete temporary directories. +optTempDirPermanence :: Parser TempDirPermanence +optTempDirPermanence = + bool DeleteTempDirs Don'tDeleteTempDirs <$> + switch ( long "preserve-tmp" + <> help "Preserve temporary build directories (useful for debugging)" ) + +-- | Parse the mode in which to run the application: plan, fetch, build. +optMode :: Parser Mode +optMode = + hsubparser . mconcat $ + [ command "plan" $ + info ( PlanMode <$> planInputs Planning <*> optOutput ) + ( fullDesc <> planInfo ) + , command "fetch" $ + info ( FetchMode <$> fetchDescription <*> newOrExisting ) + ( fullDesc <> fetchInfo ) + , command "build" $ + info ( BuildMode <$> build ) + ( fullDesc <> buildInfo ) + ] + where + optOutput :: Parser FilePath + optOutput = + option str ( short 'p' + <> long "plan" + <> help "Output 'plan.json' file" + <> metavar "OUTFILE" + ) + planInfo, fetchInfo, buildInfo :: InfoMod a + planInfo = progDesc "Compute a build plan from a collection of seeds" + fetchInfo = progDesc "Fetch package sources" + buildInfo = progDesc "Build and register packages" + +-- | Description of which mode we are in. +-- +-- Used to generate help-text that is specific to a certain mode. +data ModeDescription + = Planning + | Fetching + | Building + deriving stock Show + +-- | Text describing a mode of the @build-env@ executable. +modeDescription :: ModeDescription -> String +modeDescription modeDesc = + case modeDesc of + Planning -> "Build plan" + Fetching -> "Fetch plan" + Building -> "Build" + +-- | Obtain a collection of seed packages. +-- +-- Might be for computing a build plan, fetching sources, or building packages. +planInputs :: ModeDescription -> Parser PlanInputs +planInputs modeDesc = do + + planPins <- optional (freeze modeDesc) + planUnits <- dependencies modeDesc + planAllowNewer <- allowNewer + + pure $ PlanInputs { planPins, planUnits, planAllowNewer } + +-- | Parse a list of pinned packages from a 'cabal.config' freeze file. +freeze :: ModeDescription -> Parser ( PackageData PkgSpecs ) +freeze modeDesc = FromFile <$> freezeFile + where + freezeFile :: Parser FilePath + freezeFile = option str ( long "freeze" <> help helpStr <> metavar "INFILE" ) + + helpStr :: String + helpStr = modeDescription modeDesc <> " 'cabal.config' freeze file" + +-- | Parse @allow-newer@ options. +allowNewer :: Parser AllowNewer +allowNewer = + fmap mconcat . many $ + option readAllowNewer + ( long "allow-newer" <> help "Allow-newer specification" + <> metavar "PKG1:PKG2" ) + where + readAllowNewer :: ReadM AllowNewer + readAllowNewer = do + allowNewerString <- str + case parseAllowNewer allowNewerString of + Just an -> return an + Nothing -> + readerError $ + "Invalid allow-newer specification.\n" ++ + "Should be of the form: pkg1:pkg2,*:base,..." + + parseAllowNewer :: String -> Maybe AllowNewer + parseAllowNewer = fmap ( AllowNewer . Set.fromList ) + . traverse oneAllowNewer + . splitOn ',' + + oneAllowNewer :: String -> Maybe (Text, Text) + oneAllowNewer s + | (Text.pack -> a, Text.pack . drop 1 -> b) <- break (== ':') s + , a == "*" || validPackageName a + , b == "*" || validPackageName b + = Just (a,b) + | otherwise + = Nothing + +-- | Parse a collection of seed dependencies, either from a seed file +-- or from explicit command-line arguments. +dependencies :: ModeDescription -> Parser ( PackageData UnitSpecs ) +dependencies modeDesc + = ( FromFile <$> seeds ) + <|> explicitUnits + + where + + seeds :: Parser FilePath + seeds = option str ( long "seeds" <> help seedsHelp <> metavar "INFILE" ) + + explicitUnits :: Parser ( PackageData UnitSpecs ) + explicitUnits = do + units <- some ( argument readUnitSpec (metavar "UNIT" <> help unitsHelp) ) + locals <- many localPkg + pure $ Explicit $ + foldl unionUnitSpecsCombining Map.empty units + `unionUnitSpecsCombining` + Map.fromList + [ (pkg, (Local loc, emptyPkgSpec, mempty)) + | (pkg, loc) <- locals ] + + localPkg :: Parser (PkgName, FilePath) + localPkg = + option readLocalPkg + ( long "local" + <> help "Local package source location" + <> metavar "PKG=PATH" ) + + readLocalPkg :: ReadM (PkgName, FilePath) + readLocalPkg = do + ln <- str + case Text.splitOn "=" ln of + pkg:loc:_ + | validPackageName pkg + -> return (PkgName pkg, Text.unpack loc) + _ -> readerError $ + "Could not parse --local argument\n" ++ + "Valid usage is of the form: --local PKG=PATH" + + readUnitSpec :: ReadM UnitSpecs + readUnitSpec = do + ln <- str + let (pkgTyComp, rest) = Text.break isSpace ln + spec = parsePkgSpec rest + case parsePkgComponent pkgTyComp of + Nothing -> readerError $ "Cannot parse package name: " <> Text.unpack ln + Just (pkgNm, comp) -> + return $ Map.singleton pkgNm (Remote, spec, Set.singleton comp) + + unitsHelp, seedsHelp :: String + (unitsHelp, seedsHelp) = (what <> " seed unit", what <> " seed file") + where + what = modeDescription modeDesc + +-- | Parse how we will obtain a build plan: by computing it, or by reading +-- from a @plan.json@ on disk? +plan :: ModeDescription -> Parser Plan +plan modeDesc = ( UsePlan <$> optPlanPath ) + <|> ( ComputePlan <$> planInputs modeDesc <*> optPlanOutput ) + + where + optPlanPath :: Parser FilePath + optPlanPath = + option str + ( short 'p' + <> long "plan" + <> help "Input 'plan.json' file" + <> metavar "INFILE" ) + + optPlanOutput :: Parser (Maybe FilePath) + optPlanOutput = + option (fmap Just str) + ( long "output-plan" + <> value Nothing + <> help "Output 'plan.json' file" + <> metavar "OUTFILE" ) + +-- | Parse information about fetched sources: in which directory they belong, +-- and what build plan they correspond to. +fetchDescription :: Parser FetchDescription +fetchDescription = do + fetchInputPlan <- plan Fetching + rawFetchDir <- optFetchDir Fetching + pure $ FetchDescription { rawFetchDir, fetchInputPlan } + +-- | Parse the fetch directory. +optFetchDir :: ModeDescription -> Parser FilePath +optFetchDir modeDesc = + option str + ( short 'f' + <> long "fetchdir" + <> help "Directory for fetched sources" + <> metavar metavarStr ) + where + metavarStr :: String + metavarStr = case modeDesc of + Building -> "INDIR" + _ -> "OUTDIR" + +-- | Parse whether to create a new fetch directory or update an existing one. +newOrExisting :: Parser NewOrExisting +newOrExisting = + bool New Existing <$> + switch ( long "update" + <> help "Update existing fetched sources directory" ) + +-- | Parse the options for the @build@ command. +build :: Parser Build +build = do + + buildBuildPlan <- plan Building + buildStart <- optStart + buildStrategy <- optStrategy + buildRawPaths <- optRawPaths + userUnitArgs <- optUnitArgs + mbOnlyDepsOf <- optOnlyDepsOf + + pure $ + Build { buildStart + , buildBuildPlan + , buildStrategy + , buildRawPaths + , userUnitArgs + , mbOnlyDepsOf } + + where + + optStrategy :: Parser BuildStrategy + optStrategy = optScript <|> ( Execute <$> optRunStrat ) + + optRunStrat :: Parser RunStrategy + optRunStrat = ( Async <$> asyncSem ) <|> pure TopoSort + + asyncSem :: Parser AsyncSem + asyncSem = + option (fmap NewQSem auto <|> pure NoSem) + ( short 'j' + <> long "async" + <> help "Use asynchronous package building" + <> metavar "N" ) + + optScript :: Parser BuildStrategy + optScript = do + scriptPath <- optScriptPath + useVariables <- + switch + ( long "variables" + <> help "Use variables in the shell script output ($PREFIX etc)" ) + pure $ Script { scriptPath, useVariables } + + optScriptPath :: Parser FilePath + optScriptPath = + option str + ( long "script" + <> help "Output a shell script containing build steps" + <> metavar "OUTFILE" ) + + optStart :: Parser BuildStart + optStart = + resume <|> prefetched <|> ( Fetch <$> newOrExisting ) + + resume :: Parser BuildStart + resume = + flag' Resume + ( long "resume" + <> help "Resume a partially-completed build" ) + + prefetched :: Parser BuildStart + prefetched = + flag' Prefetched + ( long "prefetched" + <> help "Start the build from the prefetched sources" ) + + optRawPaths :: Parser (Paths Raw) + optRawPaths = do + fetchDir <- optFetchDir Building + buildPaths <- optBuildPaths + return $ Paths { fetchDir, buildPaths } + + optBuildPaths :: Parser (BuildPaths Raw) + optBuildPaths = do + rawPrefix <- + option str ( short 'o' + <> long "prefix" + <> help "Installation prefix" + <> metavar "OUTDIR" ) + rawDestDir <- + option str ( long "destdir" + <> help "Installation destination directory" + <> value "/" + <> metavar "OUTDIR" ) + pure $ RawBuildPaths { rawPrefix, rawDestDir } + + -- TODO: we only support passing arguments for all units at once, + -- rather than per-unit. + optUnitArgs :: Parser ( ConfiguredUnit -> UnitArgs ) + optUnitArgs = do + confArgs <- optConfigureArgs + mbDocArgs <- optHaddockArgs + regArgs <- optGhcPkgArgs + pure $ \ cu -> + UnitArgs { configureArgs = confArgs cu + , mbHaddockArgs = fmap ($ cu) mbDocArgs + , registerArgs = regArgs cu } + + optConfigureArgs :: Parser ( ConfiguredUnit -> Args ) + optConfigureArgs = do + args <- many $ option str ( long "configure-arg" + <> help "Pass argument to 'Setup configure'" + <> metavar "ARG" ) + pure $ const args + + optHaddockArgs :: Parser ( Maybe ( ConfiguredUnit -> Args ) ) + optHaddockArgs = do + doHaddock <- + switch ( long "haddock" + <> help "Generate haddock documentation" ) + args <- many $ + option str ( long "haddock-arg" + <> help "Pass argument to 'Setup haddock'" + <> metavar "ARG" ) + pure $ + if null args && not doHaddock + then Nothing + else Just $ const args + + optGhcPkgArgs :: Parser ( ConfiguredUnit -> Args ) + optGhcPkgArgs = do + args <- many $ + option str ( long "ghc-pkg-arg" + <> help "Pass argument to 'ghc-pkg register'" + <> metavar "ARG" ) + pure $ const args + + optOnlyDepsOf :: Parser ( Maybe ( Set PkgName ) ) + optOnlyDepsOf = do + pkgs <- many $ + option pkgName + ( long "only" + <> help "Only build these packages (and their dependencies)" + <> metavar "PKG" ) + pure $ + if null pkgs + then Nothing + else Just $ Set.fromList pkgs + + pkgName :: ReadM PkgName + pkgName = do + nm <- str + if validPackageName nm + then return $ PkgName nm + else readerError $ + "Invalid package name: " <> Text.unpack nm diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,187 @@ +module Main ( main ) where + +-- base +import Control.Monad + ( guard ) +import Data.Foldable + ( for_ ) +import System.IO + ( BufferMode(..), hSetBuffering, stdout ) + +-- bytestring +import qualified Data.ByteString.Lazy as Lazy.ByteString + ( readFile, writeFile ) + +-- containers +import qualified Data.Map as Map + ( empty ) +import qualified Data.Set as Set + ( empty, member ) + +-- directory +import System.Directory + +-- text +import qualified Data.Text as Text + ( pack ) + +-- build-env +import BuildEnv.Build +import BuildEnv.CabalPlan +import BuildEnv.Config +import BuildEnv.File + ( parseCabalDotConfigPkgs, parseSeedFile ) +import BuildEnv.Options +import BuildEnv.Parse + ( runOptionsParser ) + +-------------------------------------------------------------------------------- + +main :: IO () +main = do + currentDir <- getCurrentDirectory + Opts { compiler, cabal, mode, verbosity, delTemp, workDir } + <- runOptionsParser currentDir + hSetBuffering stdout $ BlockBuffering Nothing + withCurrentDirectory workDir $ + case mode of + PlanMode { planModeInputs, planOutput } -> do + CabalPlanBinary planBinary <- + computePlanFromInputs delTemp verbosity workDir compiler cabal planModeInputs + normalMsg verbosity $ + "Writing build plan to '" <> Text.pack planOutput <> "'" + Lazy.ByteString.writeFile planOutput planBinary + FetchMode ( FetchDescription { rawFetchDir, fetchInputPlan } ) newOrUpd -> do + plan <- getPlan delTemp verbosity workDir compiler cabal fetchInputPlan + fetchDir <- canonicalizePath rawFetchDir + doFetch verbosity cabal fetchDir True newOrUpd plan + BuildMode ( Build { buildBuildPlan + , buildStart + , buildStrategy + , buildRawPaths = rawPaths + , mbOnlyDepsOf + , userUnitArgs } ) -> do + plan <- getPlan delTemp verbosity workDir compiler cabal buildBuildPlan + ( pathsForPrep@( Paths { fetchDir }), pathsForBuild ) + <- canonicalizePaths compiler buildStrategy rawPaths + case buildStart of + Fetch newOrUpd -> doFetch verbosity cabal fetchDir False newOrUpd plan + _ -> return () + let mbOnlyDepsOfUnits :: Maybe [UnitId] + mbOnlyDepsOfUnits = + case mbOnlyDepsOf of + Nothing -> Nothing + Just pkgs -> + let wantUnit :: PlanUnit -> Maybe UnitId + wantUnit pu = do + ConfiguredUnit { puPkgName, puId } <- configuredUnitMaybe pu + guard ( puPkgName `Set.member` pkgs ) + return puId + in Just $ mapMaybePlanUnits wantUnit plan + + let resumeBuild = case buildStart of { Resume -> True; _ -> False } + buildPlan verbosity workDir pathsForPrep pathsForBuild + buildStrategy resumeBuild mbOnlyDepsOfUnits userUnitArgs plan + +-- | Generate the contents of @pkg.cabal@ and @cabal.project@ files, using +-- +-- - a seed file containing packages to build (with constraints, flags +-- and allow-newer), +-- - a @cabal.config@ freeze file, +-- - explicit packages and allow-newer specified as command-line arguments. +parsePlanInputs :: Verbosity -> FilePath -> PlanInputs -> IO CabalFilesContents +parsePlanInputs verbosity workDir (PlanInputs { planPins, planUnits, planAllowNewer }) + = do (pkgs, fileAllowNewer) <- parsePlanUnits verbosity planUnits + let + allAllowNewer = fileAllowNewer <> planAllowNewer + -- NB: allow-newer specified in the command-line overrides + -- the allow-newer included in the seed file. + cabalContents = cabalFileContentsFromPackages pkgs + projectContents <- + case planPins of + Nothing -> return $ cabalProjectContentsFromPackages workDir pkgs Map.empty allAllowNewer + Just (FromFile pinCabalConfig) -> do + normalMsg verbosity $ + "Reading 'cabal.config' file at '" <> Text.pack pinCabalConfig <> "'" + pins <- parseCabalDotConfigPkgs pinCabalConfig + return $ cabalProjectContentsFromPackages workDir pkgs pins allAllowNewer + Just (Explicit pins) -> do + return $ cabalProjectContentsFromPackages workDir pkgs pins allAllowNewer + return $ CabalFilesContents { cabalContents, projectContents } + +-- | Retrieve the seed units we want to build, either from a seed file +-- or from explicit command line arguments. +parsePlanUnits :: Verbosity -> PackageData UnitSpecs -> IO (UnitSpecs, AllowNewer) +parsePlanUnits _ (Explicit units) = return (units, AllowNewer Set.empty) +parsePlanUnits verbosity (FromFile fp) = + do normalMsg verbosity $ + "Reading seed packages from '" <> Text.pack fp <> "'" + parseSeedFile fp + +-- | Compute a build plan by calling @cabal build --dry-run@ with the generated +-- @pkg.cabal@ and @cabal.project@ files. +computePlanFromInputs :: TempDirPermanence + -> Verbosity + -> FilePath + -> Compiler + -> Cabal + -> PlanInputs + -> IO CabalPlanBinary +computePlanFromInputs delTemp verbosity workDir comp cabal inputs + = do cabalFileContents <- parsePlanInputs verbosity workDir inputs + normalMsg verbosity "Computing build plan" + computePlan delTemp verbosity comp cabal cabalFileContents + +-- | Retrieve a cabal build plan, either by computing it or using +-- a pre-existing @plan.json@ file. +getPlan :: TempDirPermanence -> Verbosity -> FilePath -> Compiler -> Cabal -> Plan -> IO CabalPlan +getPlan delTemp verbosity workDir comp cabal planMode = do + planBinary <- + case planMode of + ComputePlan planInputs mbPlanOutputPath -> do + plan@(CabalPlanBinary planData) <- + computePlanFromInputs delTemp verbosity workDir comp cabal planInputs + for_ mbPlanOutputPath \ planOutputPath -> + Lazy.ByteString.writeFile planOutputPath planData + return plan + UsePlan { planJSONPath } -> + do + normalMsg verbosity $ + "Reading build plan from '" <> Text.pack planJSONPath <> "'" + CabalPlanBinary <$> Lazy.ByteString.readFile planJSONPath + return $ parsePlanBinary planBinary + +-- | Fetch all packages in a cabal build plan. +doFetch :: Verbosity + -> Cabal + -> FilePath + -> Bool -- ^ True <=> we are fetching (not building) + -- (only relevant for error messages) + -> NewOrExisting + -> CabalPlan + -> IO () +doFetch verbosity cabal fetchDir0 weAreFetching newOrUpd plan = do + fetchDir <- canonicalizePath fetchDir0 + fetchDirExists <- doesDirectoryExist fetchDir + case newOrUpd of + New | fetchDirExists -> + error $ unlines $ + "Fetch directory already exists." : existsMsg + ++ [ "Fetch directory: " <> fetchDir ] + Existing | not fetchDirExists -> + error $ unlines + [ "Fetch directory must already exist when using --update." + , "Fetch directory: " <> fetchDir ] + _ -> return () + createDirectoryIfMissing True fetchDir + normalMsg verbosity $ + "Fetching sources from build plan into directory '" <> Text.pack fetchDir <> "'" + fetchPlan verbosity cabal fetchDir plan + + where + existsMsg + | weAreFetching + = [ "Use --update to update an existing directory." ] + | otherwise + = [ "Use --prefetched to build using a prefetched source directory," + , "or --update to continue fetching before building." ] diff --git a/build-env.cabal b/build-env.cabal new file mode 100644 --- /dev/null +++ b/build-env.cabal @@ -0,0 +1,125 @@ +cabal-version: 3.0 +name: build-env +version: 1.0.0.0 +author: Ben Gamari & Sam Derbyshire +maintainer: ben@smart-cactus.org +license: BSD-3-Clause +category: Distribution +build-type: Simple +homepage: https://github.com/bgamari/build-env +bug-reports: https://github.com/bgamari/build-env/issues + +extra-source-files: + readme.md + changelog.md + +synopsis: Compute, fetch and install Cabal build plans into a local environment + +description: + __build-env__ allows one to compute, fetch and install Cabal build plans + into a local environment, registering the libraries into a free-standing + package database. + + In particular, __build-env__ enables bootstrapping of Haskell packages + in hermetic build environments without the use of @cabal-install@ or Stack. + + It can be used as a library, or as an executable. + + Please refer to the [readme](https://github.com/bgamari/build-env/readme.md) + for more information and usage examples. + +common common + + build-depends: + base + >= 4.15 && < 4.18 + , bytestring + >= 0.10 && < 0.12 + , containers + ^>= 0.6 + , directory + ^>= 1.3 + , filepath + ^>= 1.4 + , text + >= 1.2 && < 2.1 + + default-language: + Haskell2010 + + default-extensions: + BangPatterns + , BlockArguments + , DerivingStrategies + , DisambiguateRecordFields + , GeneralizedNewtypeDeriving + , LambdaCase + , NamedFieldPuns + , OverloadedStrings + , StandaloneDeriving + , StandaloneKindSignatures + , TypeOperators + , ViewPatterns + + ghc-options: + -Wall + -Wcompat + -fwarn-missing-local-signatures + -fwarn-incomplete-patterns + -fwarn-incomplete-uni-patterns + -fwarn-missing-deriving-strategies + -fno-warn-unticked-promoted-constructors + +library + + import: + common + + hs-source-dirs: + src + + exposed-modules: + BuildEnv.Build + , BuildEnv.BuildOne + , BuildEnv.CabalPlan + , BuildEnv.Config + , BuildEnv.File + , BuildEnv.Script + , BuildEnv.Utils + + build-depends: + async + ^>= 2.2 + , aeson + >= 1.5 && < 2.2 + , process + ^>= 1.6 + , temporary + ^>= 1.3 + , time + >= 1.9 && < 1.13 + , transformers + ^>= 0.5 + +executable build-env + + import: + common + + hs-source-dirs: + app + + main-is: + Main.hs + + ghc-options: + -threaded + + build-depends: + optparse-applicative + >= 0.16 && < 0.18 + , build-env + + other-modules: + BuildEnv.Options + , BuildEnv.Parse diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,9 @@ +# Changelog for `build-env` + +## Version 1.0.0.0 (2022-12-26) + +- First released version. + +## Version 0.1.0.0 (2022-11-16) + +- Initial proof of concept. diff --git a/readme.md b/readme.md new file mode 100644 --- /dev/null +++ b/readme.md @@ -0,0 +1,263 @@ +# build-env + +**`build-env`** is a utility to build a set of Cabal packages (computed +by `cabal-install`'s solver) into a free-standing package database. + +This enables the compilation of Haskell packages (with their dependencies) +in hermetic build environments. + +--- + +### Contents + +- [Example](#example) +- [Commands](#commands) +- [What does `build-env` do?](#what-does-build-env-do) +- [Hermetic builds](#hermetic-builds) + - [Narrowing a build down (for debugging)](#narrowing-a-build-down-for-debugging) +- [Bootstrapping](#bootstrapping) + - [Bootstrap arguments](#bootstrap-arguments) +- [Specifying packages](#specifying-packages) + - [Local packages](#local-packages) + +--- + +## Example + +``` +$ build-env build lens -f sources -o install -j8 +$ ghci -package-db install/package.conf/ -package lens +ghci> :ty Control.Lens.Lens +Control.Lens.Lens + :: Control.Lens.Type.Lens s t a b + -> Control.Lens.Reified.ReifiedLens s t a b +``` + +In this example, the `build-env build` invocation: + + - computes a build plan for `lens`, + - fetches `lens` and its dependencies into the `sources` directory, + - configures and builds all the packages, with up to `8` units building + concurrently, and registers the libraries into the package database at + `install/package.conf`. + +We then tell `ghci` to use this package database, making `lens` available. + +## Commands + +`build-env` has three distinct modes of operation: + + - `plan` computes a build plan, outputting a `plan.json` Cabal plan. + - `fetch` fetches sources. + - `build` executes a build plan. + +Each command subsumes the functionality of the previous ones in the above list. +In particular, in the previous example, the `build` command computed a build +plan, fetched the sources, and built the plan. The same could have been achieved +with three separate invocations: + +``` +$ build-env plan lens -p lens-plan.json +$ build-env fetch -p lens-plan.json -f sources +$ build-env build -p lens-plan.json -f sources -o install -j8 --prefetched +``` + +Being able to separate these steps affords us some extra flexibility, as +subsequent sections will explain. + +## What does `build-env` do? + +- **plan:** `build-env` calls `cabal build --dry-run` on a dummy + project with the dependencies and constraints that were asked for. + This produces a Cabal plan in the form of a `plan.json`, which `build-env` + parses. + **Required executables:** `cabal`, `ghc`. +- **fetch:** `build-env` calls `cabal get` on each package in the build plan. + **Required executables:** `cabal`. +- **build:** `build-env` builds the dependencies by compiling their `Setup` + scripts and calling `Setup configure`, `Setup build`, + `Setup haddock` (optional), `Setup copy`, and, for libraries, `Setup register` + and `ghc-pkg register`. + **Required executables:** `ghc`, `ghc-pkg`. + +Note that, when building packages, `build-env` passes the following information +when running the `Setup` script: + + - `with-compiler`, `prefix` and `destdir` options supplied by the user, + - the default `datadir` option, + - `cid`, `datasubdir`, `bindir` and `builddir` options supplied by `build-env`, + - package flags and `dependency` arguments, obtained from the build plan, + - `_datadir` environment variables supplied by `build-env`. + +Problems will likely arise if you pass extra arguments that override any of +these, for example by using `--configure-arg ARG` on the command line. + +## Hermetic builds + +When working in a hermetic build environment, we might need to compute a build +plan and fetch all the dependencies first, before doing an offline build. + +This can be achieved by two separate `build-env` invocations. + +In a local environment (with access to internet): + +``` +$ build-env fetch lens -f sources --output-plan plan.json +``` + +In a build environment in which `build-env` has been provisioned: + +``` +$ build-env build --prefetched -p plan.json -f sources -o install -j8 +``` + +In this example: + + - the `fetch` command computes a plan which is written to + `plan.json` (using the Cabal JSON plan format), and fetches all + the required sources, putting them into the `sources` directory; + - the `build` command reads in the build plan and performs the build. + +### Narrowing a build down (for debugging) + +When attempting to execute a large build plan, it can be useful to be able +to refine the build down to a small set of problematic packages, for debugging +purposes. For this, you can use `--only`, e.g.: + +``` +$ build-env build --prefetched -p plan.json -f sources -o install --only badPackage +``` + +Instead of building the full plan from `plan.json`, this will instead restrict +to only building units from package `badPackage` and their transitive dependencies. +Multiple `--only` arguments combine additively, e.g. `--only pkg1 --only pkg2` +will build the units from the build plan that belong to `pkg1` or `pkg2`, and +transitive dependencies thereof. + +Note that `--only` only affects which packages are built; it does not change +the computation of the build plan nor which packages are fetched. + +You can also resume a build where it left off by passing `--resume`; this will +avoid rebuilding any of the units that have already been registed in the +package database. + +## Bootstrapping + +In the example from [ยง Hermetic builds](#hermetic-builds), we ran +`build-env build` to perform a build. However, this requires that the build +environment provision `build-env`. + +To avoid this requirement, it is also possible to ask `build-env` to output +a shell script containing the build steps to execute. + +In a local environment (with access to internet): + +``` +$ build-env build lens -f sources -o install --script build_lens.sh +``` + +In a build environment: + +``` +$ ./build_lens.sh +``` + +The downside is that we lose any parallelism from this approach, as the +generated build script is inherently sequential. + +One particularly useful application is the bootstrapping of `build-env` itself, +as this supplies a mechanism for the provisioning of `build-env` in build +environments. + +### Bootstrap arguments + +If your build environment provides additional variables that need to be passed +to the build script, you can pass them to the shell script using variables. + +For example, in the local environment, you can first obtain all the information +needed to return a build script: + +``` +$ build-env fetch lens -f sources --output-plan myPlan.json +``` + +Next, compute a build script containing references to variables: + +``` +$ build-env build -p myPlan.json -f sources -o install --prefetched --configure-arg \$\{myArgs\} --script script.sh +``` + +This will output a script which passes `$myArgs` to each `Setup configure` +invocation. In the build environment, you can then set the value of `$myArgs` +before running the shell script `script.sh`. Note that the build script +__does not__ insert additional quotation marks around `$myArgs`, which allows +passing multiple arguments at once (this is crucial when one doesn't know +the number of arguments ahead of time). + +If you want to set `--fetchdir`, `--prefix` or `--destdir` to variables, +you should pass the `--variables` flag. This will set these to the values +`$SOURCES`, `$PREFIX` and `$DESTDIR` in the output shell script, respectively. +These should be set to absolute paths before running the script. +The script will also use `$GHC` and `$GHCPKG` variables for the compiler. + +## Specifying packages + +Instead of passing the required packages through the command line, +it can be more convenient to ask `build-env` to read them from files: + +``` +$ build-env build --seeds SEEDS --freeze cabal.config -f sources -o install +``` + +This will build a plan for the packages specified in the `SEEDS` file, +with versions of packages that aren't in the `SEEDS` file constrained as +specified by the `cabal.config` file. + +Each line in the seeds file should be one of the following: + + - A Cabal unit, in the format `unit +flag1 -flag2 >= 0.1 && < 0.3`. + + A unit can be of the form `pkgName`, `lib:pkgName`, `exe:pkgName`, + `pkgName:lib:compName`, ... as per `cabal` component syntax. + + The unit name must be followed by a space. + + Flags and constraints are optional. + When both are present, flags must precede constraints. + Constraints must use valid Cabal constraint syntax. + + - An allow-newer specification such as: + + ``` + allow-newer: pkg1:pkg2,pkg3:base,*:ghc + ``` + + This uses Cabal `allow-newer` syntax. + + - An empty line or comment (starting with `--`). + +The `cabal.config` file should use valid `cabal.project` syntax, e.g.: + +```cabal +constraints: pkg1 == 0.1, + pkg2 >= 3.0 +``` + +Only the constraints are processed; everything else from the `cabal.config` +file is ignored. + +### Local packages + +To specify that a package should be found locally rather than fetched from +Hackage, use `--local`: + +``` +build-env build myPkg --local myPkg=../pkgs/myPkg +``` + +The part to the right of the `=` sign corresponds to what you would write +in a `cabal.project` file: the directory in which `myPkg.cabal` is located. + +If this is a relative path, it will be interpreted relative to the working +directory of the `build-env` invocation, which can be overriden by passing +`--cwd ` (works like the `-C` argument to `make`). diff --git a/src/BuildEnv/Build.hs b/src/BuildEnv/Build.hs new file mode 100644 --- /dev/null +++ b/src/BuildEnv/Build.hs @@ -0,0 +1,724 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : BuildEnv.Build +-- Description : Computing, fetching and building plans +-- +-- 'computePlan' computes a Cabal plan by generating @pkg.cabal@ and +-- @cabal.project@ files with the given dependencies, constraints, flags..., +-- calling @cabal build --dry-run@ to compute a build plan, and parsing +-- the resulting @plan.json@ file. +-- +-- 'fetchPlan' calls @cabal unpack@ to fetch all packages in the given plan. +-- +-- 'buildPlan' builds each unit in the build plan from source, +-- using 'buildUnit'. This can be done either asynchronously or sequentially +-- in dependency order, depending on the 'BuildStrategy'. +-- 'buildPlan' can also be used to output a shell script containing +-- build instructions, with the 'Script' 'BuildStrategy'. +module BuildEnv.Build + ( -- * Computing, fetching and building plans + computePlan + , fetchPlan + , buildPlan + + -- * Generating @pkg.cabal@ and @cabal.project@ files. + , CabalFilesContents(..) + , cabalFileContentsFromPackages + , cabalProjectContentsFromPackages + ) where + +-- base +import Control.Exception + ( IOException, catch ) +import Control.Monad + ( when ) +import Control.Monad.Fix + ( MonadFix(mfix) ) +import Data.Char + ( isSpace ) +import Data.Foldable + ( for_, toList ) +import Data.IORef + ( newIORef ) +import Data.Maybe + ( catMaybes, mapMaybe, maybeToList, isNothing ) +import Data.String + ( IsString ) +import Data.Traversable + ( for ) +import Data.Version + ( Version ) + +-- async +import Control.Concurrent.Async + ( async, wait ) + +-- bytestring +import qualified Data.ByteString.Lazy as Lazy.ByteString + ( readFile ) + +-- containers +import qualified Data.Graph as Graph + ( dfs, graphFromEdges, reverseTopSort ) +import Data.Map.Strict + ( Map ) +import qualified Data.Map.Strict as Map +import qualified Data.Map.Lazy as Lazy + ( Map ) +import qualified Data.Map.Lazy as Lazy.Map +import Data.Set + ( Set ) +import qualified Data.Set as Set + ( elems, fromList, member, toList ) + +-- directory +import System.Directory + ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist + , exeExtension, listDirectory, removeDirectoryRecursive + ) + +-- filepath +import System.FilePath + ( (), (<.>) + , isAbsolute + ) + +-- process +import qualified System.Process as Process + ( readProcess ) + +-- text +import Data.Text + ( Text ) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text + ( writeFile ) + +-- build-env +import BuildEnv.BuildOne + ( PkgDbDirs(..) + , getPkgDbDirsForPrep, getPkgDbDirsForBuild, getPkgDir + , setupPackage, buildUnit ) +import BuildEnv.CabalPlan +import qualified BuildEnv.CabalPlan as Configured + ( ConfiguredUnit(..) ) +import BuildEnv.Config +import BuildEnv.Script + ( BuildScript, ScriptOutput(..), ScriptConfig(..) + , emptyBuildScript + , executeBuildScript, script + , createDir, logMessage + ) +import BuildEnv.Utils + ( ProgPath(..), CallProcess(..), callProcessInIO, withTempDir + , AbstractSem(..), noSem, newAbstractSem + ) + +-------------------------------------------------------------------------------- +-- Planning. + +-- | The name of the dummy cabal package on which we will call +-- @cabal@ to obtain a build plan. +dummyPackageName :: IsString str => str +dummyPackageName = "build-env-dummy-package" + +-- | The 'UnitId' of the (local) dummy package (version 0). +dummyUnitId :: UnitId +dummyUnitId = UnitId $ dummyPackageName <> "-0-inplace" + +-- | Query @cabal@ to obtain a build plan for the given packages, +-- by reading the output @plan.json@ of a @cabal build --dry-run@ invocation. +-- +-- Use 'cabalFileContentsFromPackages' and 'cabalProjectContentsFromPackages' +-- to generate the @cabal@ file contents from a collection of packages with +-- constraints and flags. +-- See also 'BuildEnv.File.parseCabalDotConfigPkgs' and +-- 'BuildEnv.File.parseSeedFile' for other ways of obtaining this information. +-- +-- Use 'parsePlanBinary' to convert the returned 'CabalPlanBinary' into +-- a 'CabalPlan'. +computePlan :: TempDirPermanence + -> Verbosity + -> Compiler + -> Cabal + -> CabalFilesContents + -> IO CabalPlanBinary +computePlan delTemp verbosity comp cabal ( CabalFilesContents { cabalContents, projectContents } ) = + withTempDir delTemp "build" \ dir -> do + verboseMsg verbosity $ "Computing plan in build directory " <> Text.pack dir + Text.writeFile (dir "cabal" <.> "project") projectContents + Text.writeFile (dir dummyPackageName <.> "cabal") cabalContents + let cabalBuildArgs = + globalCabalArgs cabal ++ + [ "build" + , "--dry-run" + , "--with-compiler", ghcPath comp + , cabalVerbosity verbosity ] + debugMsg verbosity $ + Text.unlines $ "cabal" : map ( (" " <>) . Text.pack ) cabalBuildArgs + callProcessInIO Nothing $ + CP { cwd = dir + , prog = AbsPath $ cabalPath cabal + , args = cabalBuildArgs + , extraPATH = [] + , extraEnvVars = [] + , logBasePath = Nothing + , sem = noSem } + + let planPath = dir "dist-newstyle" "cache" "plan.json" + CabalPlanBinary <$> Lazy.ByteString.readFile planPath + +-- | The contents of a dummy @cabal.project@ file, specifying +-- package constraints, flags and allow-newer. +cabalProjectContentsFromPackages :: FilePath -> UnitSpecs -> PkgSpecs -> AllowNewer -> Text +cabalProjectContentsFromPackages workDir units pins (AllowNewer allowNewer) = + packages + <> allowNewers + <> flagSpecs + <> constraints + where + + packages + | null localPkgs + = "packages: .\n\n" + | otherwise + = Text.intercalate ",\n " + ( "packages: ." : map ( Text.pack . makeAbsolute ) ( Map.elems localPkgs ) ) + <> "\n" + + makeAbsolute :: FilePath -> FilePath + makeAbsolute fp + | isAbsolute fp + = fp + | otherwise + = workDir fp + + isLocal :: (PkgSrc, PkgSpec, Set ComponentName) -> Maybe FilePath + isLocal ( Local src, _, _ ) = Just src + isLocal _ = Nothing + localPkgs = Map.mapMaybe isLocal units + + allPkgs = fmap ( \ ( _, spec, _ ) -> spec ) units + `unionPkgSpecsOverriding` + pins + -- Constraints from the SEED file (units) should override + -- constraints from the cabal.config file (pins). + + constraints = Text.unlines + [ Text.unwords ["constraints:", unPkgName nm, cts] + | (nm, ps) <- Map.assocs allPkgs + , Constraints cts <- maybeToList $ psConstraints ps + , not (Text.all isSpace cts) + ] + + allowNewers + | null allowNewer + = "" + | otherwise + = Text.unlines $ + "allow-newer:" : + [ " " <> p <> ":" <> q <> "," + | (p,q) <- Set.elems allowNewer ] + + flagSpecs = Text.unlines + [ Text.unlines + [ "package " <> unPkgName nm + , " flags: " <> showFlagSpec (psFlags ps) + ] + | (nm, ps) <- Map.assocs allPkgs + , let flags = psFlags ps + , not $ flagSpecIsEmpty flags + ] + +-- | The contents of a dummy Cabal file with dependencies on +-- the specified units (without any constraints). +cabalFileContentsFromPackages :: UnitSpecs -> Text +cabalFileContentsFromPackages units = + Text.unlines + [ "cabal-version: 3.0" + , "name: " <> dummyPackageName + , "version: 0" + , "library" ] + <> libDepends + <> exeDepends + where + isLib (ComponentName ty lib) = case ty of { Lib -> Just lib; _ -> Nothing } + isExe (ComponentName ty exe) = case ty of { Exe -> Just exe; _ -> Nothing } + allLibs = [ (pkg, libsInPkg) + | (pkg, (_, _, comps)) <- Map.assocs units + , let libsInPkg = mapMaybe isLib $ Set.toList comps + , not (null libsInPkg) ] + allExes = [ (pkg, exesInPkg) + | (pkg, (_, _, comps)) <- Map.assocs units + , let exesInPkg = mapMaybe isExe $ Set.toList comps + , not (null exesInPkg) ] + + dep (PkgName pkg) [comp] + = pkg <> ":" <> comp + dep (PkgName pkg) comps + = pkg <> ":{" <> Text.intercalate "," comps <> "}" + + libDepends + | null allLibs + = "" + | otherwise + = "\n build-depends:\n" + <> Text.intercalate ",\n" + [ " " <> dep pkg libs + | (pkg, libs) <- allLibs ] + <> "\n" + + exeDepends + | null allExes + = "" + | otherwise + = "\n build-tool-depends:\n" + <> Text.intercalate ",\n" + [ " " <> dep pkg exes + | (pkg, exes) <- allExes ] + <> "\n" + +-- | The file contents of the Cabal files of a Cabal project: +-- @pkg.cabal@ and @cabal.project@. +data CabalFilesContents + = CabalFilesContents + { cabalContents :: !Text + -- ^ The package Cabal file contents. + , projectContents :: !Text + -- ^ The @cabal.project@ file contents. + } + +-------------------------------------------------------------------------------- +-- Fetching. + +-- | Fetch the sources of a 'CabalPlan', calling @cabal get@ on each +-- package and putting it into the correspondingly named and versioned +-- subfolder of the specified directory (e.g. @pkg-name-1.2.3@). +fetchPlan :: Verbosity + -> Cabal + -> FilePath -- ^ Directory in which to put the sources. + -> CabalPlan + -> IO () +fetchPlan verbosity cabal fetchDir cabalPlan = + for_ pkgs \ (pkgNm, pkgVer) -> do + let nameVersion = pkgNameVersion pkgNm pkgVer + nmVerStr = Text.unpack nameVersion + pkgDirExists <- doesDirectoryExist (fetchDir nmVerStr) + if pkgDirExists + then normalMsg verbosity $ "NOT fetching " <> nameVersion + else cabalFetch verbosity cabal fetchDir nmVerStr + where + pkgs :: Set (PkgName, Version) + pkgs = Set.fromList + -- Some packages might have multiple components; + -- we don't want to fetch the package itself multiple times. + $ mapMaybe remotePkgNameVersion + $ planUnits cabalPlan + + remotePkgNameVersion :: PlanUnit -> Maybe (PkgName, Version) + remotePkgNameVersion = \case + PU_Configured ( ConfiguredUnit { puPkgName = nm, puVersion = ver, puPkgSrc = src } ) + | Remote <- src -- only fetch remote packages + -> Just (nm, ver) + _ -> Nothing + +-- | Call @cabal get@ to fetch a single package from Hackage. +cabalFetch :: Verbosity -> Cabal -> FilePath -> String -> IO () +cabalFetch verbosity cabal root pkgNmVer = do + normalMsg verbosity $ "Fetching " <> Text.pack pkgNmVer + let args = globalCabalArgs cabal ++ + [ "get" + , pkgNmVer + , cabalVerbosity verbosity ] + callProcessInIO Nothing $ + CP { cwd = root + , prog = AbsPath $ cabalPath cabal + , args + , extraPATH = [] + , extraEnvVars = [] + , logBasePath = Nothing + , sem = noSem } + +-------------------------------------------------------------------------------- +-- Building. + +-- | Build a 'CabalPlan'. This will install all the packages in the plan +-- by running their @Setup@ scripts. Libraries will be registered +-- into a local package database at @/package.conf@. +buildPlan :: Verbosity + -> FilePath + -- ^ Working directory. + -- Used to compute relative paths for local packages, + -- and to choose a logging directory. + -> Paths ForPrep + -> Paths ForBuild + -> BuildStrategy + -> Bool + -- ^ @True@ <> resume a previously-started build, + -- skipping over units that were already built. + -- + -- This function will fail if this argument is @False@ + -- and one of the units has already been registered in the + -- package database. + -> Maybe [ UnitId ] + -- ^ @Just units@: only build @units@ and their transitive + -- dependencies, instead of the full build plan. + -> ( ConfiguredUnit -> UnitArgs ) + -- ^ Extra arguments for each unit in the build plan. + -> CabalPlan + -- ^ Build plan to execute. + -> IO () +buildPlan verbosity workDir + pathsForPrep@( Paths { buildPaths = buildPathsForPrep }) + pathsForBuild + buildStrat + resumeBuild + mbOnlyBuildDepsOf + userUnitArgs + cabalPlan + = do + let paths@( BuildPaths { compiler, prefix, destDir, installDir } ) + = buildPaths pathsForBuild + -- Create the temporary package database, if it doesn't already exist. + -- We also create the final installation package database, + -- but this happens later, in (*), as part of the build script itself. + -- + -- See Note [Using two package databases] in BuildOne. + let pkgDbDirsForPrep@( PkgDbDirsForPrep { tempPkgDbDir } ) + = getPkgDbDirsForPrep pathsForPrep + tempPkgDbExists <- doesDirectoryExist tempPkgDbDir + + if + | resumeBuild && not tempPkgDbExists + -> error $ + "Cannot resume build: no package database at " <> tempPkgDbDir + | not resumeBuild + -> do when tempPkgDbExists $ + removeDirectoryRecursive tempPkgDbDir + `catch` \ ( _ :: IOException ) -> return () + createDirectoryIfMissing True tempPkgDbDir + | otherwise + -> return () + + pkgDbDirsForBuild@( PkgDbDirsForBuild { finalPkgDbDir } ) + <- getPkgDbDirsForBuild pathsForBuild + + verboseMsg verbosity $ + Text.unlines [ "Directory structure:" + , " prefix: " <> Text.pack prefix + , " destDir: " <> Text.pack destDir + , " installDir: " <> Text.pack installDir ] + + mbAlreadyBuilt <- + if resumeBuild + then let prepComp = compilerForPrep buildPathsForPrep + in Just <$> getInstalledUnits verbosity prepComp buildPathsForPrep pkgDbDirsForPrep fullDepMap + else return Nothing + + let -- Units to build, in dependency order. + unitsToBuild :: [(ConfiguredUnit, Maybe UnitId)] + unitsToBuild + = tagUnits $ sortPlan mbAlreadyBuilt mbOnlyBuildDepsOf cabalPlan + + nbUnitsToBuild :: Word + nbUnitsToBuild = fromIntegral $ length unitsToBuild + + pkgMap :: Map (PkgName, Version) ConfiguredUnit + pkgMap = Lazy.Map.fromList + [ ((puPkgName, puVersion), cu) + | ( cu@( ConfiguredUnit { puPkgName, puVersion } ), didSetup ) <- unitsToBuild + , isNothing didSetup ] + + -- Initial preparation: logging, and creating the final + -- package database. + preparation :: BuildScript + preparation = do + logMessage verbosity Verbose $ + "Creating final package database at " <> finalPkgDbDir + createDir finalPkgDbDir -- (*) + logMessage verbosity Debug $ "Packages:\n" <> + unlines + [ " - " <> Text.unpack (pkgNameVersion nm ver) + | (nm, ver) <- Map.keys pkgMap ] + logMessage verbosity Debug $ "Units:\n" <> + unlines + [ " - " <> Text.unpack pkgNm <> ":" <> Text.unpack (cabalComponent compName) + | ( ConfiguredUnit + { puPkgName = PkgName pkgNm + , puComponentName = compName } + , _ ) <- unitsToBuild + ] + logMessage verbosity Normal $ "=== BUILD START ===" + + -- Setup the package for this unit. + unitSetupScript :: ConfiguredUnit -> IO BuildScript + unitSetupScript pu = do + let pkgDirForPrep = getPkgDir workDir pathsForPrep pu + pkgDirForBuild = getPkgDir workDir pathsForBuild pu + setupPackage verbosity compiler + paths pkgDbDirsForBuild pkgDirForPrep pkgDirForBuild + fullDepMap pu + + -- Build and install this unit. + unitBuildScript :: ConfiguredUnit -> BuildScript + unitBuildScript pu = + let pkgDirForBuild = getPkgDir workDir pathsForBuild pu + in buildUnit verbosity compiler + paths pkgDbDirsForBuild pkgDirForBuild + (userUnitArgs pu) + fullDepMap pu + + -- Close out the build. + finish :: BuildScript + finish = do + logMessage verbosity Normal $ "=== BUILD SUCCEEDED ===" + + case buildStrat of + + Execute runStrat -> do + + -- Initialise the "units built" counter. + unitsBuiltCounterRef <- newIORef 0 + let unitsBuiltCounter + = Just $ + Counter { counterRef = unitsBuiltCounterRef + , counterMax = nbUnitsToBuild } + + case runStrat of + + Async sem -> do + + normalMsg verbosity $ + "\nBuilding and installing units asynchronously with " <> semDescription sem + executeBuildScript unitsBuiltCounter preparation + + let unitMap :: Lazy.Map UnitId (ConfiguredUnit, Maybe UnitId) + unitMap = + Lazy.Map.fromList + [ (puId, pu) + | pu@( ConfiguredUnit { puId }, _ ) <- unitsToBuild ] + + AbstractSem { withAbstractSem } <- newAbstractSem sem + (_, unitAsyncs) <- mfix \ ~(pkgAsyncs, unitAsyncs) -> do + + let -- Compile the Setup script of the package the unit belongs to. + -- (This should happen only once per package.) + doPkgSetupAsync :: ConfiguredUnit -> IO () + doPkgSetupAsync cu@( ConfiguredUnit { puSetupDepends } ) = do + + -- Wait for the @setup-depends@ units. + for_ puSetupDepends \ setupDepId -> + for_ (unitAsyncs Map.!? setupDepId) wait + + -- Setup the package. + withAbstractSem do + setupScript <- unitSetupScript cu + executeBuildScript unitsBuiltCounter setupScript + + -- Configure, build and install the unit. + doUnitAsync :: ( ConfiguredUnit, Maybe UnitId ) -> IO () + doUnitAsync ( pu, _didSetup ) = do + + let nm = Configured.puPkgName pu + ver = Configured.puVersion pu + + -- Wait for the package to have been setup. + wait $ pkgAsyncs Map.! (nm, ver) + + -- Wait until we have built the units we depend on. + for_ (unitDepends pu) \ depUnitId -> + for_ (unitAsyncs Map.!? depUnitId) wait + + -- Build the unit! + withAbstractSem $ + executeBuildScript unitsBuiltCounter $ unitBuildScript pu + + -- Kick off setting up the packages... + finalPkgAsyncs <- for pkgMap (async . doPkgSetupAsync) + -- ... and building the units. + finalUnitAsyncs <- for unitMap (async . doUnitAsync) + return (finalPkgAsyncs, finalUnitAsyncs) + mapM_ wait unitAsyncs + executeBuildScript unitsBuiltCounter finish + + TopoSort -> do + normalMsg verbosity "\nBuilding and installing units sequentially.\n\ + \NB: pass -j for increased parallelism." + executeBuildScript unitsBuiltCounter preparation + for_ unitsToBuild \ ( cu, didSetup ) -> do + when (isNothing didSetup) $ + unitSetupScript cu >>= executeBuildScript unitsBuiltCounter + executeBuildScript unitsBuiltCounter (unitBuildScript cu) + executeBuildScript unitsBuiltCounter finish + + Script { scriptPath = fp, useVariables } -> do + let scriptConfig :: ScriptConfig + scriptConfig = + ScriptConfig { scriptOutput = Shell { useVariables } + , scriptStyle = hostStyle + , scriptTotal = Just nbUnitsToBuild } + + normalMsg verbosity $ "\nWriting build scripts to " <> Text.pack fp + buildScripts <- for unitsToBuild \ ( cu, didSetup ) -> do + mbSetup <- if isNothing didSetup + then unitSetupScript cu + else return emptyBuildScript + let build = unitBuildScript cu + return $ mbSetup <> build + Text.writeFile fp $ script scriptConfig $ + preparation <> mconcat buildScripts <> finish + + where + + -- This needs to have ALL units, as that's how we pass correct + -- Unit IDs for dependencies. + fullDepMap :: Map UnitId PlanUnit + fullDepMap = Map.fromList + [ (planUnitUnitId pu, pu) + | pu <- planUnits cabalPlan ] + + +-- | Sort the units in a 'CabalPlan' in dependency order. +sortPlan :: Maybe ( Set UnitId ) + -- ^ - @Just skip@ <=> skip these already-built units. + -- - @Nothing@ <=> don't skip any units. + -> Maybe [ UnitId ] + -- ^ - @Just keep@ <=> only return units that belong + -- to the transitive closure of @keep@. + -- - @Nothing@ <=> return all units in the plan. + -> CabalPlan + -> [ConfiguredUnit] +sortPlan mbAlreadyBuilt mbOnlyDepsOf plan = + onlyInteresting $ map (fst3 . lookupVertex) $ Graph.reverseTopSort gr + where + + onlyInteresting :: [ConfiguredUnit] -> [ConfiguredUnit] + onlyInteresting + -- Fast path: don't filter out anything. + | isNothing mbAlreadyBuilt + , isNothing mbOnlyDepsOf + = id + | otherwise + = filter isInteresting + + where + isInteresting :: ConfiguredUnit -> Bool + isInteresting cu@( ConfiguredUnit { puId } ) + | not $ reachable cu + = False + | Just alreadyBuilt <- mbAlreadyBuilt + , puId `Set.member` alreadyBuilt + = False + | otherwise + = True + + reachable :: ConfiguredUnit -> Bool + reachable = + case mbOnlyDepsOf of + Nothing -> const True + Just onlyDepsOf -> + let reachableUnits :: Set UnitId + !reachableUnits + = Set.fromList + $ map ( Configured.puId . fst3 . lookupVertex ) + $ concatMap toList + $ Graph.dfs gr + $ mapMaybe mkVertex onlyDepsOf + in \ ( ConfiguredUnit { puId } ) -> puId `Set.member` reachableUnits + + fst3 :: (a,b,c) -> a + fst3 (a,_,_) = a + ( gr, lookupVertex, mkVertex ) = + Graph.graphFromEdges + [ (pu, puId, allDepends pu) + | PU_Configured pu@( ConfiguredUnit { puId } ) <- planUnits plan ] + +-- | Tag units in a build plan: the first unit we compile in each package +-- is tagged (with @'Nothing'@) as having the responsibility to build +-- the Setup executable for the package it belongs to, while other units +-- in this same package are tagged with @'Just' uid@, where @uid@ is the unit +-- which is responsible for building the Setup executable. +tagUnits :: [ConfiguredUnit] -> [(ConfiguredUnit, Maybe UnitId)] +tagUnits = go Map.empty + where + go _ [] = [] + go seenPkgs ( cu@( ConfiguredUnit { puId } ):cus) + | puId == dummyUnitId + = go seenPkgs cus + | let nm = Configured.puPkgName cu + ver = Configured.puVersion cu + , ( mbUnit, newPkgs ) <- Map.insertLookupWithKey (\_ a _ -> a) (nm,ver) puId seenPkgs + = (cu, mbUnit) : go newPkgs cus + +-- | Compute the set of @UnitId@s that have already been installed, to avoid +-- unnecessarily recompiling them. +-- +-- This set of already-installed units is computed by querying the following: +-- +-- - Library: is it already registered in the package database? +-- - Executable: is there an executable of the correct name in the binary +-- directory associated with the unit? +getInstalledUnits :: Verbosity + -> Compiler + -> BuildPaths ForPrep + -> PkgDbDirs ForPrep + -> Map UnitId PlanUnit + -> IO ( Set UnitId ) +getInstalledUnits verbosity + ( Compiler { ghcPkgPath } ) + ( BuildPathsForPrep { installDir } ) + ( PkgDbDirsForPrep { tempPkgDbDir } ) + plan = do + pkgVerUnitIds <- + words <$> + Process.readProcess ( ghcPkgPath ) + [ "list" + , ghcPkgVerbosity verbosity + , "--show-unit-ids", "--simple-output" + , "--package-db", tempPkgDbDir ] + -- TODO: allow user package databases too? + "" + let installedLibs = map ( UnitId . Text.pack ) pkgVerUnitIds + verboseMsg verbosity $ + "Preinstalled libraries:\n" <> Text.unlines ( map mkLine installedLibs ) + + binDirContents <- listDirectory binsDir + installedBins <- catMaybes <$> mapM binDirMaybe binDirContents + verboseMsg verbosity $ + "Preinstalled executables:\n" <> Text.unlines ( map mkLine installedBins ) + + return $ Set.fromList installedLibs <> Set.fromList installedBins + where + + mkLine :: UnitId -> Text + mkLine ( UnitId uid ) = " - " <> uid + + binsDir :: FilePath + binsDir = installDir "bin" + binDirMaybe :: FilePath -> IO (Maybe UnitId) + binDirMaybe binDir = do + isDir <- doesDirectoryExist ( binsDir binDir ) + if not isDir + then return Nothing + else + case plan Map.!? ( UnitId $ Text.pack binDir ) of + -- Is this directory name the 'UnitId' of an executable + -- in the build plan? + Just ( PU_Configured cu ) + | ConfiguredUnit + { puId + , puComponentName = + ComponentName + { componentName = comp + , componentType = Exe } + } <- cu + -> do -- If so, does it contain the executable we expect? + let exePath = binsDir binDir Text.unpack comp <.> exeExtension + exeExists <- doesFileExist exePath + if exeExists + then return $ Just puId + else return Nothing + _ -> return Nothing diff --git a/src/BuildEnv/BuildOne.hs b/src/BuildEnv/BuildOne.hs new file mode 100644 --- /dev/null +++ b/src/BuildEnv/BuildOne.hs @@ -0,0 +1,569 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : BuildEnv.BuildOne +-- Description : Configure, build and install a single unit +-- +-- 'setupPackage' prepares a package for building, returning instructions +-- that compile its @Setup@ script. +-- +-- 'buildUnit' computes build instructions to configure, build and install +-- the unit using its @Setup@ script. If the unit is a library, the instructions +-- will also register it into a local package database using @ghc-pkg@. +module BuildEnv.BuildOne + ( -- * Building packages + setupPackage, buildUnit + + -- * Package directory structure helpers + + -- $twoDBs + + , PkgDir(..) + , getPkgDir + , PkgDbDirs(..) + , getPkgDbDirsForPrep, getPkgDbDirsForBuild + ) where + +-- base +import Control.Concurrent + ( QSem, newQSem ) +import Data.Foldable + ( for_ ) +import Data.Kind + ( Type ) +import Data.Maybe + ( maybeToList ) + +-- containers +import Data.Map.Strict + ( Map ) +import qualified Data.Map.Strict as Map + ( lookup ) + +-- directory +import System.Directory + +-- filepath +import System.FilePath + ( (), (<.>) + , makeRelative + ) + +-- text +import Data.Text + ( Text ) +import qualified Data.Text as Text + ( unpack ) + +-- build-env +import BuildEnv.Config +import BuildEnv.CabalPlan +import BuildEnv.Script +import BuildEnv.Utils + ( ProgPath(..), CallProcess(..) + , abstractQSem, noSem + ) + +-------------------------------------------------------------------------------- +-- Setup + +-- | Setup a single package. +-- +-- Returns a build script which compiles the @Setup@ script. +setupPackage :: Verbosity + -> Compiler + -> BuildPaths ForBuild -- ^ Overall build directory structure. + -> PkgDbDirs ForBuild -- ^ Package database directories (see 'getPkgDbDirsForBuild'). + -> PkgDir ForPrep -- ^ Package directory (to find the @Setup.hs@). + -> PkgDir ForBuild -- ^ Package directory (to build the @Setup.hs@). + -> Map UnitId PlanUnit -- ^ All dependencies in the build plan. + -> ConfiguredUnit -- ^ The unit to build. + -> IO BuildScript +setupPackage verbosity + ( Compiler { ghcPath } ) + paths@( BuildPaths { installDir, logDir } ) + ( PkgDbDirsForBuild { tempPkgDbDir } ) + ( PkgDir { pkgNameVer, pkgDir = prepPkgDir } ) + ( PkgDir { pkgDir = buildPkgDir } ) + plan + unit@( ConfiguredUnit { puId, puSetupDepends, puExeDepends } ) + + = do let logPath + | verbosity <= Quiet + = Nothing + | otherwise + = Just $ logDir Text.unpack ( unUnitId puId ) + -- Find the appropriate Setup.hs file (creating one if necessary) + setupHs <- findSetupHs prepPkgDir + return do + scriptCfg <- askScriptConfig + let setupArgs = [ quoteArg scriptCfg (buildPkgDir setupHs) + , "-o" + , quoteArg scriptCfg (buildPkgDir "Setup") + , "-package-db=" ++ quoteArg scriptCfg tempPkgDbDir + , ghcVerbosity verbosity + ] ++ map unitIdArg puSetupDepends + + -- Specify location of binaries and data directories. + -- + -- See the commentary around 'depDataDirs' in 'buildUnit'. + binDirs = [ quoteArg scriptCfg $ installDir "bin" Text.unpack ( unUnitId exeUnitId ) + | exeUnitId <- puExeDepends ] + setupDepDataDirs = + dataDirs scriptCfg paths + [ dep_cu + | depUnitId <- puSetupDepends + , let dep = lookupDependency unit depUnitId plan + , dep_cu <- maybeToList $ configuredUnitMaybe dep + ] + logMessage verbosity Verbose $ + "Compiling Setup.hs for " <> pkgNameVer + callProcess $ + CP { cwd = "." + , prog = AbsPath ghcPath + , args = setupArgs + , extraPATH = binDirs + , extraEnvVars = setupDepDataDirs + , logBasePath = logPath + , sem = noSem + } + +-- | Find the @Setup.hs@/@Setup.lhs@ file to use, +-- or create one using @main = defaultMain@ if none exist. +findSetupHs :: FilePath -> IO FilePath +findSetupHs root = trySetupsOrUseDefault [ "Setup.hs", "Setup.lhs" ] + where + useDefaultSetupHs = do + let path = root "Setup.hs" + writeFile path defaultSetupHs + return "Setup.hs" + + try fname = do + let path = root fname + exists <- doesFileExist path + return $ if exists then Just fname else Nothing + + defaultSetupHs = unlines + [ "import Distribution.Simple" + , "main = defaultMain" + ] + + trySetupsOrUseDefault [] = useDefaultSetupHs + trySetupsOrUseDefault (setupPath:setups) = do + res <- try setupPath + case res of + Nothing -> trySetupsOrUseDefault setups + Just setup -> return setup + +-------------------------------------------------------------------------------- +-- Build + +-- | Return build steps to to configure, build and and installing the unit, +-- including registering it in the package database if it is a library. +-- +-- You can run the build script with 'executeBuildScript', or you can +-- turn it into a shell script with 'script'. +-- +-- Note: executing the build script will fail if the unit has already been +-- registered in the package database. +buildUnit :: Verbosity + -> Compiler + -> BuildPaths ForBuild -- ^ Overall build directory structure. + -> PkgDbDirs ForBuild -- ^ Package database directories (see 'getPkgDbDirsForBuild'). + -> PkgDir ForBuild -- ^ This package's directory (see 'getPkgDir'). + -> UnitArgs -- ^ Extra arguments for this unit. + -> Map UnitId PlanUnit -- ^ All dependencies in the build plan. + -> ConfiguredUnit -- ^ The unit to build. + -> BuildScript +buildUnit verbosity + ( Compiler { ghcPath, ghcPkgPath } ) + paths@( BuildPaths { installDir, prefix, destDir, logDir } ) + ( PkgDbDirsForBuild + { tempPkgDbDir + , finalPkgDbDir + , tempPkgDbSem + , finalPkgDbSem } ) + ( PkgDir { pkgDir, pkgNameVer } ) + ( UnitArgs { configureArgs = userConfigureArgs + , mbHaddockArgs = mbUserHaddockArgs + , registerArgs = userGhcPkgArgs } ) + plan unit@( ConfiguredUnit { puId, puDepends, puExeDepends } ) + = let compName = Text.unpack $ cabalComponent ( puComponentName unit ) + thisUnit'sId = Text.unpack ( unUnitId puId ) + logPath + | verbosity <= Quiet + = Nothing + | otherwise + = Just $ logDir thisUnit'sId + unitPrintableName + | verbosity >= Verbose + = pkgNameVer <> ":" <> compName + | otherwise + = compName + + in do + scriptCfg <- askScriptConfig + + let -- Specify the data directories for all dependencies, + -- including executable dependencies (see (**)). + -- This is important so that e.g. 'happy' can find its datadir. + depDataDirs = + dataDirs scriptCfg paths + [ dep_cu + | depUnitId <- unitDepends unit -- (**) depends ++ exeDepends + , let dep = lookupDependency unit depUnitId plan + , dep_cu <- maybeToList $ configuredUnitMaybe dep + ] + + -- Configure + let flagsArg = case puFlags unit of + flags + | flagSpecIsEmpty flags + -> [] + | otherwise + -> [ "--flags=" ++ quoteArg scriptCfg ( Text.unpack (showFlagSpec flags) ) ] + + -- Set a different build directory for each unit, + -- to avoid clashes when building multiple units from the same + -- package concurrently. + buildDir = quoteArg scriptCfg -- Quote to escape \ on Windows. + $ "temp-build" thisUnit'sId + + -- Set a different binDir for each executable unit, + -- so that we can know precisely which executables have been built + -- for the purpose of resumable builds. + thisUnit'sBinDir = quoteArg scriptCfg + $ prefix "bin" thisUnit'sId + -- NB: use prefix not installDir here, otherwise the copy command + -- will duplicate destDir. + thisUnit'sBinDirArg + | Exe <- cuComponentType unit + = [ "--bindir=" ++ thisUnit'sBinDir ] + | otherwise + = [] + + -- Add the output binary directories to PATH, to satisfy executable + -- dependencies during the build. + binDirs = [ quoteArg scriptCfg $ + installDir "bin" Text.unpack ( unUnitId exeUnitId ) + | exeUnitId <- puExeDepends ] + + -- NB: make sure to update the readme after changing + -- the arguments that are passed here. + configureArgs = [ "--with-compiler", quoteArg scriptCfg ghcPath + , "--prefix", quoteArg scriptCfg prefix + , "--cid=" ++ Text.unpack (unUnitId puId) + , "--package-db=" ++ quoteArg scriptCfg tempPkgDbDir + , "--exact-configuration" + , "--datasubdir=" ++ pkgNameVer + , "--builddir=" ++ buildDir + , setupVerbosity verbosity + ] ++ thisUnit'sBinDirArg + ++ flagsArg + ++ map ( dependencyArg plan unit ) puDepends + ++ userConfigureArgs + ++ [ buildTarget unit ] + setupExe = RelPath $ runCwdExe scriptCfg "Setup" -- relative to pkgDir + + logMessage verbosity Verbose $ + "Configuring " <> unitPrintableName + logMessage verbosity Debug $ + "Configure arguments:\n" <> unlines (map (" " <>) configureArgs) + callProcess $ + CP { cwd = pkgDir + , prog = setupExe + , args = "configure" : configureArgs + , extraPATH = binDirs + , extraEnvVars = depDataDirs -- Not sure this is needed for 'Setup configure'. + , logBasePath = logPath + , sem = noSem + } + + -- Build + logMessage verbosity Verbose $ + "Building " <> unitPrintableName + callProcess $ + CP { cwd = pkgDir + , prog = setupExe + , args = [ "build" + , "--builddir=" ++ buildDir + , setupVerbosity verbosity ] + , extraPATH = binDirs + , extraEnvVars = depDataDirs + , logBasePath = logPath + , sem = noSem + } + + -- Haddock + for_ mbUserHaddockArgs \ userHaddockArgs -> do + logMessage verbosity Verbose $ + "Building documentation for " <> unitPrintableName + callProcess $ + CP { cwd = pkgDir + , prog = setupExe + , args = [ "haddock" + , "--builddir=" ++ buildDir + , setupVerbosity verbosity ] + ++ userHaddockArgs + , extraPATH = binDirs + , extraEnvVars = depDataDirs + , logBasePath = logPath + , sem = noSem + } + + -- Copy + logMessage verbosity Verbose $ + "Copying " <> unitPrintableName + callProcess $ + CP { cwd = pkgDir + , prog = setupExe + , args = [ "copy", setupVerbosity verbosity + , "--builddir=" ++ buildDir + , "--destdir", quoteArg scriptCfg destDir ] + , extraPATH = [] + , extraEnvVars = [] + , logBasePath = logPath + , sem = noSem + } + + -- Register + case cuComponentType unit of + Lib -> do + -- Register library (in both the local and final package databases) + -- See Note [Using two package databases]. + let pkgRegsFile = thisUnit'sId <> "-pkg-reg.conf" + dirs = [ ( tempPkgDbDir, tempPkgDbSem, "temporary", ["--inplace"], []) + , (finalPkgDbDir, finalPkgDbSem, "final" , [], "--force" : userGhcPkgArgs) ] + + for_ dirs \ (pkgDbDir, pkgDbSem, desc, extraSetupArgs, extraPkgArgs) -> do + + logMessage verbosity Verbose $ + mconcat [ "Registering ", unitPrintableName, " in " + , desc, " package database at:\n " + , pkgDbDir ] + + -- Setup register + callProcess $ + CP { cwd = pkgDir + , prog = setupExe + , args = [ "register", setupVerbosity verbosity + , "--builddir=" ++ buildDir + , "--gen-pkg-config=" ++ pkgRegsFile + ] ++ extraSetupArgs + , extraPATH = [] + , extraEnvVars = [] + , logBasePath = logPath + , sem = noSem + } + + -- NB: we have configured & built a single target, + -- so there should be a single "pkg-reg.conf" file, + -- and not a directory of registration files. + + -- ghc-pkg register + callProcess $ + CP { cwd = pkgDir + , prog = AbsPath ghcPkgPath + , args = [ "register" + , ghcPkgVerbosity verbosity + , "--package-db", quoteArg scriptCfg pkgDbDir + , pkgRegsFile ] + ++ extraPkgArgs + , extraPATH = [] + , extraEnvVars = [] + , logBasePath = logPath + , sem = abstractQSem pkgDbSem + -- Take a lock to avoid contention on the package database + -- when building units concurrently. + } + + _notALib -> return () + + logMessage verbosity Normal $ "Finished building " <> unitPrintableName + reportProgress verbosity + +-- | The argument @-package-id PKG_ID@. +unitIdArg :: UnitId -> String +unitIdArg (UnitId unitId) = "-package-id " ++ Text.unpack unitId + +-- | The target to configure and build. +buildTarget :: ConfiguredUnit -> String +buildTarget ( ConfiguredUnit { puComponentName = comp } ) + = Text.unpack $ cabalComponent comp + +-- | The argument @--dependency=PKG:COMP=UNIT_ID@. +-- +-- Used to specify the 'UnitId' of a dependency to the configure script. +-- This allows us to perform a build using the specific dependencies we have +-- available, ignoring any bounds in the cabal file. +dependencyArg :: Map UnitId PlanUnit -> ConfiguredUnit -> UnitId -> String +dependencyArg fullPlan unitWeAreBuilding depUnitId + = "--dependency=" ++ Text.unpack (mkDependency pu) + where + pu :: PlanUnit + pu = lookupDependency unitWeAreBuilding depUnitId fullPlan + + mkDependency :: PlanUnit -> Text + mkDependency ( PU_Preexisting ( PreexistingUnit { puPkgName = PkgName nm } ) ) + = nm <> "=" <> unUnitId depUnitId + mkDependency ( PU_Configured ( ConfiguredUnit { puPkgName = PkgName pkg + , puComponentName = comp } ) ) + = pkg <> ":" <> componentName comp <> "=" <> unUnitId depUnitId + +-- | Look up a dependency in the full build plan. +-- +-- Throws an error if the dependency can't be found. +lookupDependency :: ConfiguredUnit -- ^ the unit which has the dependency + -- (for error messages only) + -> UnitId -- ^ dependency to look up + -> Map UnitId PlanUnit -- ^ build plan + -> PlanUnit +lookupDependency ( ConfiguredUnit { puPkgName = pkgWeAreBuilding } ) depUnitId plan + | Just pu <- Map.lookup depUnitId plan + = pu + | otherwise + = error $ "buildUnit: can't find dependency in build plan\n\ + \package: " ++ show pkgWeAreBuilding ++ "\n\ + \dependency: " ++ show depUnitId + +-------------------------------------------------------------------------------- +-- Directory structure computation helpers + +{- $twoDBs +__Note [Using two package databases]__ + +We need __two__ distinct package databases: we might want to perform the build +in a temporary location, before everything gets placed into its final +destination. The final package database might use a specific, baked-in +installation prefix (in the sense of @Setup configure --prefix pfx@). As a +result, this package database won't be immediately usable, as we won't have +copied over the build products yet. + +In order to be able to build packages in a temporary directory, we create a +temporary package database that is used for the build, making use of it +with @Setup register --inplace@. +We also register the packages into the final package database using +@ghc-pkg --force@: otherwise, @ghc-pkg@ would error because the relevant files +haven't been copied over yet. +-} + +-- | The package database directories. +-- +-- See Note [Using two package databases]. +type PkgDbDirs :: PathUsability -> Type +data family PkgDbDirs use + +data instance PkgDbDirs ForPrep + = PkgDbDirsForPrep + { tempPkgDbDir :: !FilePath + -- ^ Local package database directory. + } +data instance PkgDbDirs ForBuild + = PkgDbDirsForBuild + { tempPkgDbDir :: !FilePath + -- ^ Local package database directory. + , tempPkgDbSem :: !QSem + -- ^ Semaphore controlling access to the temporary + -- package database. + , finalPkgDbDir :: !FilePath + -- ^ Installation package database directory. + , finalPkgDbSem :: !QSem + -- ^ Semaphore controlling access to the installation + -- package database. + } + +-- | Compute the paths of the package database directories we are going +-- to use. +-- +-- See Note [Using two package databases]. +getPkgDbDirsForPrep :: Paths ForPrep -> PkgDbDirs ForPrep +getPkgDbDirsForPrep ( Paths { fetchDir } ) = + PkgDbDirsForPrep { tempPkgDbDir = fetchDir "package.conf" } + +-- | Compute the paths of the package database directories we are going +-- to use, and create some semaphores to control access to them +-- in order to avoid contention. +-- +-- See Note [Using two package databases]. +getPkgDbDirsForBuild :: Paths ForBuild -> IO (PkgDbDirs ForBuild) +getPkgDbDirsForBuild ( Paths { fetchDir, buildPaths = BuildPaths { installDir } } ) = do + tempPkgDbSem <- newQSem 1 + finalPkgDbSem <- newQSem 1 + return $ + PkgDbDirsForBuild { tempPkgDbDir, finalPkgDbDir, tempPkgDbSem, finalPkgDbSem } + where + tempPkgDbDir = fetchDir "package.conf" + finalPkgDbDir = installDir "package.conf" + +-- | The package @name-version@ string and its directory. +type PkgDir :: PathUsability -> Type +data PkgDir use + = PkgDir + { pkgNameVer :: !String + -- ^ Package @name-version@ string. + , pkgDir :: !FilePath + -- ^ Package directory. + } +type role PkgDir representational + -- Don't allow accidentally passing a @PkgDir ForPrep@ where one expects + -- a @PkgDir ForBuild@. + +-- | Compute the package directory location. +getPkgDir :: FilePath + -- ^ Working directory + -- (used only to relativise paths to local packages). + -> Paths use + -- ^ Overall directory structure to base the computation off. + -> ConfiguredUnit + -- ^ Any unit from the package in question. + -> PkgDir use +getPkgDir workDir ( Paths { fetchDir } ) + ( ConfiguredUnit { puPkgName, puVersion, puPkgSrc } ) + = PkgDir { pkgNameVer, pkgDir } + where + pkgNameVer = Text.unpack $ pkgNameVersion puPkgName puVersion + pkgDir + | Local dir <- puPkgSrc + = makeRelative workDir dir + -- Give local packages paths relative to the working directory, + -- to enable relocatable build scripts. + | otherwise + = fetchDir pkgNameVer + +-- | Command to run an executable located the current working directory. +runCwdExe :: ScriptConfig -> FilePath -> FilePath +runCwdExe ( ScriptConfig { scriptOutput, scriptStyle } ) + = pre . ext + where + pre + | Run <- scriptOutput + = id + | otherwise + = ( "./" <> ) + ext + | WinStyle <- scriptStyle + = ( <.> "exe" ) + | otherwise + = id + +-- | An environment containing the data directory paths for the given units. +dataDirs :: ScriptConfig + -> BuildPaths ForBuild + -> [ ConfiguredUnit ] + -> [ ( String, FilePath ) ] +dataDirs scriptCfg ( BuildPaths { installDir } ) units = + [ ( mangledPkgName puPkgName <> "_datadir" + , quoteArg scriptCfg $ + dataDir Text.unpack (pkgNameVersion puPkgName puVersion) ) + | ConfiguredUnit { puPkgName, puVersion } <- units ] + where + dataDir = + case scriptStyle scriptCfg of + WinStyle -> installDir + PosixStyle -> installDir "share" + -- NB: this is the default value of 'datadir'. + -- If we want the user to be able to specify 'datadir', we should + -- make it into an explicit argument, like 'prefix' & 'destdir'. diff --git a/src/BuildEnv/CabalPlan.hs b/src/BuildEnv/CabalPlan.hs new file mode 100644 --- /dev/null +++ b/src/BuildEnv/CabalPlan.hs @@ -0,0 +1,458 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : BuildEnv.CabalPlan +-- Description : Parsing Cabal plans from the @plan.json@ file format +-- +-- This module parses the @plan.json@ Cabal plan files that are created +-- by @cabal-install@. +-- +-- In the future, we hope to avoid doing this, and directly invoke Cabal's +-- solver to obtain the build plan, instead of invoking +-- @cabal-install build --dry-run@ and parsing the resulting @plan.json@ file. +module BuildEnv.CabalPlan + ( -- * Build plans + CabalPlan(..), mapMaybePlanUnits + , CabalPlanBinary(..), parsePlanBinary + + -- * Packages + , PkgName(..) + , pkgNameVersion, validPackageName + , mangledPkgName + + -- ** Allow-newer + + , AllowNewer(..) + + -- ** Package specification + + , PkgSpecs, PkgSpec(..) + , emptyPkgSpec, parsePkgSpec + , unionPkgSpecsOverriding + + -- *** Package constraints + + , Constraints(..) + + -- *** Package flags + , FlagSpec(..) + , showFlagSpec, flagSpecIsEmpty + + -- *** Package source location + , PkgSrc(..) + + -- * Units + + -- ** Units + + , UnitId(..) + , PlanUnit(..) + , planUnitUnitId, planUnitPkgName, planUnitVersion + + , PreexistingUnit(..) + , ConfiguredUnit(..) + , configuredUnitMaybe, cuComponentType + , allDepends, unitDepends + + + -- *** Units within a package + + , UnitSpecs + , unionUnitSpecsCombining + + -- ** Components + , ComponentName(..) + , cabalComponent, parsePkgComponent + , ComponentType(..) + , cabalComponentType, parseComponentType + + ) + where + +-- base +import Data.Char + ( isAlphaNum ) +import Data.Maybe + ( fromMaybe, mapMaybe ) +import Data.Version + ( Version, showVersion ) + +-- aeson +import Data.Aeson + +-- bytestring +import qualified Data.ByteString.Lazy as Lazy + ( ByteString ) + +-- containers +import qualified Data.Map.Strict as Strict + ( Map ) +import qualified Data.Map.Strict as Map +import Data.Set + ( Set ) + +-- text +import Data.Text + ( Text ) +import qualified Data.Text as Text + +------------------------------------------------------------------------------- +-- Build plans + +-- | Units in a Cabal @plan.json@ file. +newtype CabalPlan = CabalPlan { planUnits :: [PlanUnit] } + +mapMaybePlanUnits :: (PlanUnit -> Maybe a) -> CabalPlan -> [a] +mapMaybePlanUnits f (CabalPlan units) = mapMaybe f units + +instance Show CabalPlan where + show (CabalPlan us) + = unlines $ map show us + +instance FromJSON CabalPlan where + parseJSON = withObject "cabal plan" \ o -> + CabalPlan <$> o .: "install-plan" + +-- | Binary data underlying a @cabal@ @plan.json@ file. +newtype CabalPlanBinary = CabalPlanBinary Lazy.ByteString + +-- | Decode a 'CabalPlanBinary' into a 'CabalPlan'. +parsePlanBinary :: CabalPlanBinary -> CabalPlan +parsePlanBinary (CabalPlanBinary pb) = + case eitherDecode pb of + Left err -> error ("parsePlanBinary: failed to parse plan JSON\n" ++ err) + Right plan -> plan + +------------------------------------------------------------------------------- +-- Packages + +-- | A cabal package name, e.g. @lens@, @aeson@. +newtype PkgName = PkgName { unPkgName :: Text } + deriving stock Show + deriving newtype (Eq, Ord, FromJSON, FromJSONKey) + +-- | The @name-version@ string of a package. +pkgNameVersion :: PkgName -> Version -> Text +pkgNameVersion (PkgName n) v = n <> "-" <> Text.pack (showVersion v) + +-- | Is the string a valid @cabal@ package name? That is, does it consist +-- only of alphanumeric identifiers and hyphens? +validPackageName :: Text -> Bool +validPackageName = Text.all ( \ x -> isAlphaNum x || x == '-' ) + +-- | A Cabal mangled package name, in which @-@ has been replaced with @_@. +mangledPkgName :: PkgName -> String +mangledPkgName = map fixupChar . Text.unpack . unPkgName + where + fixupChar '-' = '_' + fixupChar c = c + +-- | A collection of allow-newer specifications, e.g. @pkg1:pkg2,*:base@. +newtype AllowNewer = AllowNewer ( Set (Text, Text) ) + deriving stock Show + deriving newtype ( Semigroup, Monoid ) + +-- | A mapping from a package name to its flags and constraints. +type PkgSpecs = Strict.Map PkgName PkgSpec + +-- | Constraints and flags for a package. +data PkgSpec = PkgSpec { psConstraints :: !( Maybe Constraints ) + , psFlags :: !FlagSpec + } + deriving stock Show + +-- | No flags or constraints on a package. +emptyPkgSpec :: PkgSpec +emptyPkgSpec = PkgSpec Nothing mempty + +-- | Parse flags and constraints (in that order). +parsePkgSpec :: Text -> PkgSpec +parsePkgSpec l = parseSpec Map.empty ( Text.words l ) + where + parseSpec :: Strict.Map Text Bool -> [Text] -> PkgSpec + parseSpec flags [] + = PkgSpec { psConstraints = Nothing + , psFlags = FlagSpec flags } + parseSpec flags (w:ws) + | Just (s,f) <- Text.uncons w + , s == '+' || s == '-' + = parseSpec (Map.insert f (s == '+') flags) ws + | otherwise + = PkgSpec { psConstraints = Just $ Constraints (Text.unwords (w:ws)) + , psFlags = FlagSpec flags } + +instance Semigroup PkgSpec where + ( PkgSpec c1 f1 ) <> ( PkgSpec c2 f2 ) = + PkgSpec ( c1 <> c2 ) + ( f1 <> f2 ) + +-- | Left-biased union of two sets of packages, +-- overriding flags and constraints of the second argument +-- with those provided in the first argument. +unionPkgSpecsOverriding :: PkgSpecs -> PkgSpecs -> PkgSpecs +unionPkgSpecsOverriding = Map.unionWith unionPkgSpec + +-- | Combine two 'UnitSpecs'. Combines constraints and flags. +unionUnitSpecsCombining :: UnitSpecs -> UnitSpecs -> UnitSpecs +unionUnitSpecsCombining = Map.unionWith (<>) + +-- | Left-biased union of package flags and constraints. +unionPkgSpec :: PkgSpec -> PkgSpec -> PkgSpec +unionPkgSpec (PkgSpec strongCts strongFlags) (PkgSpec weakCts weakFlags) + = PkgSpec cts (strongFlags <> weakFlags) + where + cts = case strongCts of + Nothing -> weakCts + _ -> strongCts + +-- | A collection of cabal constraints, e.g. @>= 3.2 && < 3.4@, +-- in raw textual format. +newtype Constraints = Constraints Text + deriving stock Show + +-- | Combine two constraints using @&&@. +instance Semigroup Constraints where + Constraints c1 <> Constraints c2 = + Constraints ( " ( " <> c1 <> " ) && ( " <> c2 <> " )" ) + +-- | Specification of package flags, e.g. @+foo -bar@. +-- +-- @+@ corresponds to @True@ and @-@ to @False@. +newtype FlagSpec = FlagSpec (Strict.Map Text Bool) + deriving stock Show + deriving newtype (Eq, Ord, Semigroup, Monoid, FromJSON) + +showFlagSpec :: FlagSpec -> Text +showFlagSpec (FlagSpec fs) = + Text.unwords + [ sign <> flag + | (flag, value) <- Map.toList fs + , let sign = if value then "+" else "-" + ] + +flagSpecIsEmpty :: FlagSpec -> Bool +flagSpecIsEmpty (FlagSpec fs) = null fs + +-- | The source location of a package. +-- +-- - @Nothing@: it's in the package database (e.g. Hackage). +-- - @Just fp@: specified by the @cabal@ file at the given path. +data PkgSrc + = Remote + | Local !FilePath + deriving stock Show + +instance Semigroup PkgSrc where + Remote <> b = b + a <> _ = a + +instance Monoid PkgSrc where + mempty = Remote + +instance FromJSON PkgSrc where + parseJSON = withObject "package source" \ o -> do + ty <- o .: "type" + case ty :: Text of + "local" -> Local <$> o .: "path" + "repo-tar" -> return Remote + -- <$> o .: "repo" + _ -> + error $ + "parseJSON PkgSrc: unsupported 'pkg-src' field: " + <> Text.unpack ty + +------------------------------------------------------------------------------- +-- Units + +-- | A unique identifier for a unit, +-- e.g. @lens-5.2-1bfd85cb66d2330e59a2f957e87cac993d922401@. +newtype UnitId = UnitId { unUnitId :: Text } + deriving stock Show + deriving newtype (Eq, Ord, FromJSON, FromJSONKey) + +data PlanUnit + = PU_Preexisting !PreexistingUnit + | PU_Configured !ConfiguredUnit + deriving stock Show + +planUnitUnitId :: PlanUnit -> UnitId +planUnitUnitId (PU_Preexisting (PreexistingUnit { puId })) = puId +planUnitUnitId (PU_Configured (ConfiguredUnit { puId })) = puId + +planUnitPkgName :: PlanUnit -> PkgName +planUnitPkgName (PU_Preexisting (PreexistingUnit { puPkgName })) = puPkgName +planUnitPkgName (PU_Configured (ConfiguredUnit { puPkgName })) = puPkgName + +planUnitVersion :: PlanUnit -> Version +planUnitVersion (PU_Preexisting (PreexistingUnit { puVersion })) = puVersion +planUnitVersion (PU_Configured (ConfiguredUnit { puVersion })) = puVersion + +instance FromJSON PlanUnit where + parseJSON = withObject "plan unit" \ o -> do + ty <- o .: "type" + case ty :: Text of + "pre-existing" -> PU_Preexisting <$> preExisting o + "configured" -> PU_Configured <$> configured o + _ -> error $ + "parseJSON PlanUnit: unexpected type " ++ Text.unpack ty ++ ",\n\ + \expecting 'pre-existing' or 'configured'" + where + preExisting o = do + puId <- o .: "id" + puPkgName <- o .: "pkg-name" + puVersion <- o .: "pkg-version" + puDepends <- o .: "depends" + return $ PreexistingUnit {..} + + configured o = do + puId <- o .: "id" + puPkgName <- o .: "pkg-name" + puVersion <- o .: "pkg-version" + puFlags <- fromMaybe (FlagSpec Map.empty) <$> o .:? "flags" + mbComps <- o .:? "components" + puPkgSrc <- o .: "pkg-src" + (puComponentName, puDepends, puExeDepends, puSetupDepends) <- + case mbComps of + Nothing -> do + deps <- o .: "depends" + exeDeps <- o .: "exe-depends" + compName <- o .: "component-name" + let + comp + | compName == "lib" + = ComponentName Lib (unPkgName puPkgName) + | (ty,nm) <- Text.break (== ':') compName + , Just compTy <- parseComponentType ty + , not $ Text.null nm + = ComponentName compTy (Text.drop 1 nm) + | otherwise + = error $ "parseJSON PlanUnit: unsupported component name " + <> Text.unpack compName + return (comp, deps, exeDeps, []) + Just comps -> do + lib <- comps .: "lib" + deps <- lib .: "depends" + exeDeps <- lib .: "exe-depends" + mbSetup <- comps .:? "setup" + setupDeps <- + case mbSetup of + Nothing -> return [] + Just setup -> setup .: "depends" + return (ComponentName Lib (unPkgName puPkgName), deps, exeDeps, setupDeps) + return $ ConfiguredUnit {..} + +-- | Information about a built-in pre-existing unit (such as @base@). +data PreexistingUnit + = PreexistingUnit + { puId :: !UnitId + , puPkgName :: !PkgName + , puVersion :: !Version + , puDepends :: ![UnitId] + } + deriving stock Show + +-- | Information about a unit: name, version, dependencies, flags. +data ConfiguredUnit + = ConfiguredUnit + { puId :: !UnitId + , puPkgName :: !PkgName + , puVersion :: !Version + , puComponentName :: !ComponentName + , puFlags :: !FlagSpec + , puDepends :: ![UnitId] + , puExeDepends :: ![UnitId] + , puSetupDepends :: ![UnitId] + , puPkgSrc :: !PkgSrc + } + deriving stock Show + +configuredUnitMaybe :: PlanUnit -> Maybe ConfiguredUnit +configuredUnitMaybe (PU_Configured pu) = Just pu +configuredUnitMaybe (PU_Preexisting {}) = Nothing + +-- | Get what kind of component this unit is: @lib@, @exe@, etc. +cuComponentType :: ConfiguredUnit -> ComponentType +cuComponentType = componentType . puComponentName + +-- | All the dependencies of a unit: @depends@, @exe-depends@ and @setup-depends@. +allDepends :: ConfiguredUnit -> [UnitId] +allDepends (ConfiguredUnit { puDepends, puExeDepends, puSetupDepends }) = + puDepends ++ puExeDepends ++ puSetupDepends + +-- | The dependencies of a unit, excluding @setup-depends@. +unitDepends :: ConfiguredUnit -> [UnitId] +unitDepends (ConfiguredUnit { puDepends, puExeDepends }) = + puDepends ++ puExeDepends + +-- | A mapping from a package name to its flags, constraints, +-- and components we want to build from it. +type UnitSpecs = Strict.Map PkgName (PkgSrc, PkgSpec, Set ComponentName) + +-- | The name of a cabal component, e.g. @lib:comp@. +data ComponentName = + ComponentName { componentType :: !ComponentType + -- ^ What's before the colon, e.g. @lib@, @exe@, @setup@... + , componentName :: !Text + -- ^ The actual name of the component. + } + deriving stock (Eq, Ord, Show) + +-- | Print a cabal component using colon syntax @ty:comp@. +cabalComponent :: ComponentName -> Text +cabalComponent (ComponentName ty nm) = cabalComponentType ty <> ":" <> nm + +-- | Parse a cabal package component, using the syntax @pkg:ty:comp@, +-- e.g. @attoparsec:lib:attoparsec-internal@. +parsePkgComponent :: Text -> Maybe ( PkgName, ComponentName ) +parsePkgComponent txt = case Text.splitOn ":" txt of + ty:pkg:[] + | Just t <- parseComponentType ty + , validPackageName pkg + -> Just ( PkgName pkg, ComponentName t pkg ) + pkg:ty:comp:[] + | Nothing <- parseComponentType pkg + , validPackageName pkg + , Just t <- parseComponentType ty + , validPackageName comp + -> Just ( PkgName pkg, ComponentName t comp ) + pkg:comp:[] + | Nothing <- parseComponentType pkg + , validPackageName pkg + , validPackageName comp + -> Just ( PkgName comp, ComponentName Lib comp ) + pkg:[] + | Nothing <- parseComponentType pkg + , validPackageName pkg + -> Just ( PkgName pkg, ComponentName Lib pkg ) + _ -> Nothing + +-- | The type of a component, e.g. library, executable, test-suite... +data ComponentType + = Lib + | FLib + | Exe + | Test + | Bench + | Setup + deriving stock (Eq, Ord, Show) + +-- | Print the cabal component type as expected in cabal colon syntax +-- @pkg:ty:comp@. +cabalComponentType :: ComponentType -> Text +cabalComponentType Lib = "lib" +cabalComponentType FLib = "flib" +cabalComponentType Exe = "exe" +cabalComponentType Test = "test" +cabalComponentType Bench = "bench" +cabalComponentType Setup = "setup" + +-- | Parse the type of a @cabal@ component, e.g library, executable, etc. +parseComponentType :: Text -> Maybe ComponentType +parseComponentType "lib" = Just Lib +parseComponentType "flib" = Just FLib +parseComponentType "exe" = Just Exe +parseComponentType "test" = Just Test +parseComponentType "bench" = Just Bench +parseComponentType "setup" = Just Setup +parseComponentType _ = Nothing diff --git a/src/BuildEnv/Config.hs b/src/BuildEnv/Config.hs new file mode 100644 --- /dev/null +++ b/src/BuildEnv/Config.hs @@ -0,0 +1,372 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : BuildEnv.Config +-- Description : Configuration options for @build-env@ +-- +-- Configuration options for @build-env@ +module BuildEnv.Config + ( -- * Build strategy + BuildStrategy(..), RunStrategy(..) + , AsyncSem(..), semDescription + + -- * Passing arguments + , Args, UnitArgs(..) + + -- * @ghc@ and @cabal-install@ executables + , Compiler(..), Cabal(..) + + -- * Directory structure + , Paths(..), BuildPaths(..) + , PathUsability(..) + , canonicalizePaths + + -- ** Handling of temporary directories + , TempDirPermanence(..) + + -- * Logging verbosity + , Verbosity(.., Quiet, Normal, Verbose, Debug) + , quietMsg, normalMsg, verboseMsg, debugMsg + , ghcVerbosity, ghcPkgVerbosity, cabalVerbosity, setupVerbosity + + -- * Reporting progress + , Counter(..) + + -- * OS specifics + , Style(..), hostStyle + , pATHSeparator + + ) where + +-- base +import Control.Monad + ( when ) +import Data.Kind + ( Type ) +import Data.IORef + ( IORef ) +import Data.Word + ( Word16 ) +import System.IO + ( hFlush, stdout ) + +-- directory +import System.Directory + ( canonicalizePath ) + +-- filepath +import System.FilePath + ( (), dropDrive ) + +-- text +import Data.Text + ( Text ) +import qualified Data.Text as Text + ( pack ) +import qualified Data.Text.IO as Text + ( putStrLn ) + +-- time +import Data.Time.Clock + ( getCurrentTime ) +import Data.Time.Format + ( defaultTimeLocale, formatTime ) + +-------------------------------------------------------------------------------- +-- Build strategy + +-- | Build strategy for 'BuildEnv.Build.buildPlan'. +data BuildStrategy + -- | Execute the build plan in-place. + = Execute RunStrategy + -- | Output a build script that can be run later. + | Script + { scriptPath :: !FilePath + -- ^ Output path at which to write the build script. + , useVariables :: !Bool + -- ^ Should the output shell script use variables, or baked in paths? + -- + -- The shell script will use the following variables: + -- + -- - @GHC@, @GHCPKG@, @SOURCES@, @PREFIX@, @DESTDIR@. + } + deriving stock Show + +-- | How to execute a build plan. +data RunStrategy + -- | Topologically sort the cabal build plan, and build the + -- packages in sequence. + = TopoSort + -- | Asynchronously build all the packages, with each package + -- waiting on its dependencies. + | Async + AsyncSem + -- ^ The kind of semaphore to use to control concurrency. + deriving stock Show + +-- | What kind of semaphore to use in 'BuildEnv.Build.buildPlan'? +-- +-- NB: this datatype depends on whether the @jsem@ flag +-- was enabled when building the @build-env@ package. +data AsyncSem + -- | Don't use any semaphore (not recommended). + = NoSem + -- | Create a new 'Control.Concurrent.QSem.QSem' semaphore + -- with the given number of tokens. + | NewQSem !Word16 + deriving stock Show + +-- | A description of the kind of semaphore we are using to control concurrency. +semDescription :: AsyncSem -> Text +semDescription = \case + NoSem -> "no semaphore" + NewQSem i -> "-j" <> Text.pack (show i) + +-------------------------------------------------------------------------------- +-- Arguments + +-- | A type synonym for command-line arguments. +type Args = [String] + +-- | Arguments specific to a unit. +data UnitArgs = + UnitArgs { configureArgs :: !Args + -- ^ Arguments to @Setup configure@. + , mbHaddockArgs :: !(Maybe Args) + -- ^ Arguments to @Setup haddock@. + -- @Nothing@ means: skip @Setup haddock@. + , registerArgs :: !Args + -- ^ Arguments to @ghc-pkg register@. + } + deriving stock Show + +-------------------------------------------------------------------------------- +-- GHC & cabal-install + +-- | Path to the @cabal-install@ executable. +data Cabal = Cabal { cabalPath :: !FilePath + , globalCabalArgs :: !Args + -- ^ Arguments to pass to all @cabal@ invocations, + -- before any @cabal@ command. + } + deriving stock Show + +-- | Paths to the @ghc@ and @ghc-pkg@ executables. +data Compiler = + Compiler { ghcPath :: !FilePath + , ghcPkgPath :: !FilePath + } + deriving stock Show + +-------------------------------------------------------------------------------- +-- Directory structure + +-- | The directory structure relevant to preparing and carrying out +-- a build plan. +type Paths :: PathUsability -> Type +data Paths use + = Paths + { fetchDir :: !FilePath + -- ^ Input fetched sources directory. + , buildPaths :: BuildPaths use + -- ^ Output build directory structure. + -- + -- NB: this will be bottom in the case that we are outputing + -- a shell script that uses variables. + } + +-- | The directory structure relevant to executing a build plan. +type BuildPaths :: PathUsability -> Type +data family BuildPaths use +data instance BuildPaths Raw + = RawBuildPaths + { rawDestDir :: !FilePath + -- ^ Raw output build @destdir@ (might be relative). + , rawPrefix :: !FilePath + -- ^ Raw output build @prefix@ (might be relative). + } +data instance BuildPaths ForPrep + = BuildPathsForPrep + { compilerForPrep :: !Compiler + -- ^ Which @ghc@ and @ghc-pkg@ to use. + , installDir :: !FilePath + -- ^ Output installation directory @destdir/prefix@ (absolute). + } +data instance BuildPaths ForBuild + = BuildPaths + { compiler :: !Compiler + -- ^ Which @ghc@ and @ghc-pkg@ to use. + , destDir :: !FilePath + -- ^ Output build @destdir@ (absolute). + , prefix :: !FilePath + -- ^ Output build @prefix@ (absolute). + , installDir :: !FilePath + -- ^ Output installation directory @destdir/prefix@ (absolute). + , logDir :: !FilePath + -- ^ Directory in which to put logs. + } + +-- | The appropriate stage at which to use a filepath. +data PathUsability + -- | We have just parsed filepaths. They need to be canonicalised + -- before they can be used. + = Raw + -- | The filepaths have been canonicalised. + -- + -- They are now suitable for preparatory build instructions, + -- but not for performing the build. + | ForPrep + -- | The paths are suitable for performing the build. + | ForBuild + +-- | Canonicalise raw 'Paths', computing the appropriate directory structure +-- for preparing and executing a build, respectively. +canonicalizePaths :: Compiler + -> BuildStrategy + -> Paths Raw + -> IO ( Paths ForPrep, Paths ForBuild ) +canonicalizePaths compiler buildStrat + ( Paths + { fetchDir = fetchDir0 + , buildPaths = RawBuildPaths { rawPrefix, rawDestDir } } ) + = do + fetchDir <- canonicalizePath fetchDir0 + prefix <- canonicalizePath rawPrefix + destDir <- canonicalizePath rawDestDir + installDir <- canonicalizePath ( rawDestDir dropDrive prefix ) + -- We must use dropDrive here. Quoting from the documentation of (): + -- + -- If the second path starts with a path separator or a drive letter, + -- then () returns the second path. + -- + -- We don't want that, as we *do* want to concatenate both paths. + + logDir <- case buildStrat of + Script {} -> return "${LOGDIR}" -- LOGDIR is defined by the script. + Execute {} -> do + -- Pick the logging directory based on the current time. + time <- getCurrentTime + let logDir = "logs" formatTime defaultTimeLocale "%0Y-%m-%d_%H-%M-%S" time + canonicalizePath logDir + + let forBuild = case buildStrat of + Script { useVariables } + | useVariables + -> Paths { fetchDir = "${SOURCES}" + , buildPaths = + BuildPaths + { prefix = "${PREFIX}" + , destDir = "${DESTDIR}" + , installDir = "${DESTDIR}" "${PREFIX}" + , logDir + , compiler = + Compiler { ghcPath = "${GHC}" + , ghcPkgPath = "${GHCPKG}" } } } + _don'tUseVars -> + Paths { fetchDir + , buildPaths = + BuildPaths { compiler, destDir, prefix, installDir, logDir } } + return $ + ( Paths { fetchDir + , buildPaths = + BuildPathsForPrep { compilerForPrep = compiler, installDir } } + , forBuild ) + +-- | How to handle deletion of temporary directories. +data TempDirPermanence + = DeleteTempDirs + | Don'tDeleteTempDirs + deriving stock Show + +-------------------------------------------------------------------------------- +-- Verbosity + +-- | Verbosity level for the @build-env@ package. +-- +-- The default verbosity level is 'Normal' (1). +newtype Verbosity = Verbosity Int + deriving newtype (Eq, Ord, Num) + deriving stock Show + +-- | Get the flag corresponding to a verbosity, e.g. @-v2@. +verbosityFlag :: Verbosity -> String +verbosityFlag ( Verbosity i ) + | i <= 0 + = "-v0" + | otherwise + = "-v" <> show i + +pattern Quiet, Normal, Verbose, Debug :: Verbosity +pattern Quiet = Verbosity 0 +pattern Normal = Verbosity 1 +pattern Verbose = Verbosity 2 +pattern Debug = Verbosity 3 + +quietMsg, normalMsg, verboseMsg, debugMsg :: Verbosity -> Text -> IO () +quietMsg v msg = when (v >= Quiet ) $ putMsg msg +normalMsg v msg = when (v >= Normal ) $ putMsg msg +verboseMsg v msg = when (v >= Verbose) $ putMsg msg +debugMsg v msg = when (v >= Debug ) $ putMsg msg + +-- | Write the text to @stdout@, and flush. +putMsg :: Text -> IO () +putMsg msg = do + Text.putStrLn msg + hFlush stdout + +ghcVerbosity, ghcPkgVerbosity, cabalVerbosity, setupVerbosity + :: Verbosity -> String +ghcVerbosity = verbosityFlag . min maxGhcVerbosity . subtract 1 +ghcPkgVerbosity = verbosityFlag . min maxGhcPkgVerbosity . subtract 1 +cabalVerbosity = verbosityFlag . min maxCabalVerbosity . subtract 1 +setupVerbosity = verbosityFlag . min maxSetupVerbosity . subtract 1 + +maxGhcVerbosity, maxGhcPkgVerbosity, maxCabalVerbosity, maxSetupVerbosity + :: Verbosity +maxGhcVerbosity = Verbosity 3 +maxGhcPkgVerbosity = Verbosity 2 +maxCabalVerbosity = Verbosity 3 +maxSetupVerbosity = maxCabalVerbosity + +-------------------------------------------------------------------------------- +-- Reporting progress. + +-- | A counter to measure progress, as units are compiled. +data Counter = + Counter + { counterRef :: !( IORef Word ) + -- ^ The running count. + , counterMax :: !Word + -- ^ The maximum that we're counting up to. + } + +-------------------------------------------------------------------------------- +-- Posix/Windows style differences. + +-- | Whether to use Posix or Windows style: +-- +-- - for executables, @./prog@ vs @prog.exe@, +-- - for the path separator, @:@ vs @;@. +data Style + = PosixStyle + | WinStyle + +-- | OS-dependent separator for the PATH environment variable. +pATHSeparator :: Style -> String +pATHSeparator PosixStyle = ":" +pATHSeparator WinStyle = ";" + +-- | The style associated with the OS the program is currently running on. +hostStyle :: Style +hostStyle = +#if defined(mingw32_HOST_OS) + WinStyle +#else + PosixStyle +#endif diff --git a/src/BuildEnv/File.hs b/src/BuildEnv/File.hs new file mode 100644 --- /dev/null +++ b/src/BuildEnv/File.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module : BuildEnv.File +-- Description : Parse packages and units from files +-- +-- This module implements the parsing of the two file formats supported +-- by @build-env@: +-- +-- - SEED files, containing a list of seed units from which to compute +-- a build plan. See 'parseSeedFile'. +-- +-- - @cabal.config@ files containing version constraints on packages. +-- See 'parseCabalDotConfigPkgs'. +module BuildEnv.File + ( parseCabalDotConfigPkgs, parseSeedFile ) + where + +-- base +import Data.Char + ( isSpace ) + +-- containers +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +-- text +import Data.Text + ( Text ) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text + +-- build-env +import BuildEnv.CabalPlan + +-------------------------------------------------------------------------------- + +-- | Parse constrained packages from the @constraints@ stanza +-- of the @cabal.config@ file at the given filepath: +-- +-- > constraints: pkg1 ==ver1, +-- > pkg2 ==ver2, +-- > ... +-- +-- This function disregards all other contents of the @cabal.config@ package. +parseCabalDotConfigPkgs :: FilePath -> IO PkgSpecs +parseCabalDotConfigPkgs fp = do + ls <- filter ( not . isCommentLine . Text.strip ) + . Text.lines + <$> Text.readFile fp + return $ outsideStanza Map.empty ls + where + outsideStanza :: PkgSpecs -> [Text] -> PkgSpecs + outsideStanza pkgs [] + = pkgs + outsideStanza pkgs (l:ls) + | Just rest <- Text.stripPrefix "constraints:" l + = inConstraintsStanza (pkgs `addPkgFromLine` rest) ls + | otherwise + = outsideStanza pkgs ls + + inConstraintsStanza :: PkgSpecs -> [Text] -> PkgSpecs + inConstraintsStanza pkgs [] + = pkgs + inConstraintsStanza pkgs (l:ls) + | let (ws, rest) = Text.span isSpace l + , not $ Text.null ws + = inConstraintsStanza (pkgs `addPkgFromLine` rest) ls + | otherwise + = outsideStanza pkgs (l:ls) + + addPkgFromLine :: PkgSpecs -> Text -> PkgSpecs + addPkgFromLine pkgs l = + let (pkgName, pkgSpec) = parseCabalDotConfigLine l + in Map.insert pkgName pkgSpec pkgs + +-- | Parse a 'PkgName' and 'PkgSpec' from a line in a @cabal.config@ file. +-- +-- Assumes whitespace has already been stripped. +parseCabalDotConfigLine :: Text -> (PkgName, PkgSpec) +parseCabalDotConfigLine txt + | let (pkg, rest) + = Text.break isSpace + $ Text.dropAround (',' ==) -- drop commas + $ txt + , validPackageName pkg + = ( PkgName pkg, parsePkgSpec rest ) + | otherwise + = error $ "Invalid package in cabal.config file : " <> Text.unpack txt + where + +-- NB: update the readme after changing the documentation below. + +-- | Parse a seed file. Each line must either be: +-- +-- - A Cabal unit, in the format @unit +flag1 -flag2 >= 0.1 && < 0.3@. +-- +-- A unit can be of the form @pkgName@, @lib:pkgName@, @exe:pkgName@, +-- @pkgName:lib:compName@, ... as per Cabal component syntax. +-- +-- The unit name must be followed by a space. +-- +-- Flags and constraints are optional. +-- When both are present, flags must precede constraints. +-- Constraints must use valid Cabal constraint syntax. +-- +-- - An allow-newer specification, e.g. @allow-newer: pkg1:pkg2,*:base,...@. +-- This is not allowed to span multiple lines. +-- +-- Returns @(units, allowNewer)@. +parseSeedFile :: FilePath -> IO (UnitSpecs, AllowNewer) +parseSeedFile fp = do + ls <- filter ( not . isCommentLine ) + . map Text.strip + . Text.lines + <$> Text.readFile fp + return $ go Map.empty mempty ls + + where + go :: UnitSpecs -> AllowNewer -> [Text] -> (UnitSpecs, AllowNewer) + go units ans [] = (units, ans) + go units ans (l:ls) + | Just an <- Text.stripPrefix "allow-newer:" l + = go units (ans <> parseAllowNewer an) ls + | let (pkgTyComp, rest) = Text.break isSpace l + , Just (pkgName, comp) <- parsePkgComponent pkgTyComp + , let spec = parsePkgSpec rest + thisUnit = Map.singleton pkgName + (Remote, spec, Set.singleton comp) + -- we assume units in a seed file + -- don't refer to local packages + = go (units `unionUnitSpecsCombining` thisUnit) ans ls + | otherwise + = error $ "Invalid package in seed file : " <> Text.unpack l + +isCommentLine :: Text -> Bool +isCommentLine l + = Text.null l + || Text.isPrefixOf "--" l + +parseAllowNewer :: Text -> AllowNewer +parseAllowNewer l = + AllowNewer $ Set.fromList $ map parseOneAllowNewer (Text.splitOn "," l) + where + parseOneAllowNewer t + | (Text.strip -> a, Text.strip . Text.drop 1 -> b) <- Text.breakOn ":" t + , a == "*" || validPackageName a + , b == "*" || validPackageName b + = (a,b) + | otherwise + = error $ "Invalid allow-newer syntax in seed file: " <> Text.unpack t + diff --git a/src/BuildEnv/Script.hs b/src/BuildEnv/Script.hs new file mode 100644 --- /dev/null +++ b/src/BuildEnv/Script.hs @@ -0,0 +1,433 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | +-- Module : BuildEnv.Script +-- Description : Tiny build script DSL +-- +-- This modules provides a tiny build script DSL. +-- +-- A 'BuildScript' is a series of simple build steps (process calls). +-- +-- A 'BuildScript' can be executed in the 'IO' monad, using 'executeBuildScript'. +-- +-- A 'BuildScript' can be turned into a shell script which can be executed +-- later, using 'script'. +module BuildEnv.Script + ( -- * Interpreting build scripts + + -- ** Executing build scripts + executeBuildScript + + -- ** Shell-script output + , script + + -- * Build scripts + , BuildScript, BuildScriptM(..) + , emptyBuildScript, askScriptConfig + , buildSteps + + -- ** Individual build steps + , BuildStep(..), BuildSteps + , step + , callProcess, createDir, logMessage, reportProgress + + -- ** Configuring build scripts + , ScriptOutput(..), ScriptConfig(..), hostRunCfg + , quoteArg + + ) where + +-- base +import Control.Monad + ( when ) +import Data.Foldable + ( traverse_, foldl', for_ ) +import Data.IORef + ( atomicModifyIORef' ) +import Data.Monoid + ( Ap(..) ) +import Data.String + ( IsString(..) ) +import System.IO + ( hFlush ) +import qualified System.IO as System + ( stdout ) + +-- directory +import System.Directory + ( createDirectoryIfMissing ) + +-- filepath +import System.FilePath + ( (<.>) ) + +-- text +import Data.Text + ( Text ) +import qualified Data.Text as Text + +-- transformers +import Control.Monad.Trans.Reader + ( ReaderT(..) ) +import Control.Monad.Trans.Writer.CPS + ( Writer, execWriter, tell ) + +-- build-env +import BuildEnv.Config + ( Verbosity(..), Counter(..), Style(..) + , hostStyle + ) +import BuildEnv.Utils + ( ProgPath(..), CallProcess(..), callProcessInIO ) + +-------------------------------------------------------------------------------- +-- Build scripts: general monad setup. + +-- | A build script: a list of build steps, given a 'ScriptConfig' context. +type BuildScript = BuildScriptM () + +deriving via Ap BuildScriptM () + instance Semigroup BuildScript +deriving via Ap BuildScriptM () + instance Monoid BuildScript + +-- | Build script monad. +newtype BuildScriptM a = + BuildScript + { runBuildScript :: ReaderT ScriptConfig ( Writer BuildSteps ) a } + deriving newtype ( Functor, Applicative, Monad ) + +-- | The empty build script: no build steps. +emptyBuildScript :: BuildScript +emptyBuildScript = return () + +-- | Retrieve the 'ScriptConfig' from the 'ReaderT' environment. +askScriptConfig :: BuildScriptM ScriptConfig +askScriptConfig = BuildScript $ ReaderT return + +-- | Obtain the build steps of a 'BuildScript'. +buildSteps :: ScriptConfig -> BuildScript -> BuildSteps +buildSteps cfg buildScript + = execWriter (runBuildScript buildScript `runReaderT` cfg) + +-------------------------------------------------------------------------------- +-- Individual build steps + +-- | A list of build steps. +type BuildSteps = [BuildStep] + +-- | A build step. +data BuildStep + -- | Call a processs with the given arguments. + = CallProcess CallProcess + -- | Create the given directory. + | CreateDir FilePath + -- | Log a message to @stdout@. + | LogMessage String + -- | Report one unit of progress. + | ReportProgress + { outputProgress :: Bool + -- ^ Whether to log the progress to @stdout@. + } + +-- | Declare a build step. +step :: BuildStep -> BuildScript +step s = BuildScript $ ReaderT \ _ -> tell [s] + +-- | Call a process with given arguments. +callProcess :: CallProcess -> BuildScript +callProcess = step . CallProcess + +-- | Create the given directory. +createDir :: FilePath -> BuildScript +createDir = step . CreateDir + +-- | Log a message. +logMessage :: Verbosity -> Verbosity -> String -> BuildScript +logMessage v msg_v msg + | v >= msg_v + = step $ LogMessage msg + | otherwise + = return () + +-- | Report one unit of progress. +reportProgress :: Verbosity -> BuildScript +reportProgress v = step ( ReportProgress { outputProgress = v > Quiet } ) + +-------------------------------------------------------------------------------- +-- Configuration + +-- | How to interpret the build script: run it in 'IO', or turn it +-- into a shell script? +data ScriptOutput + -- | Run the build script in 'IO' + = Run + -- | Generate a shell script. + | Shell + { useVariables :: !Bool + -- ^ Replace various values with variables, so that + -- they can be set before running the build script. + -- + -- Values: + -- + -- - @GHC@ and @GHC-PKG@, + -- - fetched sources directory @SOURCES@, + -- - @PREFIX@ and @DESTDIR@. + } + +-- | Configuration options for a 'BuildScript'. +data ScriptConfig + = ScriptConfig + { scriptOutput :: !ScriptOutput + -- ^ Whether we are outputting a shell script, so that we can know whether + -- we should: + -- + -- - add quotes around command-line arguments? + -- - add @./@ to run an executable in the current working directory? + , scriptStyle :: !Style + -- ^ Whether to use Posix or Windows style conventions. See 'Style'. + + , scriptTotal :: !(Maybe Word) + -- ^ Optional: the total number of units we are building; + -- used to report progress. + } + +-- | Configure a script to run on the host (in @IO@). +hostRunCfg :: Maybe Word -- ^ Optional: total to report progress against. + -> ScriptConfig +hostRunCfg mbTotal = + ScriptConfig + { scriptOutput = Run + , scriptStyle = hostStyle + , scriptTotal = mbTotal } + +-- | Quote a string, to avoid spaces causing the string +-- to be interpreted as multiple arguments. +q :: ( IsString r, Monoid r ) => String -> r +q t = "\"" <> fromString (escapeArg t) <> "\"" + where + escapeArg :: String -> String + escapeArg = reverse . foldl' escape [] + + escape :: String -> Char -> String + escape cs c + | '\\' == c + || '\'' == c + || '"' == c + = c:'\\':cs + | otherwise + = c:cs + +-- | Quote a command-line argument, if the 'ScriptConfig' requires arguments +-- to be quoted. +-- +-- No need to call this on the 'cwd' or 'prog' fields of 'CallProcess', +-- as these will be quoted by the shell-script backend no matter what. +quoteArg :: ( IsString r, Monoid r ) => ScriptConfig -> String -> r +quoteArg ( ScriptConfig { scriptOutput } ) = + case scriptOutput of + Run -> fromString + Shell {} -> q + +-------------------------------------------------------------------------------- +-- Interpretation + +------ +-- IO + +-- | Execute a 'BuildScript' in the 'IO' monad. +executeBuildScript :: Maybe Counter -- ^ Optional counter to use to report progress. + -> BuildScript -- ^ The build script to execute. + -> IO () +executeBuildScript counter + = traverse_ ( executeBuildStep counter ) + . buildSteps ( hostRunCfg $ fmap counterMax counter ) + +-- | Execute a single 'BuildStep' in the 'IO' monad. +executeBuildStep :: Maybe Counter + -- ^ Optional counter to use to report progress. + -> BuildStep + -> IO () +executeBuildStep mbCounter = \case + CallProcess cp -> callProcessInIO mbCounter cp + CreateDir dir -> createDirectoryIfMissing True dir + LogMessage msg -> do { putStrLn msg ; hFlush System.stdout } + ReportProgress { outputProgress } -> + for_ mbCounter \ counter -> do + completed <- + atomicModifyIORef' ( counterRef counter ) + ( \ x -> let !x' = x+1 in (x',x') ) + when outputProgress do + let + txt = "## " <> show completed <> " of " <> show ( counterMax counter ) <> " ##" + n = length txt + putStrLn $ unlines + [ "" + , " " <> replicate n '#' + , " " <> txt + , " " <> replicate n '#' + , "" ] + +---------------- +-- Shell script + +-- | Obtain the textual contents of a build script. +script :: ScriptConfig -> BuildScript -> Text +script scriptCfg buildScript = + Text.unlines ( header ++ concatMap ( stepScript scriptCfg ) ( buildSteps scriptCfg buildScript ) ) + where + header, varsHelper, progressVars :: [ Text ] + header = [ "#!/bin/bash" , "" ] ++ varsHelper ++ logDir ++ progressVars + varsHelper + | Shell { useVariables } <- scriptOutput scriptCfg + , useVariables + = variablesHelper + | otherwise + = [] + progressVars = + case scriptTotal scriptCfg of + Nothing -> [] + Just {} -> + [ "buildEnvProgress=0" ] + logDir = [ "LOGDIR=\"$PWD/logs/$(date --utc +%Y-%m-%d_%H-%M-%S)\"" + , "mkdir -p \"${LOGDIR}\"" ] + +-- | The underlying script of a build step. +stepScript :: ScriptConfig -> BuildStep -> [ Text ] +stepScript scriptCfg = \case + CreateDir dir -> + [ "mkdir -p " <> q dir ] + LogMessage str -> + [ "echo " <> q str ] + ReportProgress { outputProgress } -> + case scriptTotal scriptCfg of + Nothing + -> [] + Just tot + | outputProgress + -> [ Text.pack $ "printf \"" <> txt <> "\" $((++buildEnvProgress))" ] + | otherwise + -> [ "((++buildEnvProgress))" ] + -- Still increment the progress variable, as we use this variable + -- to report progress upon failure. + where + n = length $ show tot + l = 2 * n + 10 + txt = "\\n " <> replicate l '#' <> "\\n " + <> "## %0" <> show n <> "d of " <> show tot <> " ##" <> "\\n " + <> replicate l '#' <> "\\n" + + CallProcess ( CP { cwd, extraPATH, extraEnvVars, prog, args, logBasePath } ) -> + -- NB: we ignore the semaphore, as the build scripts we produce + -- are inherently sequential. + logCommand ++ + [ "( cd " <> q cwd <> " ; \\" ] + ++ mbUpdatePath + ++ map mkEnvVar extraEnvVars + ++ + [ " " <> cmd <> pipeToLogs <> " )" + , resVar <> "=$?" + , "if [ \"${" <> resVar <> "}\" -eq 0 ]" + , "then true" + , "else" + , " echo -e " <> + "\"callProcess failed with non-zero exit code. Command:\\n" <> + " > " <> unquote cmd <> "\\n" <> + " CWD = " <> unquote (q cwd) <> "\"" + <> logErr + ] + ++ progressReport + ++ logMsg + ++ + [ " exit \"${" <> resVar <> "}\"" + , "fi" ] + where + cmd :: Text + cmd = q ( progPath prog ) <> " " <> Text.unwords (map Text.pack args) + -- (1) (2) + -- + -- (1) + -- In shell scripts, we always change directory before running the + -- program. As the program path is either absolute or relative to @cwd@, + -- we don't need to modify the program path. + -- + -- (2) + -- Don't quote the arguments: arguments which needed quoting will have + -- been quoted using the 'quoteArg' function. + -- + -- This allows users to pass multiple arguments using variables: + -- + -- > myArgs="arg1 arg2 arg3" + -- > Setup configure $myArgs + -- + -- by passing @$myArgs@ as a @Setup configure@ argument. + resVar :: Text + resVar = "buildEnvLastExitCode" + mbUpdatePath :: [Text] + mbUpdatePath + | null extraPATH + = [] + | otherwise + = [ " export PATH=$PATH:" + <> Text.intercalate ":" (map Text.pack extraPATH) -- (already quoted) + <> " ; \\" ] + + mkEnvVar :: (String, String) -> Text + mkEnvVar (var,val) = " export " + <> Text.pack var + <> "=" <> Text.pack val <> " ; \\" + -- (already quoted) + + logCommand, logMsg :: [Text] + pipeToLogs, logErr :: Text + (logCommand, pipeToLogs, logErr, logMsg) = + case logBasePath of + Nothing -> ( [], "", " >&2", [] ) + Just logPath -> + let stdoutFile, stderrFile :: Text + stdoutFile = q ( logPath <.> "stdout" ) + stderrFile = q ( logPath <.> "stderr" ) + in ( [ "echo \"> " <> unquote cmd <> "\" >> " <> stdoutFile ] + , " > " <> stdoutFile <> " 2> >( tee -a " <> stderrFile <> " >&2 )" + -- Write stdout to the stdout log file. + -- Write stderr both to the terminal and to the stderr log file. + , " | tee -a " <> stderrFile <> " >&2" + , [ " echo \"Logs are available at: " <> unquote ( q ( logPath <> ".{stdout,stderr}" ) ) <> "\"" ] ) + + progressReport :: [Text] + progressReport = + case scriptTotal scriptCfg of + Nothing -> [] + Just tot -> + [ " echo \"After ${buildEnvProgress} of " <> Text.pack (show tot) <> "\"" ] + +unquote :: Text -> Text +unquote = Text.filter ( not . (== '\"') ) + +---- +-- Helper to check that environment variables are set as expected. + +-- | All the environment variables that a shell script using variables +-- expects to be set. +allVars :: [ Text ] +allVars = [ "GHC", "GHCPKG", "SOURCES", "PREFIX", "DESTDIR" ] + +-- | A preamble that checks the required environment variables are defined. +variablesHelper :: [ Text ] +variablesHelper = + [ "", "echo \"Checking that required environment variables are set.\"" ] + ++ concatMap variableHelper allVars + ++ [ "" ] + +-- | Check that the given environment variable is defined, giving an error +-- message if it isn't (to avoid an error cascade). +variableHelper :: Text -> [ Text ] +variableHelper varName = + [ "if [ -z ${" <> varName <> "} ]" + , "then" + , " echo \"Environment variable " <> varName <> " not set.\"" + , " echo \"When using --variables, the build script expects the following environment variables to be set:\"" + , " echo \" " <> Text.intercalate ", " allVars <> ".\"" + , " exit 1" + , "fi" ] diff --git a/src/BuildEnv/Utils.hs b/src/BuildEnv/Utils.hs new file mode 100644 --- /dev/null +++ b/src/BuildEnv/Utils.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : BuildEnv.Utils +-- Description : Utilities for @build-env@ +-- +-- Various utilities: +-- +-- - Spawning of processes in particular environments; see 'callProcessInIO'. +-- - Semaphores. +-- +module BuildEnv.Utils + ( -- * Call a process in a given environment + ProgPath(..), CallProcess(..), callProcessInIO + + -- * Create temporary directories + , TempDirPermanence(..), withTempDir + + -- * Abstract semaphores + , AbstractSem(..) + , newAbstractSem, noSem, abstractQSem + + -- * Other utilities + , splitOn + + ) where + +-- base +import Control.Concurrent.QSem + ( QSem, newQSem, signalQSem, waitQSem ) +import Control.Exception + ( bracket_ ) +import Data.List + ( intercalate ) +import Data.Maybe + ( fromMaybe ) +import Data.IORef + ( readIORef ) +import System.Environment + ( getEnvironment ) +import System.Exit + ( ExitCode(..), exitWith ) +import System.IO + ( IOMode(..), hPutStrLn, withFile ) +import qualified System.IO as System.Handle + ( stderr ) +import GHC.IO.Handle + ( hDuplicateTo ) +import GHC.Stack + ( HasCallStack ) + +-- containers +import Data.Map.Strict + ( Map ) +import qualified Data.Map.Strict as Map + ( alter, fromList, toList ) + +-- directory +import System.Directory + ( createDirectoryIfMissing, makeAbsolute ) + +-- filepath +import System.FilePath + ( (), (<.>), takeDirectory ) + +-- process +import qualified System.Process as Proc + +-- temporary +import System.IO.Temp + ( createTempDirectory + , getCanonicalTemporaryDirectory + , withSystemTempDirectory + ) + +-- build-env +import BuildEnv.Config + ( AsyncSem(..), Args, TempDirPermanence(..), Counter(..) + , pATHSeparator, hostStyle + ) + +-------------------------------------------------------------------------------- + +-- | The path of a program to run. +data ProgPath + -- | An absolute path, or an executable in @PATH@. + = AbsPath { progPath :: !FilePath } + -- | A relative path. What it is relative to depends on context. + | RelPath { progPath :: !FilePath } + +-- | Arguments to 'callProcess'. +data CallProcess + = CP + { cwd :: !FilePath + -- ^ Working directory. + , extraPATH :: ![FilePath] + -- ^ Absolute filepaths to add to PATH. + , extraEnvVars :: ![(String, String)] + -- ^ Extra envi!ronment variables to add before running the command. + , prog :: !ProgPath + -- ^ The program to run. + -- + -- If it's a relative path, it should be relative to the @cwd@ field. + , args :: !Args + -- ^ Arguments to the program. + , logBasePath :: !( Maybe FilePath ) + -- ^ Log @stdout@ to @basePath.stdout@ and @stderr@ to @basePath.stderr@. + , sem :: !AbstractSem + -- ^ Lock to take when calling the process + -- and waiting for it to return, to avoid + -- contention in concurrent situations. + } + +-- | Run a command and wait for it to complete. +-- +-- Crashes if the process returns with non-zero exit code. +-- +-- See 'CallProcess' for a description of the options. +callProcessInIO :: HasCallStack + => Maybe Counter + -- ^ Optional counter. Used when the command fails, + -- to report the progress that has been made so far. + -> CallProcess + -> IO () +callProcessInIO mbCounter ( CP { cwd, extraPATH, extraEnvVars, prog, args, logBasePath, sem } ) = do + absProg <- + case prog of + AbsPath p -> return p + RelPath p -> makeAbsolute $ cwd p + -- Needs to be an absolute path, as per the @process@ documentation: + -- + -- If cwd is provided, it is implementation-dependent whether + -- relative paths are resolved with respect to cwd or the current + -- working directory, so absolute paths should be used + -- to ensure portability. + -- + -- We always want the program to be interpreted relative to the cwd + -- argument, so we prepend @cwd@ and then make it absolute. + let argsStr + | null args = "" + | otherwise = " " ++ unwords args + command = + [ " > " ++ absProg ++ argsStr + , " CWD = " ++ cwd ] + env <- + if null extraPATH && null extraEnvVars + then return Nothing + else do env0 <- getEnvironment + let env1 = Map.fromList $ env0 ++ extraEnvVars + env2 = Map.toList $ augmentSearchPath "PATH" extraPATH env1 + return $ Just env2 + let withHandles :: ( ( Proc.StdStream, Proc.StdStream ) -> IO () ) -> IO () + withHandles action = case logBasePath of + Nothing -> action ( Proc.Inherit, Proc.Inherit ) + Just logPath -> do + let stdoutFile = logPath <.> "stdout" + stderrFile = logPath <.> "stderr" + createDirectoryIfMissing True $ takeDirectory logPath + withFile stdoutFile AppendMode \ stdoutFileHandle -> + withFile stderrFile AppendMode \ stderrFileHandle -> do + hDuplicateTo System.Handle.stderr stderrFileHandle + -- Write stderr to the log file and to the terminal. + hPutStrLn stdoutFileHandle ( unlines command ) + action ( Proc.UseHandle stdoutFileHandle, Proc.UseHandle stderrFileHandle ) + withHandles \ ( stdoutStream, stderrStream ) -> do + let processArgs = + ( Proc.proc absProg args ) + { Proc.cwd = if cwd == "." then Nothing else Just cwd + , Proc.env = env + , Proc.std_out = stdoutStream + , Proc.std_err = stderrStream } + res <- withAbstractSem sem do + (_, _, _, ph) <- Proc.createProcess_ "createProcess" processArgs + -- Use 'createProcess_' to avoid closing handles prematurely. + Proc.waitForProcess ph + case res of + ExitSuccess -> return () + ExitFailure i -> do + progressReport <- + case mbCounter of + Nothing -> return [] + Just ( Counter { counterRef, counterMax } ) -> do + progress <- readIORef counterRef + return $ [ "After " <> show progress <> " of " <> show counterMax ] + let msg = [ "callProcess failed with non-zero exit code " ++ show i ++ ". Command:" ] + ++ command ++ progressReport + case stderrStream of + Proc.UseHandle errHandle -> + hPutStrLn errHandle + ( unlines $ msg ++ [ "Logs are available at: " <> fromMaybe "" logBasePath <> ".{stdout, stderr}" ] ) + _ -> putStrLn (unlines msg) + exitWith res + +-- | Add filepaths to the given key in a key/value environment. +augmentSearchPath :: Ord k => k -> [FilePath] -> Map k String -> Map k String +augmentSearchPath _ [] = id +augmentSearchPath var paths = Map.alter f var + where + pathsVal = intercalate (pATHSeparator hostStyle) paths + f Nothing = Just pathsVal + f (Just p) = Just (p <> (pATHSeparator hostStyle) <> pathsVal) + +-- | Perform an action with a fresh temporary directory. +withTempDir :: TempDirPermanence -- ^ whether to delete the temporary directory + -- after the action completes + -> String -- ^ directory name template + -> (FilePath -> IO a) -- ^ action to perform + -> IO a +withTempDir del name k = + case del of + DeleteTempDirs + -> withSystemTempDirectory name k + Don'tDeleteTempDirs + -> do root <- getCanonicalTemporaryDirectory + createTempDirectory root name >>= k + +-- | Utility list 'splitOn' function. +splitOn :: Char -> String -> [String] +splitOn c = go + where + go "" = [] + go s + | (a,as) <- break (== c) s + = a : go (drop 1 as) + +-------------------------------------------------------------------------------- +-- Semaphores. + +-- | Abstract acquire/release mechanism. +newtype AbstractSem = + AbstractSem { withAbstractSem :: forall r. IO r -> IO r } + +-- | Create a semaphore-based acquire/release mechanism. +newAbstractSem :: AsyncSem -> IO AbstractSem +newAbstractSem whatSem = + case whatSem of + NoSem -> return noSem + NewQSem n -> do + qsem <- newQSem ( fromIntegral n ) + return $ abstractQSem qsem + +-- | Abstract acquire/release mechanism controlled by the given 'QSem'. +abstractQSem :: QSem -> AbstractSem +abstractQSem sem = + AbstractSem $ bracket_ (waitQSem sem) (signalQSem sem) + +-- | No acquire/release mechanism required. +noSem :: AbstractSem +noSem = AbstractSem { withAbstractSem = id }