stack-2.9.3: src/Stack/Build/Execute.hs
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
-- | Perform a build
module Stack.Build.Execute
( printPlan
, preFetch
, executePlan
-- * Running Setup.hs
, ExecuteEnv
, withExecuteEnv
, withSingleContext
, ExcludeTHLoading (..)
, KeepOutputOpen (..)
) where
import Control.Concurrent.Execute
import Control.Concurrent.STM ( check )
import Crypto.Hash
import Data.Attoparsec.Text ( char, choice, digit, parseOnly )
import qualified Data.Attoparsec.Text as P ( string )
import qualified Data.ByteArray as Mem ( convert )
import qualified Data.ByteString as S
import qualified Data.ByteString.Builder
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Base64.URL as B64URL
import Data.Char ( isSpace )
import Conduit
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.Filesystem as CF
import qualified Data.Conduit.List as CL
import Data.Conduit.Process.Typed ( createSource )
import qualified Data.Conduit.Text as CT
import qualified Data.List as L
import Data.List.NonEmpty ( nonEmpty )
import qualified Data.List.NonEmpty as NonEmpty ( toList )
import Data.List.Split ( chunksOf )
import qualified Data.Map.Strict as M
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Text.Encoding ( decodeUtf8 )
import Data.Tuple
import Data.Time
( ZonedTime, getZonedTime, formatTime, defaultTimeLocale )
import qualified Data.ByteString.Char8 as S8
import qualified Distribution.PackageDescription as C
import qualified Distribution.Simple.Build.Macros as C
import Distribution.System ( OS (Windows), Platform (Platform) )
import qualified Distribution.Text as C
import Distribution.Types.PackageName ( mkPackageName )
import Distribution.Types.UnqualComponentName
( mkUnqualComponentName )
import Distribution.Verbosity ( showForCabal )
import Distribution.Version ( mkVersion )
import Pantry.Internal.Companion
import Path
import Path.CheckInstall
import Path.Extra ( toFilePathNoTrailingSep, rejectMissingFile )
import Path.IO
hiding ( findExecutable, makeAbsolute, withSystemTempDir )
import RIO.Process
import Stack.Build.Cache
import Stack.Build.Haddock
import Stack.Build.Installed
import Stack.Build.Source
import Stack.Build.Target
import Stack.Config
import Stack.Constants
import Stack.Constants.Config
import Stack.Coverage
import Stack.DefaultColorWhen ( defaultColorWhen )
import Stack.GhcPkg
import Stack.Package
import Stack.PackageDump
import Stack.Prelude
import Stack.Types.Build
import Stack.Types.Compiler
import Stack.Types.Config
import Stack.Types.GhcPkgId
import Stack.Types.NamedComponent
import Stack.Types.Package
import Stack.Types.PackageFile
import Stack.Types.Version
import qualified System.Directory as D
import System.Environment ( getExecutablePath, lookupEnv )
import System.FileLock
( withTryFileLock, SharedExclusive (Exclusive)
, withFileLock
)
import qualified System.FilePath as FP
import System.IO.Error ( isDoesNotExistError )
import System.PosixCompat.Files
( createLink, modificationTime, getFileStatus )
import System.Random ( randomIO )
-- | Has an executable been built or not?
data ExecutableBuildStatus
= ExecutableBuilt
| ExecutableNotBuilt
deriving (Show, Eq, Ord)
-- | Fetch the packages necessary for a build, for example in combination with a dry run.
preFetch :: HasEnvConfig env => Plan -> RIO env ()
preFetch plan
| Set.null pkgLocs = logDebug "Nothing to fetch"
| otherwise = do
logDebug $
"Prefetching: " <>
mconcat (L.intersperse ", " (display <$> Set.toList pkgLocs))
fetchPackages pkgLocs
where
pkgLocs = Set.unions $ map toPkgLoc $ Map.elems $ planTasks plan
toPkgLoc task =
case taskType task of
TTLocalMutable{} -> Set.empty
TTRemotePackage _ _ pkgloc -> Set.singleton pkgloc
-- | Print a description of build plan for human consumption.
printPlan :: HasRunner env => Plan -> RIO env ()
printPlan plan = do
case Map.elems $ planUnregisterLocal plan of
[] -> logInfo "No packages would be unregistered."
xs -> do
logInfo "Would unregister locally:"
forM_ xs $ \(ident, reason) -> logInfo $
fromString (packageIdentifierString ident) <>
if T.null reason
then ""
else " (" <> display reason <> ")"
logInfo ""
case Map.elems $ planTasks plan of
[] -> logInfo "Nothing to build."
xs -> do
logInfo "Would build:"
mapM_ (logInfo . displayTask) xs
let hasTests = not . Set.null . testComponents . taskComponents
hasBenches = not . Set.null . benchComponents . taskComponents
tests = Map.elems $ Map.filter hasTests $ planFinals plan
benches = Map.elems $ Map.filter hasBenches $ planFinals plan
unless (null tests) $ do
logInfo ""
logInfo "Would test:"
mapM_ (logInfo . displayTask) tests
unless (null benches) $ do
logInfo ""
logInfo "Would benchmark:"
mapM_ (logInfo . displayTask) benches
logInfo ""
case Map.toList $ planInstallExes plan of
[] -> logInfo "No executables to be installed."
xs -> do
logInfo "Would install executables:"
forM_ xs $ \(name, loc) -> logInfo $
display name <>
" from " <>
(case loc of
Snap -> "snapshot"
Local -> "local") <>
" database"
-- | For a dry run
displayTask :: Task -> Utf8Builder
displayTask task =
fromString (packageIdentifierString (taskProvides task)) <>
": database=" <>
(case taskLocation task of
Snap -> "snapshot"
Local -> "local") <>
", source=" <>
(case taskType task of
TTLocalMutable lp -> fromString $ toFilePath $ parent $ lpCabalFile lp
TTRemotePackage _ _ pl -> display pl) <>
(if Set.null missing
then ""
else ", after: " <>
mconcat (L.intersperse "," (fromString . packageIdentifierString <$> Set.toList missing)))
where
missing = tcoMissing $ taskConfigOpts task
data ExecuteEnv = ExecuteEnv
{ eeConfigureLock :: !(MVar ())
, eeInstallLock :: !(MVar ())
, eeBuildOpts :: !BuildOpts
, eeBuildOptsCLI :: !BuildOptsCLI
, eeBaseConfigOpts :: !BaseConfigOpts
, eeGhcPkgIds :: !(TVar (Map PackageIdentifier Installed))
, eeTempDir :: !(Path Abs Dir)
, eeSetupHs :: !(Path Abs File)
-- ^ Temporary Setup.hs for simple builds
, eeSetupShimHs :: !(Path Abs File)
-- ^ Temporary SetupShim.hs, to provide access to initial-build-steps
, eeSetupExe :: !(Maybe (Path Abs File))
-- ^ Compiled version of eeSetupHs
, eeCabalPkgVer :: !Version
, eeTotalWanted :: !Int
, eeLocals :: ![LocalPackage]
, eeGlobalDB :: !(Path Abs Dir)
, eeGlobalDumpPkgs :: !(Map GhcPkgId DumpPackage)
, eeSnapshotDumpPkgs :: !(TVar (Map GhcPkgId DumpPackage))
, eeLocalDumpPkgs :: !(TVar (Map GhcPkgId DumpPackage))
, eeLogFiles :: !(TChan (Path Abs Dir, Path Abs File))
, eeCustomBuilt :: !(IORef (Set PackageName))
-- ^ Stores which packages with custom-setup have already had their
-- Setup.hs built.
, eeLargestPackageName :: !(Maybe Int)
-- ^ For nicer interleaved output: track the largest package name size
, eePathEnvVar :: !Text
-- ^ Value of the PATH environment variable
}
buildSetupArgs :: [String]
buildSetupArgs =
[ "-rtsopts"
, "-threaded"
, "-clear-package-db"
, "-global-package-db"
, "-hide-all-packages"
, "-package"
, "base"
, "-main-is"
, "StackSetupShim.mainOverride"
]
simpleSetupCode :: Builder
simpleSetupCode = "import Distribution.Simple\nmain = defaultMain"
simpleSetupHash :: String
simpleSetupHash =
T.unpack $ decodeUtf8 $ S.take 8 $ B64URL.encode $ Mem.convert $ hashWith SHA256 $
toStrictBytes $
Data.ByteString.Builder.toLazyByteString $
encodeUtf8Builder (T.pack (unwords buildSetupArgs)) <> setupGhciShimCode <> simpleSetupCode
-- | Get a compiled Setup exe
getSetupExe :: HasEnvConfig env
=> Path Abs File -- ^ Setup.hs input file
-> Path Abs File -- ^ SetupShim.hs input file
-> Path Abs Dir -- ^ temporary directory
-> RIO env (Maybe (Path Abs File))
getSetupExe setupHs setupShimHs tmpdir = do
wc <- view $ actualCompilerVersionL.whichCompilerL
platformDir <- platformGhcRelDir
config <- view configL
cabalVersionString <- view $ cabalVersionL.to versionString
actualCompilerVersionString <- view $ actualCompilerVersionL.to compilerVersionString
platform <- view platformL
let baseNameS = concat
[ "Cabal-simple_"
, simpleSetupHash
, "_"
, cabalVersionString
, "_"
, actualCompilerVersionString
]
exeNameS = baseNameS ++
case platform of
Platform _ Windows -> ".exe"
_ -> ""
outputNameS =
case wc of
Ghc -> exeNameS
setupDir =
view stackRootL config </>
relDirSetupExeCache </>
platformDir
exePath <- (setupDir </>) <$> parseRelFile exeNameS
exists <- liftIO $ D.doesFileExist $ toFilePath exePath
if exists
then pure $ Just exePath
else do
tmpExePath <- fmap (setupDir </>) $ parseRelFile $ "tmp-" ++ exeNameS
tmpOutputPath <- fmap (setupDir </>) $ parseRelFile $ "tmp-" ++ outputNameS
ensureDir setupDir
let args = buildSetupArgs ++
[ "-package"
, "Cabal-" ++ cabalVersionString
, toFilePath setupHs
, toFilePath setupShimHs
, "-o"
, toFilePath tmpOutputPath
]
compilerPath <- getCompilerPath
withWorkingDir (toFilePath tmpdir) $ proc (toFilePath compilerPath) args (\pc0 -> do
let pc = setStdout (useHandleOpen stderr) pc0
runProcess_ pc)
`catch` \ece ->
throwM $ PrettyException $
SetupHsBuildFailure
(eceExitCode ece)
Nothing
compilerPath
args
Nothing
[]
renameFile tmpExePath exePath
pure $ Just exePath
-- | Execute a function that takes an 'ExecuteEnv'.
withExecuteEnv :: forall env a. HasEnvConfig env
=> BuildOpts
-> BuildOptsCLI
-> BaseConfigOpts
-> [LocalPackage]
-> [DumpPackage] -- ^ global packages
-> [DumpPackage] -- ^ snapshot packages
-> [DumpPackage] -- ^ local packages
-> Maybe Int -- ^ largest package name, for nicer interleaved output
-> (ExecuteEnv -> RIO env a)
-> RIO env a
withExecuteEnv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages mlargestPackageName inner =
createTempDirFunction stackProgName $ \tmpdir -> do
configLock <- liftIO $ newMVar ()
installLock <- liftIO $ newMVar ()
idMap <- liftIO $ newTVarIO Map.empty
config <- view configL
customBuiltRef <- newIORef Set.empty
-- Create files for simple setup and setup shim, if necessary
let setupSrcDir =
view stackRootL config </>
relDirSetupExeSrc
ensureDir setupSrcDir
setupFileName <- parseRelFile ("setup-" ++ simpleSetupHash ++ ".hs")
let setupHs = setupSrcDir </> setupFileName
setupHsExists <- doesFileExist setupHs
unless setupHsExists $ writeBinaryFileAtomic setupHs simpleSetupCode
setupShimFileName <- parseRelFile ("setup-shim-" ++ simpleSetupHash ++ ".hs")
let setupShimHs = setupSrcDir </> setupShimFileName
setupShimHsExists <- doesFileExist setupShimHs
unless setupShimHsExists $ writeBinaryFileAtomic setupShimHs setupGhciShimCode
setupExe <- getSetupExe setupHs setupShimHs tmpdir
cabalPkgVer <- view cabalVersionL
globalDB <- view $ compilerPathsL.to cpGlobalDB
snapshotPackagesTVar <- liftIO $ newTVarIO (toDumpPackagesByGhcPkgId snapshotPackages)
localPackagesTVar <- liftIO $ newTVarIO (toDumpPackagesByGhcPkgId localPackages)
logFilesTChan <- liftIO $ atomically newTChan
let totalWanted = length $ filter lpWanted locals
pathEnvVar <- liftIO $ maybe mempty T.pack <$> lookupEnv "PATH"
inner ExecuteEnv
{ eeBuildOpts = bopts
, eeBuildOptsCLI = boptsCli
-- Uncertain as to why we cannot run configures in parallel. This
-- appears to be a Cabal library bug. Original issue:
-- https://github.com/commercialhaskell/stack/issues/84. Ideally
-- we'd be able to remove this.
, eeConfigureLock = configLock
, eeInstallLock = installLock
, eeBaseConfigOpts = baseConfigOpts
, eeGhcPkgIds = idMap
, eeTempDir = tmpdir
, eeSetupHs = setupHs
, eeSetupShimHs = setupShimHs
, eeSetupExe = setupExe
, eeCabalPkgVer = cabalPkgVer
, eeTotalWanted = totalWanted
, eeLocals = locals
, eeGlobalDB = globalDB
, eeGlobalDumpPkgs = toDumpPackagesByGhcPkgId globalPackages
, eeSnapshotDumpPkgs = snapshotPackagesTVar
, eeLocalDumpPkgs = localPackagesTVar
, eeLogFiles = logFilesTChan
, eeCustomBuilt = customBuiltRef
, eeLargestPackageName = mlargestPackageName
, eePathEnvVar = pathEnvVar
} `finally` dumpLogs logFilesTChan totalWanted
where
toDumpPackagesByGhcPkgId = Map.fromList . map (\dp -> (dpGhcPkgId dp, dp))
createTempDirFunction
| boptsKeepTmpFiles bopts = withKeepSystemTempDir
| otherwise = withSystemTempDir
dumpLogs :: TChan (Path Abs Dir, Path Abs File) -> Int -> RIO env ()
dumpLogs chan totalWanted = do
allLogs <- fmap reverse $ liftIO $ atomically drainChan
case allLogs of
-- No log files generated, nothing to dump
[] -> pure ()
firstLog:_ -> do
toDump <- view $ configL.to configDumpLogs
case toDump of
DumpAllLogs -> mapM_ (dumpLog "") allLogs
DumpWarningLogs -> mapM_ dumpLogIfWarning allLogs
DumpNoLogs
| totalWanted > 1 ->
logInfo $
"Build output has been captured to log files, use " <>
"--dump-logs to see it on the console"
| otherwise -> pure ()
logInfo $ "Log files have been written to: " <>
fromString (toFilePath (parent (snd firstLog)))
-- We only strip the colors /after/ we've dumped logs, so that
-- we get pretty colors in our dump output on the terminal.
colors <- shouldForceGhcColorFlag
when colors $ liftIO $ mapM_ (stripColors . snd) allLogs
where
drainChan :: STM [(Path Abs Dir, Path Abs File)]
drainChan = do
mx <- tryReadTChan chan
case mx of
Nothing -> pure []
Just x -> do
xs <- drainChan
pure $ x:xs
dumpLogIfWarning :: (Path Abs Dir, Path Abs File) -> RIO env ()
dumpLogIfWarning (pkgDir, filepath) = do
firstWarning <- withSourceFile (toFilePath filepath) $ \src ->
runConduit
$ src
.| CT.decodeUtf8Lenient
.| CT.lines
.| CL.map stripCR
.| CL.filter isWarning
.| CL.take 1
unless (null firstWarning) $ dumpLog " due to warnings" (pkgDir, filepath)
isWarning :: Text -> Bool
isWarning t = ": Warning:" `T.isSuffixOf` t -- prior to GHC 8
|| ": warning:" `T.isInfixOf` t -- GHC 8 is slightly different
|| "mwarning:" `T.isInfixOf` t -- colorized output
dumpLog :: String -> (Path Abs Dir, Path Abs File) -> RIO env ()
dumpLog msgSuffix (pkgDir, filepath) = do
logInfo $
"\n-- Dumping log file" <>
fromString msgSuffix <>
": " <>
fromString (toFilePath filepath) <>
"\n"
compilerVer <- view actualCompilerVersionL
withSourceFile (toFilePath filepath) $ \src ->
runConduit
$ src
.| CT.decodeUtf8Lenient
.| mungeBuildOutput ExcludeTHLoading ConvertPathsToAbsolute pkgDir compilerVer
.| CL.mapM_ (logInfo . display)
logInfo $ "\n-- End of log file: " <> fromString (toFilePath filepath) <> "\n"
stripColors :: Path Abs File -> IO ()
stripColors fp = do
let colorfp = toFilePath fp ++ "-color"
withSourceFile (toFilePath fp) $ \src ->
withSinkFile colorfp $ \sink ->
runConduit $ src .| sink
withSourceFile colorfp $ \src ->
withSinkFile (toFilePath fp) $ \sink ->
runConduit $ src .| noColors .| sink
where
noColors = do
CB.takeWhile (/= 27) -- ESC
mnext <- CB.head
case mnext of
Nothing -> pure ()
Just x -> assert (x == 27) $ do
-- Color sequences always end with an m
CB.dropWhile (/= 109) -- m
CB.drop 1 -- drop the m itself
noColors
-- | Perform the actual plan
executePlan :: HasEnvConfig env
=> BuildOptsCLI
-> BaseConfigOpts
-> [LocalPackage]
-> [DumpPackage] -- ^ global packages
-> [DumpPackage] -- ^ snapshot packages
-> [DumpPackage] -- ^ local packages
-> InstalledMap
-> Map PackageName Target
-> Plan
-> RIO env ()
executePlan boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages installedMap targets plan = do
logDebug "Executing the build plan"
bopts <- view buildOptsL
withExecuteEnv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages mlargestPackageName
(executePlan' installedMap targets plan)
copyExecutables (planInstallExes plan)
config <- view configL
menv' <- liftIO $ configProcessContextSettings config EnvSettings
{ esIncludeLocals = True
, esIncludeGhcPackagePath = True
, esStackExe = True
, esLocaleUtf8 = False
, esKeepGhcRts = False
}
withProcessContext menv' $
forM_ (boptsCLIExec boptsCli) $ \(cmd, args) ->
proc cmd args runProcess_
where
mlargestPackageName =
Set.lookupMax $
Set.map (length . packageNameString) $
Map.keysSet (planTasks plan) <> Map.keysSet (planFinals plan)
copyExecutables ::
HasEnvConfig env
=> Map Text InstallLocation
-> RIO env ()
copyExecutables exes | Map.null exes = pure ()
copyExecutables exes = do
snapBin <- (</> bindirSuffix) `liftM` installationRootDeps
localBin <- (</> bindirSuffix) `liftM` installationRootLocal
compilerSpecific <- boptsInstallCompilerTool <$> view buildOptsL
destDir <- if compilerSpecific
then bindirCompilerTools
else view $ configL.to configLocalBin
ensureDir destDir
destDir' <- liftIO . D.canonicalizePath . toFilePath $ destDir
platform <- view platformL
let ext =
case platform of
Platform _ Windows -> ".exe"
_ -> ""
currExe <- liftIO getExecutablePath -- needed for windows, see below
installed <- forMaybeM (Map.toList exes) $ \(name, loc) -> do
let bindir =
case loc of
Snap -> snapBin
Local -> localBin
mfp <- liftIO $ forgivingAbsence (resolveFile bindir $ T.unpack name ++ ext)
>>= rejectMissingFile
case mfp of
Nothing -> do
logWarn $
"Couldn't find executable " <>
display name <>
" in directory " <>
fromString (toFilePath bindir)
pure Nothing
Just file -> do
let destFile = destDir' FP.</> T.unpack name ++ ext
logInfo $
"Copying from " <>
fromString (toFilePath file) <>
" to " <>
fromString destFile
liftIO $ case platform of
Platform _ Windows | FP.equalFilePath destFile currExe ->
windowsRenameCopy (toFilePath file) destFile
_ -> D.copyFile (toFilePath file) destFile
pure $ Just (name <> T.pack ext)
unless (null installed) $ do
logInfo ""
logInfo $
"Copied executables to " <>
fromString destDir' <>
":"
forM_ installed $ \exe -> logInfo ("- " <> display exe)
unless compilerSpecific $ warnInstallSearchPathIssues destDir' installed
-- | Windows can't write over the current executable. Instead, we rename the
-- current executable to something else and then do the copy.
windowsRenameCopy :: FilePath -> FilePath -> IO ()
windowsRenameCopy src dest = do
D.copyFile src new
D.renameFile dest old
D.renameFile new dest
where
new = dest ++ ".new"
old = dest ++ ".old"
-- | Perform the actual plan (internal)
executePlan' :: HasEnvConfig env
=> InstalledMap
-> Map PackageName Target
-> Plan
-> ExecuteEnv
-> RIO env ()
executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do
when (toCoverage $ boptsTestOpts eeBuildOpts) deleteHpcReports
cv <- view actualCompilerVersionL
case nonEmpty . Map.toList $ planUnregisterLocal plan of
Nothing -> pure ()
Just ids -> do
localDB <- packageDatabaseLocal
unregisterPackages cv localDB ids
liftIO $ atomically $ modifyTVar' eeLocalDumpPkgs $ \initMap ->
foldl' (flip Map.delete) initMap $ Map.keys (planUnregisterLocal plan)
run <- askRunInIO
-- If running tests concurrently with each other, then create an MVar
-- which is empty while each test is being run.
concurrentTests <- view $ configL.to configConcurrentTests
mtestLock <- if concurrentTests then pure Nothing else Just <$> liftIO (newMVar ())
let actions = concatMap (toActions installedMap' mtestLock run ee) $ Map.elems $ Map.mergeWithKey
(\_ b f -> Just (Just b, Just f))
(fmap (\b -> (Just b, Nothing)))
(fmap (\f -> (Nothing, Just f)))
(planTasks plan)
(planFinals plan)
threads <- view $ configL.to configJobs
let keepGoing =
fromMaybe (not (M.null (planFinals plan))) (boptsKeepGoing eeBuildOpts)
terminal <- view terminalL
errs <- liftIO $ runActions threads keepGoing actions $ \doneVar actionsVar -> do
let total = length actions
loop prev
| prev == total =
run $ logStickyDone ("Completed " <> display total <> " action(s).")
| otherwise = do
inProgress <- readTVarIO actionsVar
let packageNames = map (\(ActionId pkgID _) -> pkgName pkgID) (toList inProgress)
nowBuilding :: [PackageName] -> Utf8Builder
nowBuilding [] = ""
nowBuilding names = mconcat $ ": " : L.intersperse ", " (map (fromString . packageNameString) names)
when terminal $ run $
logSticky $
"Progress " <> display prev <> "/" <> display total <>
nowBuilding packageNames
done <- atomically $ do
done <- readTVar doneVar
check $ done /= prev
pure done
loop done
when (total > 1) $ loop 0
when (toCoverage $ boptsTestOpts eeBuildOpts) $ do
generateHpcUnifiedReport
generateHpcMarkupIndex
unless (null errs) $ throwM $ PrettyException (ExecutionFailure errs)
when (boptsHaddock eeBuildOpts) $ do
snapshotDumpPkgs <- liftIO (readTVarIO eeSnapshotDumpPkgs)
localDumpPkgs <- liftIO (readTVarIO eeLocalDumpPkgs)
generateLocalHaddockIndex eeBaseConfigOpts localDumpPkgs eeLocals
generateDepsHaddockIndex eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs localDumpPkgs eeLocals
generateSnapHaddockIndex eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs
when (boptsOpenHaddocks eeBuildOpts) $ do
let planPkgs, localPkgs, installedPkgs, availablePkgs
:: Map PackageName (PackageIdentifier, InstallLocation)
planPkgs = Map.map (taskProvides &&& taskLocation) (planTasks plan)
localPkgs =
Map.fromList
[(packageName p, (packageIdentifier p, Local)) | p <- map lpPackage eeLocals]
installedPkgs = Map.map (swap . second installedPackageIdentifier) installedMap'
availablePkgs = Map.unions [planPkgs, localPkgs, installedPkgs]
openHaddocksInBrowser eeBaseConfigOpts availablePkgs (Map.keysSet targets)
where
installedMap' = Map.difference installedMap0
$ Map.fromList
$ map (\(ident, _) -> (pkgName ident, ()))
$ Map.elems
$ planUnregisterLocal plan
unregisterPackages ::
(HasProcessContext env, HasLogFunc env, HasPlatform env, HasCompiler env)
=> ActualCompiler
-> Path Abs Dir
-> NonEmpty (GhcPkgId, (PackageIdentifier, Text))
-> RIO env ()
unregisterPackages cv localDB ids = do
let logReason ident reason =
logInfo $
fromString (packageIdentifierString ident) <> ": unregistering" <>
if T.null reason
then ""
else " (" <> display reason <> ")"
let unregisterSinglePkg select (gid, (ident, reason)) = do
logReason ident reason
pkg <- getGhcPkgExe
unregisterGhcPkgIds pkg localDB $ select ident gid :| []
case cv of
-- GHC versions >= 8.2.1 support batch unregistering of packages. See
-- https://gitlab.haskell.org/ghc/ghc/issues/12637
ACGhc v | v >= mkVersion [8, 2, 1] -> do
platform <- view platformL
-- According to https://support.microsoft.com/en-us/help/830473/command-prompt-cmd-exe-command-line-string-limitation
-- the maximum command line length on Windows since XP is 8191 characters.
-- We use conservative batch size of 100 ids on this OS thus argument name '-ipid', package name,
-- its version and a hash should fit well into this limit.
-- On Unix-like systems we're limited by ARG_MAX which is normally hundreds
-- of kilobytes so batch size of 500 should work fine.
let batchSize = case platform of
Platform _ Windows -> 100
_ -> 500
let chunksOfNE size = mapMaybe nonEmpty . chunksOf size . NonEmpty.toList
for_ (chunksOfNE batchSize ids) $ \batch -> do
for_ batch $ \(_, (ident, reason)) -> logReason ident reason
pkg <- getGhcPkgExe
unregisterGhcPkgIds pkg localDB $ fmap (Right . fst) batch
-- GHC versions >= 7.9 support unregistering of packages via their
-- GhcPkgId.
ACGhc v | v >= mkVersion [7, 9] -> for_ ids . unregisterSinglePkg $ \_ident gid -> Right gid
_ -> for_ ids . unregisterSinglePkg $ \ident _gid -> Left ident
toActions :: HasEnvConfig env
=> InstalledMap
-> Maybe (MVar ())
-> (RIO env () -> IO ())
-> ExecuteEnv
-> (Maybe Task, Maybe Task) -- build and final
-> [Action]
toActions installedMap mtestLock runInBase ee (mbuild, mfinal) =
abuild ++ afinal
where
abuild =
case mbuild of
Nothing -> []
Just task@Task {..} ->
[ Action
{ actionId = ActionId taskProvides ATBuild
, actionDeps =
Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts)
, actionDo = \ac -> runInBase $ singleBuild ac ee task installedMap False
, actionConcurrency = ConcurrencyAllowed
}
]
afinal =
case mfinal of
Nothing -> []
Just task@Task {..} ->
(if taskAllInOne then id else (:)
Action
{ actionId = ActionId taskProvides ATBuildFinal
, actionDeps = addBuild
(Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts))
, actionDo = \ac -> runInBase $ singleBuild ac ee task installedMap True
, actionConcurrency = ConcurrencyAllowed
}) $
-- These are the "final" actions - running tests and benchmarks.
(if Set.null tests then id else (:)
Action
{ actionId = ActionId taskProvides ATRunTests
, actionDeps = finalDeps
, actionDo = \ac -> withLock mtestLock $ runInBase $ do
singleTest topts (Set.toList tests) ac ee task installedMap
-- Always allow tests tasks to run concurrently with
-- other tasks, particularly build tasks. Note that
-- 'mtestLock' can optionally make it so that only
-- one test is run at a time.
, actionConcurrency = ConcurrencyAllowed
}) $
(if Set.null benches then id else (:)
Action
{ actionId = ActionId taskProvides ATRunBenchmarks
, actionDeps = finalDeps
, actionDo = \ac -> runInBase $ do
singleBench beopts (Set.toList benches) ac ee task installedMap
-- Never run benchmarks concurrently with any other task, see #3663
, actionConcurrency = ConcurrencyDisallowed
})
[]
where
comps = taskComponents task
tests = testComponents comps
benches = benchComponents comps
finalDeps =
if taskAllInOne
then addBuild mempty
else Set.singleton (ActionId taskProvides ATBuildFinal)
addBuild =
case mbuild of
Nothing -> id
Just _ -> Set.insert $ ActionId taskProvides ATBuild
withLock Nothing f = f
withLock (Just lock) f = withMVar lock $ \() -> f
bopts = eeBuildOpts ee
topts = boptsTestOpts bopts
beopts = boptsBenchmarkOpts bopts
-- | Generate the ConfigCache
getConfigCache :: HasEnvConfig env
=> ExecuteEnv -> Task -> InstalledMap -> Bool -> Bool
-> RIO env (Map PackageIdentifier GhcPkgId, ConfigCache)
getConfigCache ExecuteEnv {..} task@Task {..} installedMap enableTest enableBench = do
let extra =
-- We enable tests if the test suite dependencies are already
-- installed, so that we avoid unnecessary recompilation based on
-- cabal_macros.h changes when switching between 'stack build' and
-- 'stack test'. See:
-- https://github.com/commercialhaskell/stack/issues/805
case taskType of
TTLocalMutable _ ->
-- FIXME: make this work with exact-configuration.
-- Not sure how to plumb the info atm. See
-- https://github.com/commercialhaskell/stack/issues/2049
[ "--enable-tests" | enableTest] ++
[ "--enable-benchmarks" | enableBench]
TTRemotePackage{} -> []
idMap <- liftIO $ readTVarIO eeGhcPkgIds
let getMissing ident =
case Map.lookup ident idMap of
Nothing
-- Expect to instead find it in installedMap if it's
-- an initialBuildSteps target.
| boptsCLIInitialBuildSteps eeBuildOptsCLI && taskIsTarget task,
Just (_, installed) <- Map.lookup (pkgName ident) installedMap
-> installedToGhcPkgId ident installed
Just installed -> installedToGhcPkgId ident installed
_ -> throwM $ PackageIdMissingBug ident
installedToGhcPkgId ident (Library ident' x _) = assert (ident == ident') $ Just (ident, x)
installedToGhcPkgId _ (Executable _) = Nothing
missing' = Map.fromList $ mapMaybe getMissing $ Set.toList missing
TaskConfigOpts missing mkOpts = taskConfigOpts
opts = mkOpts missing'
allDeps = Set.fromList $ Map.elems missing' ++ Map.elems taskPresent
cache = ConfigCache
{ configCacheOpts = opts
{ coNoDirs = coNoDirs opts ++ map T.unpack extra
}
, configCacheDeps = allDeps
, configCacheComponents =
case taskType of
TTLocalMutable lp -> Set.map (encodeUtf8 . renderComponent) $ lpComponents lp
TTRemotePackage{} -> Set.empty
, configCacheHaddock = taskBuildHaddock
, configCachePkgSrc = taskCachePkgSrc
, configCachePathEnvVar = eePathEnvVar
}
allDepsMap = Map.union missing' taskPresent
pure (allDepsMap, cache)
-- | Ensure that the configuration for the package matches what is given
ensureConfig :: HasEnvConfig env
=> ConfigCache -- ^ newConfigCache
-> Path Abs Dir -- ^ package directory
-> ExecuteEnv
-> RIO env () -- ^ announce
-> (ExcludeTHLoading -> [String] -> RIO env ()) -- ^ cabal
-> Path Abs File -- ^ Cabal file
-> Task
-> RIO env Bool
ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp task = do
newCabalMod <- liftIO $ modificationTime <$> getFileStatus (toFilePath cabalfp)
setupConfigfp <- setupConfigFromDir pkgDir
let getNewSetupConfigMod =
liftIO $ either (const Nothing) (Just . modificationTime) <$>
tryJust (guard . isDoesNotExistError) (getFileStatus (toFilePath setupConfigfp))
newSetupConfigMod <- getNewSetupConfigMod
newProjectRoot <- S8.pack . toFilePath <$> view projectRootL
-- See https://github.com/commercialhaskell/stack/issues/3554
taskAnyMissingHack <- view $ actualCompilerVersionL.to getGhcVersion.to (< mkVersion [8, 4])
needConfig <-
if boptsReconfigure eeBuildOpts || (taskAnyMissing task && taskAnyMissingHack)
then pure True
else do
-- We can ignore the components portion of the config
-- cache, because it's just used to inform 'construct
-- plan that we need to plan to build additional
-- components. These components don't affect the actual
-- package configuration.
let ignoreComponents cc = cc { configCacheComponents = Set.empty }
-- Determine the old and new configuration in the local directory, to
-- determine if we need to reconfigure.
mOldConfigCache <- tryGetConfigCache pkgDir
mOldCabalMod <- tryGetCabalMod pkgDir
-- Cabal's setup-config is created per OS/Cabal version, multiple
-- projects using the same package could get a conflict because of this
mOldSetupConfigMod <- tryGetSetupConfigMod pkgDir
mOldProjectRoot <- tryGetPackageProjectRoot pkgDir
pure $ fmap ignoreComponents mOldConfigCache /= Just (ignoreComponents newConfigCache)
|| mOldCabalMod /= Just newCabalMod
|| mOldSetupConfigMod /= newSetupConfigMod
|| mOldProjectRoot /= Just newProjectRoot
let ConfigureOpts dirs nodirs = configCacheOpts newConfigCache
when (taskBuildTypeConfig task) ensureConfigureScript
when needConfig $ withMVar eeConfigureLock $ \_ -> do
deleteCaches pkgDir
announce
cp <- view compilerPathsL
let (GhcPkgExe pkgPath) = cpPkg cp
let programNames =
case cpWhich cp of
Ghc ->
[ ("ghc", toFilePath (cpCompiler cp))
, ("ghc-pkg", toFilePath pkgPath)
]
exes <- forM programNames $ \(name, file) -> do
mpath <- findExecutable file
pure $ case mpath of
Left _ -> []
Right x -> pure $ concat ["--with-", name, "=", x]
-- Configure cabal with arguments determined by
-- Stack.Types.Build.configureOpts
cabal KeepTHLoading $ "configure" : concat
[ concat exes
, dirs
, nodirs
]
-- Only write the cache for local packages. Remote packages are built
-- in a temporary directory so the cache would never be used anyway.
case taskType task of
TTLocalMutable{} -> writeConfigCache pkgDir newConfigCache
TTRemotePackage{} -> pure ()
writeCabalMod pkgDir newCabalMod
-- This file gets updated one more time by the configure step, so get
-- the most recent value. We could instead change our logic above to
-- check if our config mod file is newer than the file above, but this
-- seems reasonable too.
getNewSetupConfigMod >>= writeSetupConfigMod pkgDir
writePackageProjectRoot pkgDir newProjectRoot
pure needConfig
where
-- When build-type is Configure, we need to have a configure
-- script in the local directory. If it doesn't exist, build it
-- with autoreconf -i. See:
-- https://github.com/commercialhaskell/stack/issues/3534
ensureConfigureScript = do
let fp = pkgDir </> relFileConfigure
exists <- doesFileExist fp
unless exists $ do
logInfo $ "Trying to generate configure with autoreconf in " <> fromString (toFilePath pkgDir)
let autoreconf = if osIsWindows
then readProcessNull "sh" ["autoreconf", "-i"]
else readProcessNull "autoreconf" ["-i"]
-- On Windows 10, an upstream issue with the `sh autoreconf -i`
-- command means that command clears, but does not then restore, the
-- ENABLE_VIRTUAL_TERMINAL_PROCESSING flag for native terminals. The
-- following hack re-enables the lost ANSI-capability.
fixupOnWindows = when osIsWindows (void $ liftIO defaultColorWhen)
withWorkingDir (toFilePath pkgDir) $ autoreconf `catchAny` \ex -> do
fixupOnWindows
logWarn $ "Unable to run autoreconf: " <> displayShow ex
when osIsWindows $ do
logInfo $ "Check that executable perl is on the path in Stack's " <>
"MSYS2 \\usr\\bin folder, and working, and that script file " <>
"autoreconf is on the path in that location. To check that " <>
"perl or autoreconf are on the path in the required location, " <>
"run commands:"
logInfo ""
logInfo " stack exec where -- perl"
logInfo " stack exec where -- autoreconf"
logInfo ""
logInfo $ "If perl or autoreconf is not on the path in the " <>
"required location, add them with command (note that the " <>
"relevant package name is 'autoconf' not 'autoreconf'):"
logInfo ""
logInfo " stack exec pacman -- --sync --refresh autoconf"
logInfo ""
logInfo $ "Some versions of perl from MSYS2 are broken. See " <>
"https://github.com/msys2/MSYS2-packages/issues/1611 and " <>
"https://github.com/commercialhaskell/stack/pull/4781. To " <>
"test if perl in the required location is working, try command:"
logInfo ""
logInfo " stack exec perl -- --version"
logInfo ""
fixupOnWindows
-- | Make a padded prefix for log messages
packageNamePrefix :: ExecuteEnv -> PackageName -> Utf8Builder
packageNamePrefix ee name' =
let name = packageNameString name'
paddedName =
case eeLargestPackageName ee of
Nothing -> name
Just len -> assert (len >= length name) $ take len $ name ++ L.repeat ' '
in fromString paddedName <> "> "
announceTask :: HasLogFunc env => ExecuteEnv -> Task -> Utf8Builder -> RIO env ()
announceTask ee task action = logInfo $
packageNamePrefix ee (pkgName (taskProvides task)) <>
action
-- | Ensure we're the only action using the directory. See
-- <https://github.com/commercialhaskell/stack/issues/2730>
withLockedDistDir ::
HasEnvConfig env
=> (Utf8Builder -> RIO env ()) -- ^ announce
-> Path Abs Dir -- ^ root directory for package
-> RIO env a
-> RIO env a
withLockedDistDir announce root inner = do
distDir <- distRelativeDir
let lockFP = root </> distDir </> relFileBuildLock
ensureDir $ parent lockFP
mres <-
withRunInIO $ \run ->
withTryFileLock (toFilePath lockFP) Exclusive $ \_lock ->
run inner
case mres of
Just res -> pure res
Nothing -> do
let complainer delay = do
delay 5000000 -- 5 seconds
announce $ "blocking for directory lock on " <> fromString (toFilePath lockFP)
forever $ do
delay 30000000 -- 30 seconds
announce $ "still blocking for directory lock on " <>
fromString (toFilePath lockFP) <>
"; maybe another Stack process is running?"
withCompanion (\x -> complainer x) $
\stopComplaining ->
withRunInIO $ \run ->
withFileLock (toFilePath lockFP) Exclusive $ \_ ->
run $ stopComplaining *> inner
-- | How we deal with output from GHC, either dumping to a log file or the
-- console (with some prefix).
data OutputType
= OTLogFile !(Path Abs File) !Handle
| OTConsole !(Maybe Utf8Builder)
-- | This sets up a context for executing build steps which need to run
-- Cabal (via a compiled Setup.hs). In particular it does the following:
--
-- * Ensures the package exists in the file system, downloading if necessary.
--
-- * Opens a log file if the built output shouldn't go to stderr.
--
-- * Ensures that either a simple Setup.hs is built, or the package's
-- custom setup is built.
--
-- * Provides the user a function with which run the Cabal process.
withSingleContext :: forall env a. HasEnvConfig env
=> ActionContext
-> ExecuteEnv
-> Task
-> Map PackageIdentifier GhcPkgId
-- ^ All dependencies' package ids to provide to Setup.hs.
-> Maybe String
-> ( Package -- Package info
-> Path Abs File -- Cabal file path
-> Path Abs Dir -- Package root directory file path
-- Note that the `Path Abs Dir` argument is redundant with the `Path Abs File`
-- argument, but we provide both to avoid recalculating `parent` of the `File`.
-> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
-- Function to run Cabal with args
-> (Utf8Builder -> RIO env ()) -- An 'announce' function, for different build phases
-> OutputType
-> RIO env a)
-> RIO env a
withSingleContext ActionContext {..} ee@ExecuteEnv {..} task@Task {..} allDeps msuffix inner0 =
withPackage $ \package cabalfp pkgDir ->
withOutputType pkgDir package $ \outputType ->
withCabal package pkgDir outputType $ \cabal ->
inner0 package cabalfp pkgDir cabal announce outputType
where
announce = announceTask ee task
wanted =
case taskType of
TTLocalMutable lp -> lpWanted lp
TTRemotePackage{} -> False
-- Output to the console if this is the last task, and the user
-- asked to build it specifically. When the action is a
-- 'ConcurrencyDisallowed' action (benchmarks), then we can also be
-- sure to have exclusive access to the console, so output is also
-- sent to the console in this case.
--
-- See the discussion on #426 for thoughts on sending output to the
-- console from concurrent tasks.
console =
(wanted &&
all (\(ActionId ident _) -> ident == taskProvides) (Set.toList acRemaining) &&
eeTotalWanted == 1
) || (acConcurrency == ConcurrencyDisallowed)
withPackage inner =
case taskType of
TTLocalMutable lp -> do
let root = parent $ lpCabalFile lp
withLockedDistDir announce root $
inner (lpPackage lp) (lpCabalFile lp) root
TTRemotePackage _ package pkgloc -> do
suffix <- parseRelDir $ packageIdentifierString $ packageIdent package
let dir = eeTempDir </> suffix
unpackPackageLocation dir pkgloc
-- See: https://github.com/commercialhaskell/stack/issues/157
distDir <- distRelativeDir
let oldDist = dir </> relDirDist
newDist = dir </> distDir
exists <- doesDirExist oldDist
when exists $ do
-- Previously used takeDirectory, but that got confused
-- by trailing slashes, see:
-- https://github.com/commercialhaskell/stack/issues/216
--
-- Instead, use Path which is a bit more resilient
ensureDir $ parent newDist
renameDir oldDist newDist
let name = pkgName taskProvides
cabalfpRel <- parseRelFile $ packageNameString name ++ ".cabal"
let cabalfp = dir </> cabalfpRel
inner package cabalfp dir
withOutputType pkgDir package inner
-- Not in interleaved mode. When building a single wanted package, dump
-- to the console with no prefix.
| console = inner $ OTConsole Nothing
-- If the user requested interleaved output, dump to the console with a
-- prefix.
| boptsInterleavedOutput eeBuildOpts =
inner $ OTConsole $ Just $ packageNamePrefix ee $ packageName package
-- Neither condition applies, dump to a file.
| otherwise = do
logPath <- buildLogPath package msuffix
ensureDir (parent logPath)
let fp = toFilePath logPath
-- We only want to dump logs for local non-dependency packages
case taskType of
TTLocalMutable lp | lpWanted lp ->
liftIO $ atomically $ writeTChan eeLogFiles (pkgDir, logPath)
_ -> pure ()
withBinaryFile fp WriteMode $ \h -> inner $ OTLogFile logPath h
withCabal ::
Package
-> Path Abs Dir
-> OutputType
-> ((KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ()) -> RIO env a)
-> RIO env a
withCabal package pkgDir outputType inner = do
config <- view configL
unless (configAllowDifferentUser config) $
checkOwnership (pkgDir </> configWorkDir config)
let envSettings = EnvSettings
{ esIncludeLocals = taskLocation task == Local
, esIncludeGhcPackagePath = False
, esStackExe = False
, esLocaleUtf8 = True
, esKeepGhcRts = False
}
menv <- liftIO $ configProcessContextSettings config envSettings
distRelativeDir' <- distRelativeDir
esetupexehs <-
-- Avoid broken Setup.hs files causing problems for simple build
-- types, see:
-- https://github.com/commercialhaskell/stack/issues/370
case (packageBuildType package, eeSetupExe) of
(C.Simple, Just setupExe) -> pure $ Left setupExe
_ -> liftIO $ Right <$> getSetupHs pkgDir
inner $ \keepOutputOpen stripTHLoading args -> do
let cabalPackageArg
-- Omit cabal package dependency when building
-- Cabal. See
-- https://github.com/commercialhaskell/stack/issues/1356
| packageName package == mkPackageName "Cabal" = []
| otherwise =
["-package=" ++ packageIdentifierString
(PackageIdentifier cabalPackageName
eeCabalPkgVer)]
packageDBArgs =
( "-clear-package-db"
: "-global-package-db"
: map (("-package-db=" ++) . toFilePathNoTrailingSep) (bcoExtraDBs eeBaseConfigOpts)
) ++
( ("-package-db=" ++ toFilePathNoTrailingSep (bcoSnapDB eeBaseConfigOpts))
: ("-package-db=" ++ toFilePathNoTrailingSep (bcoLocalDB eeBaseConfigOpts))
: ["-hide-all-packages"]
)
warnCustomNoDeps :: RIO env ()
warnCustomNoDeps =
case (taskType, packageBuildType package) of
(TTLocalMutable lp, C.Custom) | lpWanted lp -> do
prettyWarnL
[ flow "Package"
, fromString $ packageNameString $ packageName package
, flow "uses a custom Cabal build, but does not use a custom-setup stanza"
]
_ -> pure ()
getPackageArgs :: Path Abs Dir -> RIO env [String]
getPackageArgs setupDir =
case packageSetupDeps package of
-- The package is using the Cabal custom-setup
-- configuration introduced in Cabal 1.24. In
-- this case, the package is providing an
-- explicit list of dependencies, and we
-- should simply use all of them.
Just customSetupDeps -> do
unless (Map.member (mkPackageName "Cabal") customSetupDeps) $
prettyWarnL
[ fromString $ packageNameString $ packageName package
, "has a setup-depends field, but it does not mention a Cabal dependency. This is likely to cause build errors."
]
matchedDeps <- forM (Map.toList customSetupDeps) $ \(name, range) -> do
let matches (PackageIdentifier name' version) =
name == name' &&
version `withinRange` range
case filter (matches . fst) (Map.toList allDeps) of
x:xs -> do
unless (null xs)
(logWarn ("Found multiple installed packages for custom-setup dep: " <> fromString (packageNameString name)))
pure ("-package-id=" ++ ghcPkgIdString (snd x), Just (fst x))
[] -> do
logWarn ("Could not find custom-setup dep: " <> fromString (packageNameString name))
pure ("-package=" ++ packageNameString name, Nothing)
let depsArgs = map fst matchedDeps
-- Generate setup_macros.h and provide it to ghc
let macroDeps = mapMaybe snd matchedDeps
cppMacrosFile = setupDir </> relFileSetupMacrosH
cppArgs = ["-optP-include", "-optP" ++ toFilePath cppMacrosFile]
writeBinaryFileAtomic cppMacrosFile (encodeUtf8Builder (T.pack (C.generatePackageVersionMacros (packageVersion package) macroDeps)))
pure (packageDBArgs ++ depsArgs ++ cppArgs)
-- This branch is usually taken for builds, and
-- is always taken for `stack sdist`.
--
-- This approach is debatable. It adds access to the
-- snapshot package database for Cabal. There are two
-- possible objections:
--
-- 1. This doesn't isolate the build enough; arbitrary
-- other packages available could cause the build to
-- succeed or fail.
--
-- 2. This doesn't provide enough packages: we should also
-- include the local database when building local packages.
--
-- Currently, this branch is only taken via `stack
-- sdist` or when explicitly requested in the
-- stack.yaml file.
Nothing -> do
warnCustomNoDeps
pure $ cabalPackageArg ++
-- NOTE: This is different from
-- packageDBArgs above in that it does not
-- include the local database and does not
-- pass in the -hide-all-packages argument
("-clear-package-db"
: "-global-package-db"
: map (("-package-db=" ++) . toFilePathNoTrailingSep) (bcoExtraDBs eeBaseConfigOpts)
++ ["-package-db=" ++ toFilePathNoTrailingSep (bcoSnapDB eeBaseConfigOpts)])
setupArgs = ("--builddir=" ++ toFilePathNoTrailingSep distRelativeDir') : args
runExe :: Path Abs File -> [String] -> RIO env ()
runExe exeName fullArgs = do
compilerVer <- view actualCompilerVersionL
runAndOutput compilerVer `catch` \ece -> do
(mlogFile, bss) <-
case outputType of
OTConsole _ -> pure (Nothing, [])
OTLogFile logFile h ->
if keepOutputOpen == KeepOpen
then pure (Nothing, []) -- expected failure build continues further
else do
liftIO $ hClose h
fmap (Just logFile,) $ withSourceFile (toFilePath logFile) $ \src ->
runConduit
$ src
.| CT.decodeUtf8Lenient
.| mungeBuildOutput stripTHLoading makeAbsolute pkgDir compilerVer
.| CL.consume
throwM $ PrettyException $ CabalExitedUnsuccessfully
(eceExitCode ece)
taskProvides
exeName
fullArgs
mlogFile
bss
where
runAndOutput :: ActualCompiler -> RIO env ()
runAndOutput compilerVer = withWorkingDir (toFilePath pkgDir) $ withProcessContext menv $ case outputType of
OTLogFile _ h -> do
let prefixWithTimestamps =
if configPrefixTimestamps config
then PrefixWithTimestamps
else WithoutTimestamps
void $ sinkProcessStderrStdout (toFilePath exeName) fullArgs
(sinkWithTimestamps prefixWithTimestamps h)
(sinkWithTimestamps prefixWithTimestamps h)
OTConsole mprefix ->
let prefix = fold mprefix in
void $ sinkProcessStderrStdout (toFilePath exeName) fullArgs
(outputSink KeepTHLoading LevelWarn compilerVer prefix)
(outputSink stripTHLoading LevelInfo compilerVer prefix)
outputSink ::
HasCallStack
=> ExcludeTHLoading
-> LogLevel
-> ActualCompiler
-> Utf8Builder
-> ConduitM S.ByteString Void (RIO env) ()
outputSink excludeTH level compilerVer prefix =
CT.decodeUtf8Lenient
.| mungeBuildOutput excludeTH makeAbsolute pkgDir compilerVer
.| CL.mapM_ (logGeneric "" level . (prefix <>) . display)
-- If users want control, we should add a config option for this
makeAbsolute :: ConvertPathsToAbsolute
makeAbsolute = case stripTHLoading of
ExcludeTHLoading -> ConvertPathsToAbsolute
KeepTHLoading -> KeepPathsAsIs
exeName <- case esetupexehs of
Left setupExe -> pure setupExe
Right setuphs -> do
distDir <- distDirFromDir pkgDir
let setupDir = distDir </> relDirSetup
outputFile = setupDir </> relFileSetupLower
customBuilt <- liftIO $ readIORef eeCustomBuilt
if Set.member (packageName package) customBuilt
then pure outputFile
else do
ensureDir setupDir
compilerPath <- view $ compilerPathsL.to cpCompiler
packageArgs <- getPackageArgs setupDir
runExe compilerPath $
[ "--make"
, "-odir", toFilePathNoTrailingSep setupDir
, "-hidir", toFilePathNoTrailingSep setupDir
, "-i", "-i."
] ++ packageArgs ++
[ toFilePath setuphs
, toFilePath eeSetupShimHs
, "-main-is"
, "StackSetupShim.mainOverride"
, "-o", toFilePath outputFile
, "-threaded"
] ++
-- Apply GHC options
-- https://github.com/commercialhaskell/stack/issues/4526
map T.unpack (
Map.findWithDefault [] AGOEverything (configGhcOptionsByCat config) ++
case configApplyGhcOptions config of
AGOEverything -> boptsCLIGhcOptions eeBuildOptsCLI
AGOTargets -> []
AGOLocals -> [])
liftIO $ atomicModifyIORef' eeCustomBuilt $
\oldCustomBuilt -> (Set.insert (packageName package) oldCustomBuilt, ())
pure outputFile
let cabalVerboseArg =
let CabalVerbosity cv = boptsCabalVerbose eeBuildOpts
in "--verbose=" <> showForCabal cv
runExe exeName $ cabalVerboseArg:setupArgs
-- Implements running a package's build, used to implement 'ATBuild' and
-- 'ATBuildFinal' tasks. In particular this does the following:
--
-- * Checks if the package exists in the precompiled cache, and if so,
-- add it to the database instead of performing the build.
--
-- * Runs the configure step if needed ('ensureConfig')
--
-- * Runs the build step
--
-- * Generates haddocks
--
-- * Registers the library and copies the built executables into the
-- local install directory. Note that this is literally invoking Cabal
-- with @copy@, and not the copying done by @stack install@ - that is
-- handled by 'copyExecutables'.
singleBuild :: forall env. (HasEnvConfig env, HasRunner env)
=> ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> Bool -- ^ Is this a final build?
-> RIO env ()
singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap isFinalBuild = do
(allDepsMap, cache) <- getConfigCache ee task installedMap enableTests enableBenchmarks
mprecompiled <- getPrecompiled cache
minstalled <-
case mprecompiled of
Just precompiled -> copyPreCompiled precompiled
Nothing -> do
mcurator <- view $ buildConfigL.to bcCurator
realConfigAndBuild cache mcurator allDepsMap
case minstalled of
Nothing -> pure ()
Just installed -> do
writeFlagCache installed cache
liftIO $ atomically $ modifyTVar eeGhcPkgIds $ Map.insert taskProvides installed
where
pname = pkgName taskProvides
doHaddock mcurator package
= taskBuildHaddock &&
not isFinalBuild &&
-- Works around haddock failing on bytestring-builder since it has no modules
-- when bytestring is new enough.
packageHasExposedModules package &&
-- Special help for the curator tool to avoid haddocks that are known to fail
maybe True (Set.notMember pname . curatorSkipHaddock) mcurator
expectHaddockFailure mcurator =
maybe False (Set.member pname . curatorExpectHaddockFailure) mcurator
fulfillHaddockExpectations mcurator action | expectHaddockFailure mcurator = do
eres <- tryAny $ action KeepOpen
case eres of
Right () -> logWarn $ fromString (packageNameString pname) <> ": unexpected Haddock success"
Left _ -> pure ()
fulfillHaddockExpectations _ action = do
action CloseOnException
buildingFinals = isFinalBuild || taskAllInOne
enableTests = buildingFinals && any isCTest (taskComponents task)
enableBenchmarks = buildingFinals && any isCBench (taskComponents task)
annSuffix executableBuildStatuses = if result == "" then "" else " (" <> result <> ")"
where
result = T.intercalate " + " $ concat
[ ["lib" | taskAllInOne && hasLib]
, ["internal-lib" | taskAllInOne && hasSubLib]
, ["exe" | taskAllInOne && hasExe]
, ["test" | enableTests]
, ["bench" | enableBenchmarks]
]
(hasLib, hasSubLib, hasExe) = case taskType of
TTLocalMutable lp ->
let package = lpPackage lp
hasLibrary =
case packageLibraries package of
NoLibraries -> False
HasLibraries _ -> True
hasSubLibrary = not . Set.null $ packageInternalLibraries package
hasExecutables = not . Set.null $ exesToBuild executableBuildStatuses lp
in (hasLibrary, hasSubLibrary, hasExecutables)
-- This isn't true, but we don't want to have this info for
-- upstream deps.
_ -> (False, False, False)
getPrecompiled cache =
case taskType of
TTRemotePackage Immutable _ loc -> do
mpc <- readPrecompiledCache
loc
(configCacheOpts cache)
(configCacheHaddock cache)
(configCacheDeps cache)
case mpc of
Nothing -> pure Nothing
-- Only pay attention to precompiled caches that refer to packages within
-- the snapshot.
Just pc | maybe False
(bcoSnapInstallRoot eeBaseConfigOpts `isProperPrefixOf`)
(pcLibrary pc) ->
pure Nothing
-- If old precompiled cache files are left around but snapshots are deleted,
-- it is possible for the precompiled file to refer to the very library
-- we're building, and if flags are changed it may try to copy the library
-- to itself. This check prevents that from happening.
Just pc -> do
let allM _ [] = pure True
allM f (x:xs) = do
b <- f x
if b then allM f xs else pure False
b <- liftIO $ allM doesFileExist $ maybe id (:) (pcLibrary pc) $ pcExes pc
pure $ if b then Just pc else Nothing
_ -> pure Nothing
copyPreCompiled (PrecompiledCache mlib sublibs exes) = do
wc <- view $ actualCompilerVersionL.whichCompilerL
announceTask ee task "using precompiled package"
-- We need to copy .conf files for the main library and all sublibraries which exist in the cache,
-- from their old snapshot to the new one. However, we must unregister any such library in the new
-- snapshot, in case it was built with different flags.
let
subLibNames = map T.unpack . Set.toList $ case taskType of
TTLocalMutable lp -> packageInternalLibraries $ lpPackage lp
TTRemotePackage _ p _ -> packageInternalLibraries p
PackageIdentifier name version = taskProvides
mainLibName = packageNameString name
mainLibVersion = versionString version
pkgName = mainLibName ++ "-" ++ mainLibVersion
-- z-package-z-internal for internal lib internal of package package
toCabalInternalLibName n = concat ["z-", mainLibName, "-z-", n, "-", mainLibVersion]
allToUnregister = map (const pkgName) (maybeToList mlib) ++ map toCabalInternalLibName subLibNames
allToRegister = maybeToList mlib ++ sublibs
unless (null allToRegister) $ do
withMVar eeInstallLock $ \() -> do
-- We want to ignore the global and user databases.
-- Unfortunately, ghc-pkg doesn't take such arguments on the
-- command line. Instead, we'll set GHC_PACKAGE_PATH. See:
-- https://github.com/commercialhaskell/stack/issues/1146
let modifyEnv = Map.insert
(ghcPkgPathEnvVar wc)
(T.pack $ toFilePathNoTrailingSep $ bcoSnapDB eeBaseConfigOpts)
withModifyEnvVars modifyEnv $ do
GhcPkgExe ghcPkgExe <- getGhcPkgExe
-- first unregister everything that needs to be unregistered
forM_ allToUnregister $ \packageName -> catchAny
(readProcessNull (toFilePath ghcPkgExe) [ "unregister", "--force", packageName])
(const (pure ()))
-- now, register the cached conf files
forM_ allToRegister $ \libpath ->
proc (toFilePath ghcPkgExe) [ "register", "--force", toFilePath libpath] readProcess_
liftIO $ forM_ exes $ \exe -> do
ensureDir bindir
let dst = bindir </> filename exe
createLink (toFilePath exe) (toFilePath dst) `catchIO` \_ -> copyFile exe dst
case (mlib, exes) of
(Nothing, _:_) -> markExeInstalled (taskLocation task) taskProvides
_ -> pure ()
-- Find the package in the database
let pkgDbs = [bcoSnapDB eeBaseConfigOpts]
case mlib of
Nothing -> pure $ Just $ Executable taskProvides
Just _ -> do
mpkgid <- loadInstalledPkg pkgDbs eeSnapshotDumpPkgs pname
pure $ Just $
case mpkgid of
Nothing -> assert False $ Executable taskProvides
Just pkgid -> Library taskProvides pkgid Nothing
where
bindir = bcoSnapInstallRoot eeBaseConfigOpts </> bindirSuffix
realConfigAndBuild cache mcurator allDepsMap = withSingleContext ac ee task allDepsMap Nothing
$ \package cabalfp pkgDir cabal0 announce _outputType -> do
let cabal = cabal0 CloseOnException
executableBuildStatuses <- getExecutableBuildStatuses package pkgDir
when (not (cabalIsSatisfied executableBuildStatuses) && taskIsTarget task)
(logInfo
("Building all executables for `" <> fromString (packageNameString (packageName package)) <>
"' once. After a successful build of all of them, only specified executables will be rebuilt."))
_neededConfig <- ensureConfig cache pkgDir ee (announce ("configure" <> display (annSuffix executableBuildStatuses))) cabal cabalfp task
let installedMapHasThisPkg :: Bool
installedMapHasThisPkg =
case Map.lookup (packageName package) installedMap of
Just (_, Library ident _ _) -> ident == taskProvides
Just (_, Executable _) -> True
_ -> False
case ( boptsCLIOnlyConfigure eeBuildOptsCLI
, boptsCLIInitialBuildSteps eeBuildOptsCLI && taskIsTarget task) of
-- A full build is done if there are downstream actions,
-- because their configure step will require that this
-- package is built. See
-- https://github.com/commercialhaskell/stack/issues/2787
(True, _) | null acDownstream -> pure Nothing
(_, True) | null acDownstream || installedMapHasThisPkg -> do
initialBuildSteps executableBuildStatuses cabal announce
pure Nothing
_ -> fulfillCuratorBuildExpectations pname mcurator enableTests enableBenchmarks Nothing $
Just <$> realBuild cache package pkgDir cabal0 announce executableBuildStatuses
initialBuildSteps executableBuildStatuses cabal announce = do
announce ("initial-build-steps" <> display (annSuffix executableBuildStatuses))
cabal KeepTHLoading ["repl", "stack-initial-build-steps"]
realBuild ::
ConfigCache
-> Package
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> Map Text ExecutableBuildStatus
-> RIO env Installed
realBuild cache package pkgDir cabal0 announce executableBuildStatuses = do
let cabal = cabal0 CloseOnException
wc <- view $ actualCompilerVersionL.whichCompilerL
markExeNotInstalled (taskLocation task) taskProvides
case taskType of
TTLocalMutable lp -> do
when enableTests $ setTestStatus pkgDir TSUnknown
caches <- runMemoizedWith $ lpNewBuildCaches lp
mapM_ (uncurry (writeBuildCache pkgDir))
(Map.toList caches)
TTRemotePackage{} -> pure ()
-- FIXME: only output these if they're in the build plan.
let postBuildCheck _succeeded = do
mlocalWarnings <- case taskType of
TTLocalMutable lp -> do
warnings <- checkForUnlistedFiles taskType pkgDir
-- TODO: Perhaps only emit these warnings for non extra-dep?
pure (Just (lpCabalFile lp, warnings))
_ -> pure Nothing
-- NOTE: once
-- https://github.com/commercialhaskell/stack/issues/2649
-- is resolved, we will want to partition the warnings
-- based on variety, and output in different lists.
let showModuleWarning (UnlistedModulesWarning comp modules) =
"- In" <+>
fromString (T.unpack (renderComponent comp)) <>
":" <> line <>
indent 4 ( mconcat
$ L.intersperse line
$ map
(style Good . fromString . C.display)
modules
)
forM_ mlocalWarnings $ \(cabalfp, warnings) -> do
unless (null warnings) $ prettyWarn $
flow "The following modules should be added to \
\exposed-modules or other-modules in" <+>
pretty cabalfp
<> ":"
<> line
<> indent 4 ( mconcat
$ L.intersperse line
$ map showModuleWarning warnings
)
<> blankLine
<> flow "Missing modules in the Cabal file are likely \
\to cause undefined reference errors from the \
\linker, along with other problems."
() <- announce ("build" <> display (annSuffix executableBuildStatuses))
config <- view configL
extraOpts <- extraBuildOptions wc eeBuildOpts
let stripTHLoading
| configHideTHLoading config = ExcludeTHLoading
| otherwise = KeepTHLoading
cabal stripTHLoading (("build" :) $ (++ extraOpts) $
case (taskType, taskAllInOne, isFinalBuild) of
(_, True, True) -> throwM AllInOneBuildBug
(TTLocalMutable lp, False, False) -> primaryComponentOptions executableBuildStatuses lp
(TTLocalMutable lp, False, True) -> finalComponentOptions lp
(TTLocalMutable lp, True, False) -> primaryComponentOptions executableBuildStatuses lp ++ finalComponentOptions lp
(TTRemotePackage{}, _, _) -> [])
`catch` \ex -> case ex of
CabalExitedUnsuccessfully{} ->
postBuildCheck False >> throwM (PrettyException ex)
_ -> throwM ex
postBuildCheck True
mcurator <- view $ buildConfigL.to bcCurator
when (doHaddock mcurator package) $ do
announce "haddock"
sourceFlag <- if not (boptsHaddockHyperlinkSource eeBuildOpts) then pure [] else do
-- See #2429 for why the temp dir is used
ec
<- withWorkingDir (toFilePath eeTempDir)
$ proc "haddock" ["--hyperlinked-source"]
$ \pc -> withProcessWait
(setStdout createSource $ setStderr createSource pc) $ \p ->
runConcurrently
$ Concurrently (runConduit $ getStdout p .| CL.sinkNull)
*> Concurrently (runConduit $ getStderr p .| CL.sinkNull)
*> Concurrently (waitExitCode p)
case ec of
-- Fancy crosslinked source
ExitSuccess -> pure ["--haddock-option=--hyperlinked-source"]
-- Older hscolour colouring
ExitFailure _ -> do
hscolourExists <- doesExecutableExist "HsColour"
unless hscolourExists $ logWarn
("Warning: haddock not generating hyperlinked sources because 'HsColour' not\n" <>
"found on PATH (use 'stack install hscolour' to install).")
pure ["--hyperlink-source" | hscolourExists]
-- For GHC 8.4 and later, provide the --quickjump option.
actualCompiler <- view actualCompilerVersionL
let quickjump =
case actualCompiler of
ACGhc ghcVer
| ghcVer >= mkVersion [8, 4] -> ["--haddock-option=--quickjump"]
_ -> []
fulfillHaddockExpectations mcurator $ \keep -> cabal0 keep KeepTHLoading $ concat
[ ["haddock", "--html", "--hoogle", "--html-location=../$pkg-$version/"]
, sourceFlag
, ["--internal" | boptsHaddockInternal eeBuildOpts]
, [ "--haddock-option=" <> opt
| opt <- hoAdditionalArgs (boptsHaddockOpts eeBuildOpts) ]
, quickjump
]
let hasLibrary =
case packageLibraries package of
NoLibraries -> False
HasLibraries _ -> True
packageHasComponentSet f = not $ Set.null $ f package
hasInternalLibrary = packageHasComponentSet packageInternalLibraries
hasExecutables = packageHasComponentSet packageExes
shouldCopy = not isFinalBuild && (hasLibrary || hasInternalLibrary || hasExecutables)
when shouldCopy $ withMVar eeInstallLock $ \() -> do
announce "copy/register"
eres <- try $ cabal KeepTHLoading ["copy"]
case eres of
Left err@CabalExitedUnsuccessfully{} ->
throwM $ CabalCopyFailed
(packageBuildType package == C.Simple)
(displayException err)
_ -> pure ()
when hasLibrary $ cabal KeepTHLoading ["register"]
-- copy ddump-* files
case T.unpack <$> boptsDdumpDir eeBuildOpts of
Just ddumpPath | buildingFinals && not (null ddumpPath) -> do
distDir <- distRelativeDir
ddumpDir <- parseRelDir ddumpPath
logDebug $ fromString ("ddump-dir: " <> toFilePath ddumpDir)
logDebug $ fromString ("dist-dir: " <> toFilePath distDir)
runConduitRes
$ CF.sourceDirectoryDeep False (toFilePath distDir)
.| CL.filter (L.isInfixOf ".dump-")
.| CL.mapM_ (\src -> liftIO $ do
parentDir <- parent <$> parseRelDir src
destBaseDir <- (ddumpDir </>) <$> stripProperPrefix distDir parentDir
-- exclude .stack-work dir
unless (".stack-work" `L.isInfixOf` toFilePath destBaseDir) $ do
ensureDir destBaseDir
src' <- parseRelFile src
copyFile src' (destBaseDir </> filename src'))
_ -> pure ()
let (installedPkgDb, installedDumpPkgsTVar) =
case taskLocation task of
Snap ->
( bcoSnapDB eeBaseConfigOpts
, eeSnapshotDumpPkgs )
Local ->
( bcoLocalDB eeBaseConfigOpts
, eeLocalDumpPkgs )
let ident = PackageIdentifier (packageName package) (packageVersion package)
-- only pure the sublibs to cache them if we also cache the main lib (that is, if it exists)
(mpkgid, sublibsPkgIds) <- case packageLibraries package of
HasLibraries _ -> do
sublibsPkgIds <- fmap catMaybes $
forM (Set.toList $ packageInternalLibraries package) $ \sublib -> do
-- z-haddock-library-z-attoparsec for internal lib attoparsec of haddock-library
let sublibName = T.concat ["z-", T.pack $ packageNameString $ packageName package, "-z-", sublib]
case parsePackageName $ T.unpack sublibName of
Nothing -> pure Nothing -- invalid lib, ignored
Just subLibName -> loadInstalledPkg [installedPkgDb] installedDumpPkgsTVar subLibName
mpkgid <- loadInstalledPkg [installedPkgDb] installedDumpPkgsTVar (packageName package)
case mpkgid of
Nothing -> throwM $ Couldn'tFindPkgId $ packageName package
Just pkgid -> pure (Library ident pkgid Nothing, sublibsPkgIds)
NoLibraries -> do
markExeInstalled (taskLocation task) taskProvides -- TODO unify somehow with writeFlagCache?
pure (Executable ident, []) -- don't pure sublibs in this case
case taskType of
TTRemotePackage Immutable _ loc ->
writePrecompiledCache
eeBaseConfigOpts
loc
(configCacheOpts cache)
(configCacheHaddock cache)
(configCacheDeps cache)
mpkgid sublibsPkgIds (packageExes package)
_ -> pure ()
case taskType of
-- For packages from a package index, pkgDir is in the tmp
-- directory. We eagerly delete it if no other tasks
-- require it, to reduce space usage in tmp (#3018).
TTRemotePackage{} -> do
let remaining = filter (\(ActionId x _) -> x == taskProvides) (Set.toList acRemaining)
when (null remaining) $ removeDirRecur pkgDir
TTLocalMutable{} -> pure ()
pure mpkgid
loadInstalledPkg pkgDbs tvar name = do
pkgexe <- getGhcPkgExe
dps <- ghcPkgDescribe pkgexe name pkgDbs $ conduitDumpPackage .| CL.consume
case dps of
[] -> pure Nothing
[dp] -> do
liftIO $ atomically $ modifyTVar' tvar (Map.insert (dpGhcPkgId dp) dp)
pure $ Just (dpGhcPkgId dp)
_ -> throwM $ MulipleResultsBug name dps
-- | Get the build status of all the package executables. Do so by
-- testing whether their expected output file exists, e.g.
--
-- .stack-work/dist/x86_64-osx/Cabal-1.22.4.0/build/alpha/alpha
-- .stack-work/dist/x86_64-osx/Cabal-1.22.4.0/build/alpha/alpha.exe
-- .stack-work/dist/x86_64-osx/Cabal-1.22.4.0/build/alpha/alpha.jsexe/ (NOTE: a dir)
getExecutableBuildStatuses ::
HasEnvConfig env
=> Package -> Path Abs Dir -> RIO env (Map Text ExecutableBuildStatus)
getExecutableBuildStatuses package pkgDir = do
distDir <- distDirFromDir pkgDir
platform <- view platformL
fmap
M.fromList
(mapM (checkExeStatus platform distDir) (Set.toList (packageExes package)))
-- | Check whether the given executable is defined in the given dist directory.
checkExeStatus ::
HasLogFunc env
=> Platform
-> Path b Dir
-> Text
-> RIO env (Text, ExecutableBuildStatus)
checkExeStatus platform distDir name = do
exename <- parseRelDir (T.unpack name)
exists <- checkPath (distDir </> relDirBuild </> exename)
pure
( name
, if exists
then ExecutableBuilt
else ExecutableNotBuilt)
where
checkPath base =
case platform of
Platform _ Windows -> do
fileandext <- parseRelFile (file ++ ".exe")
doesFileExist (base </> fileandext)
_ -> do
fileandext <- parseRelFile file
doesFileExist (base </> fileandext)
where
file = T.unpack name
-- | Check if any unlisted files have been found, and add them to the build cache.
checkForUnlistedFiles ::
HasEnvConfig env
=> TaskType
-> Path Abs Dir
-> RIO env [PackageWarning]
checkForUnlistedFiles (TTLocalMutable lp) pkgDir = do
caches <- runMemoizedWith $ lpNewBuildCaches lp
(addBuildCache,warnings) <-
addUnlistedToBuildCache
(lpPackage lp)
(lpCabalFile lp)
(lpComponents lp)
caches
forM_ (M.toList addBuildCache) $ \(component, newToCache) -> do
let cache = Map.findWithDefault Map.empty component caches
writeBuildCache pkgDir component $
Map.unions (cache : newToCache)
pure warnings
checkForUnlistedFiles TTRemotePackage{} _ = pure []
-- | Implements running a package's tests. Also handles producing
-- coverage reports if coverage is enabled.
singleTest :: HasEnvConfig env
=> TestOpts
-> [Text]
-> ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> RIO env ()
singleTest topts testsToRun ac ee task installedMap = do
-- FIXME: Since this doesn't use cabal, we should be able to avoid using a
-- full blown 'withSingleContext'.
(allDepsMap, _cache) <- getConfigCache ee task installedMap True False
mcurator <- view $ buildConfigL.to bcCurator
let pname = pkgName $ taskProvides task
expectFailure = expectTestFailure pname mcurator
withSingleContext ac ee task allDepsMap (Just "test") $ \package _cabalfp pkgDir _cabal announce outputType -> do
config <- view configL
let needHpc = toCoverage topts
toRun <-
if toDisableRun topts
then do
announce "Test running disabled by --no-run-tests flag."
pure False
else if toRerunTests topts
then pure True
else do
status <- getTestStatus pkgDir
case status of
TSSuccess -> do
unless (null testsToRun) $ announce "skipping already passed test"
pure False
TSFailure
| expectFailure -> do
announce "skipping already failed test that's expected to fail"
pure False
| otherwise -> do
announce "rerunning previously failed test"
pure True
TSUnknown -> pure True
when toRun $ do
buildDir <- distDirFromDir pkgDir
hpcDir <- hpcDirFromDir pkgDir
when needHpc (ensureDir hpcDir)
let suitesToRun
= [ testSuitePair
| testSuitePair <- Map.toList $ packageTests package
, let testName = fst testSuitePair
, testName `elem` testsToRun
]
errs <- liftM Map.unions $ forM suitesToRun $ \(testName, suiteInterface) -> do
let stestName = T.unpack testName
(testName', isTestTypeLib) <-
case suiteInterface of
C.TestSuiteLibV09{} -> pure (stestName ++ "Stub", True)
C.TestSuiteExeV10{} -> pure (stestName, False)
interface -> throwM (TestSuiteTypeUnsupported interface)
let exeName = testName' ++
case configPlatform config of
Platform _ Windows -> ".exe"
_ -> ""
tixPath <- liftM (pkgDir </>) $ parseRelFile $ exeName ++ ".tix"
exePath <- liftM (buildDir </>) $ parseRelFile $ "build/" ++ testName' ++ "/" ++ exeName
exists <- doesFileExist exePath
-- in Stack.Package.packageFromPackageDescription we filter out
-- package itself of any dependencies so any tests requiring loading
-- of their own package library will fail
-- so to prevent this we return it back here but unfortunately unconditionally
installed <- case Map.lookup pname installedMap of
Just (_, installed) -> pure $ Just installed
Nothing -> do
idMap <- liftIO $ readTVarIO (eeGhcPkgIds ee)
pure $ Map.lookup (taskProvides task) idMap
let pkgGhcIdList = case installed of
Just (Library _ ghcPkgId _) -> [ghcPkgId]
_ -> []
-- doctest relies on template-haskell in QuickCheck-based tests
thGhcId <- case L.find ((== "template-haskell") . pkgName . dpPackageIdent. snd)
(Map.toList $ eeGlobalDumpPkgs ee) of
Just (ghcId, _) -> pure ghcId
Nothing -> throwIO TemplateHaskellNotFoundBug
-- env variable GHC_ENVIRONMENT is set for doctest so module names for
-- packages with proper dependencies should no longer get ambiguous
-- see e.g. https://github.com/doctest/issues/119
-- also we set HASKELL_DIST_DIR to a package dist directory so
-- doctest will be able to load modules autogenerated by Cabal
let setEnv f pc = modifyEnvVars pc $ \envVars ->
Map.insert "HASKELL_DIST_DIR" (T.pack $ toFilePath buildDir) $
Map.insert "GHC_ENVIRONMENT" (T.pack f) envVars
fp' = eeTempDir ee </> testGhcEnvRelFile
-- Add a random suffix to avoid conflicts between parallel jobs
-- See https://github.com/commercialhaskell/stack/issues/5024
randomInt <- liftIO (randomIO :: IO Int)
let randomSuffix = "." <> show (abs randomInt)
fp <- toFilePath <$> addExtension randomSuffix fp'
let snapDBPath = toFilePathNoTrailingSep (bcoSnapDB $ eeBaseConfigOpts ee)
localDBPath = toFilePathNoTrailingSep (bcoLocalDB $ eeBaseConfigOpts ee)
ghcEnv =
"clear-package-db\n" <>
"global-package-db\n" <>
"package-db " <> fromString snapDBPath <> "\n" <>
"package-db " <> fromString localDBPath <> "\n" <>
foldMap (\ghcId -> "package-id " <> display (unGhcPkgId ghcId) <> "\n")
(pkgGhcIdList ++ thGhcId:M.elems allDepsMap)
writeFileUtf8Builder fp ghcEnv
menv <- liftIO $ setEnv fp =<< configProcessContextSettings config EnvSettings
{ esIncludeLocals = taskLocation task == Local
, esIncludeGhcPackagePath = True
, esStackExe = True
, esLocaleUtf8 = False
, esKeepGhcRts = False
}
let emptyResult = Map.singleton testName Nothing
withProcessContext menv $ if exists
then do
-- We clear out the .tix files before doing a run.
when needHpc $ do
tixexists <- doesFileExist tixPath
when tixexists $
logWarn ("Removing HPC file " <> fromString (toFilePath tixPath))
liftIO $ ignoringAbsence (removeFile tixPath)
let args = toAdditionalArgs topts
argsDisplay = case args of
[] -> ""
_ -> ", args: " <> T.intercalate " " (map showProcessArgDebug args)
announce $ "test (suite: " <> display testName <> display argsDisplay <> ")"
-- Clear "Progress: ..." message before
-- redirecting output.
case outputType of
OTConsole _ -> do
logStickyDone ""
liftIO $ hFlush stdout
liftIO $ hFlush stderr
OTLogFile _ _ -> pure ()
let output =
case outputType of
OTConsole Nothing -> Nothing <$ inherit
OTConsole (Just prefix) -> fmap
(\src -> Just $ runConduit $ src .|
CT.decodeUtf8Lenient .|
CT.lines .|
CL.map stripCR .|
CL.mapM_ (\t -> logInfo $ prefix <> display t))
createSource
OTLogFile _ h -> Nothing <$ useHandleOpen h
optionalTimeout action
| Just maxSecs <- toMaximumTimeSeconds topts, maxSecs > 0 = do
timeout (maxSecs * 1000000) action
| otherwise = Just <$> action
mec <- withWorkingDir (toFilePath pkgDir) $
optionalTimeout $ proc (toFilePath exePath) args $ \pc0 -> do
changeStdin <-
if isTestTypeLib
then do
logPath <- buildLogPath package (Just stestName)
ensureDir (parent logPath)
pure $ setStdin
$ byteStringInput
$ BL.fromStrict
$ encodeUtf8 $ fromString $
show (logPath, mkUnqualComponentName (T.unpack testName))
else do
isTerminal <- view $ globalOptsL.to globalTerminal
if toAllowStdin topts && isTerminal
then pure id
else pure $ setStdin $ byteStringInput mempty
let pc = changeStdin
$ setStdout output
$ setStderr output
pc0
withProcessWait pc $ \p -> do
case (getStdout p, getStderr p) of
(Nothing, Nothing) -> pure ()
(Just x, Just y) -> concurrently_ x y
(x, y) -> assert False $ concurrently_ (fromMaybe (pure ()) x) (fromMaybe (pure ()) y)
waitExitCode p
-- Add a trailing newline, incase the test
-- output didn't finish with a newline.
case outputType of
OTConsole Nothing -> logInfo ""
_ -> pure ()
-- Move the .tix file out of the package
-- directory into the hpc work dir, for
-- tidiness.
when needHpc $
updateTixFile (packageName package) tixPath testName'
let announceResult result = announce $ "Test suite " <> display testName <> " " <> result
case mec of
Just ExitSuccess -> do
announceResult "passed"
pure Map.empty
Nothing -> do
announceResult "timed out"
if expectFailure
then pure Map.empty
else pure $ Map.singleton testName Nothing
Just ec -> do
announceResult "failed"
if expectFailure
then pure Map.empty
else pure $ Map.singleton testName (Just ec)
else do
unless expectFailure $ logError $ displayShow $ TestSuiteExeMissing
(packageBuildType package == C.Simple)
exeName
(packageNameString (packageName package))
(T.unpack testName)
pure emptyResult
when needHpc $ do
let testsToRun' = map f testsToRun
f tName =
case Map.lookup tName (packageTests package) of
Just C.TestSuiteLibV09{} -> tName <> "Stub"
_ -> tName
generateHpcReport pkgDir package testsToRun'
bs <- liftIO $
case outputType of
OTConsole _ -> pure ""
OTLogFile logFile h -> do
hClose h
S.readFile $ toFilePath logFile
let succeeded = Map.null errs
unless (succeeded || expectFailure) $ throwM $ TestSuiteFailure
(taskProvides task)
errs
(case outputType of
OTLogFile fp _ -> Just fp
OTConsole _ -> Nothing)
bs
setTestStatus pkgDir $ if succeeded then TSSuccess else TSFailure
-- | Implements running a package's benchmarks.
singleBench :: HasEnvConfig env
=> BenchmarkOpts
-> [Text]
-> ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> RIO env ()
singleBench beopts benchesToRun ac ee task installedMap = do
(allDepsMap, _cache) <- getConfigCache ee task installedMap False True
withSingleContext ac ee task allDepsMap (Just "bench") $ \_package _cabalfp _pkgDir cabal announce _outputType -> do
let args = map T.unpack benchesToRun <> maybe []
((:[]) . ("--benchmark-options=" <>))
(beoAdditionalArgs beopts)
toRun <-
if beoDisableRun beopts
then do
announce "Benchmark running disabled by --no-run-benchmarks flag."
pure False
else do
pure True
when toRun $ do
announce "benchmarks"
cabal CloseOnException KeepTHLoading ("bench" : args)
data ExcludeTHLoading = ExcludeTHLoading | KeepTHLoading
data ConvertPathsToAbsolute = ConvertPathsToAbsolute | KeepPathsAsIs
-- | special marker for expected failures in curator builds, using those
-- we need to keep log handle open as build continues further even after a failure
data KeepOutputOpen = KeepOpen | CloseOnException deriving Eq
-- | Strip Template Haskell "Loading package" lines and making paths absolute.
mungeBuildOutput :: forall m. MonadIO m
=> ExcludeTHLoading -- ^ exclude TH loading?
-> ConvertPathsToAbsolute -- ^ convert paths to absolute?
-> Path Abs Dir -- ^ package's root directory
-> ActualCompiler -- ^ compiler we're building with
-> ConduitM Text Text m ()
mungeBuildOutput excludeTHLoading makeAbsolute pkgDir compilerVer = void $
CT.lines
.| CL.map stripCR
.| CL.filter (not . isTHLoading)
.| filterLinkerWarnings
.| toAbsolute
where
-- | Is this line a Template Haskell "Loading package" line
-- ByteString
isTHLoading :: Text -> Bool
isTHLoading = case excludeTHLoading of
KeepTHLoading -> const False
ExcludeTHLoading -> \bs ->
"Loading package " `T.isPrefixOf` bs &&
("done." `T.isSuffixOf` bs || "done.\r" `T.isSuffixOf` bs)
filterLinkerWarnings :: ConduitM Text Text m ()
filterLinkerWarnings
-- Check for ghc 7.8 since it's the only one prone to producing
-- linker warnings on Windows x64
| getGhcVersion compilerVer >= mkVersion [7, 8] = doNothing
| otherwise = CL.filter (not . isLinkerWarning)
isLinkerWarning :: Text -> Bool
isLinkerWarning str =
("ghc.exe: warning:" `T.isPrefixOf` str || "ghc.EXE: warning:" `T.isPrefixOf` str) &&
"is linked instead of __imp_" `T.isInfixOf` str
-- | Convert GHC error lines with file paths to have absolute file paths
toAbsolute :: ConduitM Text Text m ()
toAbsolute = case makeAbsolute of
KeepPathsAsIs -> doNothing
ConvertPathsToAbsolute -> CL.mapM toAbsolutePath
toAbsolutePath :: Text -> m Text
toAbsolutePath bs = do
let (x, y) = T.break (== ':') bs
mabs <-
if isValidSuffix y
then liftIO $ liftM (fmap ((T.takeWhile isSpace x <>) . T.pack . toFilePath)) $
forgivingAbsence (resolveFile pkgDir (T.unpack $ T.dropWhile isSpace x)) `catch`
\(_ :: PathException) -> pure Nothing
else pure Nothing
case mabs of
Nothing -> pure bs
Just fp -> pure $ fp `T.append` y
doNothing :: ConduitM Text Text m ()
doNothing = awaitForever yield
-- | Match the error location format at the end of lines
isValidSuffix = isRight . parseOnly lineCol
lineCol = char ':'
>> choice
[ num >> char ':' >> num >> optional (char '-' >> num) >> pure ()
, char '(' >> num >> char ',' >> num >> P.string ")-(" >> num >> char ',' >> num >> char ')' >> pure ()
]
>> char ':'
>> pure ()
where num = some digit
-- | Whether to prefix log lines with timestamps.
data PrefixWithTimestamps = PrefixWithTimestamps | WithoutTimestamps
-- | Write stream of lines to handle, but adding timestamps.
sinkWithTimestamps :: MonadIO m => PrefixWithTimestamps -> Handle -> ConduitT ByteString Void m ()
sinkWithTimestamps prefixWithTimestamps h =
case prefixWithTimestamps of
PrefixWithTimestamps ->
CB.lines .| CL.mapM addTimestamp .| CL.map (<> "\n") .| sinkHandle h
WithoutTimestamps -> sinkHandle h
where
addTimestamp theLine = do
now <- liftIO getZonedTime
pure (formatZonedTimeForLog now <> " " <> theLine)
-- | Format a time in ISO8601 format. We choose ZonedTime over UTCTime
-- because a user expects to see logs in their local time, and would
-- be confused to see UTC time. Stack's debug logs also use the local
-- time zone.
formatZonedTimeForLog :: ZonedTime -> ByteString
formatZonedTimeForLog = S8.pack . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6Q"
-- | Find the Setup.hs or Setup.lhs in the given directory. If none exists,
-- throw an exception.
getSetupHs :: Path Abs Dir -- ^ project directory
-> IO (Path Abs File)
getSetupHs dir = do
exists1 <- doesFileExist fp1
if exists1
then pure fp1
else do
exists2 <- doesFileExist fp2
if exists2
then pure fp2
else throwM $ NoSetupHsFound dir
where
fp1 = dir </> relFileSetupHs
fp2 = dir </> relFileSetupLhs
-- Do not pass `-hpcdir` as GHC option if the coverage is not enabled.
-- This helps running stack-compiled programs with dynamic interpreters like `hint`.
-- Cfr: https://github.com/commercialhaskell/stack/issues/997
extraBuildOptions :: (HasEnvConfig env, HasRunner env)
=> WhichCompiler -> BuildOpts -> RIO env [String]
extraBuildOptions wc bopts = do
colorOpt <- appropriateGhcColorFlag
let optsFlag = compilerOptionsCabalFlag wc
baseOpts = maybe "" (" " ++) colorOpt
if toCoverage (boptsTestOpts bopts)
then do
hpcIndexDir <- toFilePathNoTrailingSep <$> hpcRelativeDir
pure [optsFlag, "-hpcdir " ++ hpcIndexDir ++ baseOpts]
else
pure [optsFlag, baseOpts]
-- Library, internal and foreign libraries and executable build components.
primaryComponentOptions :: Map Text ExecutableBuildStatus -> LocalPackage -> [String]
primaryComponentOptions executableBuildStatuses lp =
-- TODO: get this information from target parsing instead,
-- which will allow users to turn off library building if
-- desired
(case packageLibraries package of
NoLibraries -> []
HasLibraries names ->
map T.unpack
$ T.append "lib:" (T.pack (packageNameString (packageName package)))
: map (T.append "flib:") (Set.toList names)) ++
map (T.unpack . T.append "lib:") (Set.toList $ packageInternalLibraries package) ++
map (T.unpack . T.append "exe:") (Set.toList $ exesToBuild executableBuildStatuses lp)
where
package = lpPackage lp
-- | History of this function:
--
-- * Normally it would do either all executables or if the user
-- specified requested components, just build them. Afterwards, due
-- to this Cabal bug <https://github.com/haskell/cabal/issues/2780>,
-- we had to make Stack build all executables every time.
--
-- * In <https://github.com/commercialhaskell/stack/issues/3229> this
-- was flagged up as very undesirable behavior on a large project,
-- hence the behavior below that we build all executables once
-- (modulo success), and thereafter pay attention to user-wanted
-- components.
--
exesToBuild :: Map Text ExecutableBuildStatus -> LocalPackage -> Set Text
exesToBuild executableBuildStatuses lp =
if cabalIsSatisfied executableBuildStatuses && lpWanted lp
then exeComponents (lpComponents lp)
else packageExes (lpPackage lp)
-- | Do the current executables satisfy Cabal's bugged out requirements?
cabalIsSatisfied :: Map k ExecutableBuildStatus -> Bool
cabalIsSatisfied = all (== ExecutableBuilt) . M.elems
-- Test-suite and benchmark build components.
finalComponentOptions :: LocalPackage -> [String]
finalComponentOptions lp =
map (T.unpack . renderComponent) $
Set.toList $
Set.filter (\c -> isCTest c || isCBench c) (lpComponents lp)
taskComponents :: Task -> Set NamedComponent
taskComponents task =
case taskType task of
TTLocalMutable lp -> lpComponents lp -- FIXME probably just want lpWanted
TTRemotePackage{} -> Set.empty
expectTestFailure :: PackageName -> Maybe Curator -> Bool
expectTestFailure pname mcurator =
maybe False (Set.member pname . curatorExpectTestFailure) mcurator
expectBenchmarkFailure :: PackageName -> Maybe Curator -> Bool
expectBenchmarkFailure pname mcurator =
maybe False (Set.member pname . curatorExpectBenchmarkFailure) mcurator
fulfillCuratorBuildExpectations ::
(HasLogFunc env, HasCallStack)
=> PackageName
-> Maybe Curator
-> Bool
-> Bool
-> b
-> RIO env b
-> RIO env b
fulfillCuratorBuildExpectations pname mcurator enableTests _ defValue action | enableTests &&
expectTestFailure pname mcurator = do
eres <- tryAny action
case eres of
Right res -> do
logWarn $ fromString (packageNameString pname) <> ": unexpected test build success"
pure res
Left _ -> pure defValue
fulfillCuratorBuildExpectations pname mcurator _ enableBench defValue action | enableBench &&
expectBenchmarkFailure pname mcurator = do
eres <- tryAny action
case eres of
Right res -> do
logWarn $ fromString (packageNameString pname) <> ": unexpected benchmark build success"
pure res
Left _ -> pure defValue
fulfillCuratorBuildExpectations _ _ _ _ _ action = do
action