stack-3.9.1: src/Stack/Build/ExecuteEnv.hs
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NoFieldSelectors #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-|
Module : Stack.Build.ExecuteEnv
License : BSD-3-Clause
Provides all the necessary types and functions for running cabal Setup.hs
commands. Only used in the "Execute" and "ExecutePackage" modules.
-}
module Stack.Build.ExecuteEnv
( ExecuteEnv (..)
, withExecuteEnv
, withSingleContext
, ExcludeTHLoading (..)
, KeepOutputOpen (..)
, OutputType (..)
) where
import Control.Concurrent.Companion ( Companion, withCompanion )
import Control.Concurrent.Execute
( ActionContext (..), ActionId (..), Concurrency (..) )
import Control.Monad.Extra ( whenJust )
import Crypto.Hash ( SHA256 (..), hashWith )
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.Base64.URL as B64URL
import qualified Data.ByteString.Builder ( toLazyByteString )
import qualified Data.ByteString.Char8 as S8
import Data.Char ( isSpace )
import Conduit
( ConduitT, awaitForever, sinkHandle, withSinkFile
, withSourceFile, yield
)
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import qualified Data.Conduit.Text as CT
import qualified Data.List as L
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.Time
( ZonedTime, defaultTimeLocale, formatTime, getZonedTime )
import qualified Distribution.PackageDescription as C
import qualified Distribution.Simple.Build.Macros as C
import Distribution.System ( OS (..), Platform (..) )
import Distribution.Types.PackageName ( mkPackageName )
import Distribution.Verbosity ( showForCabal )
import Path
( PathException, (</>), parent, parseRelDir, parseRelFile )
import Path.Extra ( forgivingResolveFile, toFilePathNoTrailingSep )
import Path.IO
( doesDirExist, doesFileExist, ensureDir, ignoringAbsence
, removeFile, renameDir, renameFile
)
import RIO.Process
( eceExitCode, proc, runProcess_, setStdout, useHandleOpen
, withWorkingDir
)
import Stack.Config ( checkOwnership )
import Stack.Constants
( cabalPackageName, relDirDist, relDirSetup
, relDirSetupExeCache, relDirSetupExeSrc, relFileBuildLock
, relFileSetupHs, relFileSetupLhs, relFileSetupLower
, relFileSetupMacrosH, setupGhciShimCode, stackProgName
)
import Stack.Constants.Config ( distDirFromDir, distRelativeDir )
import Stack.Package ( buildLogPath )
import Stack.Prelude
import Stack.Types.ApplyGhcOptions ( ApplyGhcOptions (..) )
import Stack.Types.Build
( ConvertPathsToAbsolute (..), ExcludeTHLoading (..)
, KeepOutputOpen (..)
)
import Stack.Types.Build.Exception
( BuildException (..), BuildPrettyException (..) )
import Stack.Types.BuildOpts ( BuildOpts (..) )
import Stack.Types.BuildOptsCLI ( BuildOptsCLI (..) )
import Stack.Types.BuildOptsMonoid ( CabalVerbosity (..) )
import Stack.Types.Compiler
( WhichCompiler (..), compilerVersionString, whichCompilerL )
import Stack.Types.CompilerPaths
( CompilerPaths (..), HasCompiler (..), cabalVersionL
, getCompilerPath
)
import Stack.Types.Config
( Config (..), HasConfig (..), stackRootL )
import Stack.Types.ConfigureOpts ( BaseConfigOpts (..) )
import Stack.Types.Dependency ( DepValue(..) )
import Stack.Types.DumpLogs ( DumpLogs (..) )
import Stack.Types.DumpPackage ( DumpPackage (..) )
import Stack.Types.EnvConfig
( HasEnvConfig (..), actualCompilerVersionL
, platformGhcRelDir, shouldForceGhcColorFlag
)
import Stack.Types.EnvSettings ( EnvSettings (..) )
import Stack.Types.GhcPkgId ( GhcPkgId, ghcPkgIdString )
import Stack.Types.Installed ( InstallLocation (..), Installed (..) )
import Stack.Types.Package
( LocalPackage (..), Package (..), packageIdentifier )
import Stack.Types.Plan
( TaskType (..), taskTypeLocation, taskTypePackageIdentifier
)
import Stack.Types.Platform ( HasPlatform (..) )
import Stack.Types.Version ( withinRange )
import qualified System.Directory as D
import System.Environment ( lookupEnv )
import System.FileLock
( SharedExclusive (..), withFileLock, withTryFileLock )
-- | Type representing environments in which the @Setup.hs@ commands of Cabal
-- (the library) can be executed.
data ExecuteEnv = ExecuteEnv
{ installLock :: !(MVar ())
, buildOpts :: !BuildOpts
, buildOptsCLI :: !BuildOptsCLI
, baseConfigOpts :: !BaseConfigOpts
, ghcPkgIds :: !(TVar (Map PackageIdentifier Installed))
, tempDir :: !(Path Abs Dir)
, setupHs :: !(Path Abs File)
-- ^ Temporary Setup.hs for simple builds
, setupShimHs :: !(Path Abs File)
-- ^ Temporary SetupShim.hs, to provide access to initial-build-steps
, setupExe :: !(Maybe (Path Abs File))
-- ^ Compiled version of eeSetupHs
, cabalPkgVer :: !Version
-- ^ The version of the compiler's Cabal boot package.
, totalWanted :: !Int
, locals :: ![LocalPackage]
, globalDB :: !(Path Abs Dir)
, globalDumpPkgs :: !(Map GhcPkgId DumpPackage)
, snapshotDumpPkgs :: !(TVar (Map GhcPkgId DumpPackage))
, localDumpPkgs :: !(TVar (Map GhcPkgId DumpPackage))
, logFiles :: !(TChan (Path Abs Dir, Path Abs File))
, customBuilt :: !(IORef (Set PackageName))
-- ^ Stores which packages with custom-setup have already had their
-- Setup.hs built.
, largestPackageName :: !(Maybe Int)
-- ^ For nicer interleaved output: track the largest package name size
, pathEnvVar :: !Text
-- ^ Value of the PATH environment variable
}
-- | Type representing setup executable circumstances.
data SetupExe
= SimpleSetupExe !(Path Abs File)
-- ^ The build type is Simple and there is a path to an existing setup
-- executable.
| OtherSetupHs !(Path Abs File)
-- ^ Other circumstances with a path to the source code for the setup
-- executable.
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 ->
prettyThrowM $ SetupHsBuildFailure
(eceExitCode ece) Nothing compilerPath args Nothing []
renameFile tmpExePath exePath
pure $ Just exePath
-- | Execute a function that takes an t'ExecuteEnv'.
withExecuteEnv ::
forall env a. HasEnvConfig env
=> BuildOpts
-> BuildOptsCLI
-> BaseConfigOpts
-> [LocalPackage]
-> [DumpPackage]
-- ^ global packages
-> [DumpPackage]
-- ^ snapshot packages
-> [DumpPackage]
-- ^ project packages and local extra-deps
-> Maybe Int
-- ^ largest package name, for nicer interleaved output
-> (ExecuteEnv -> RIO env a)
-> RIO env a
withExecuteEnv
buildOpts
buildOptsCLI
baseConfigOpts
locals
globalPackages
snapshotPackages
localPackages
largestPackageName
inner
= createTempDirFunction stackProgName $ \tempDir -> do
installLock <- liftIO $ newMVar ()
ghcPkgIds <- liftIO $ newTVarIO Map.empty
config <- view configL
customBuilt <- newIORef Set.empty
-- Create files for simple setup and setup shim, if necessary
let setupSrcDir =
view stackRootL config </>
relDirSetupExeSrc
ensureDir setupSrcDir
let setupStub = "setup-" ++ simpleSetupHash
setupFileName <- parseRelFile (setupStub ++ ".hs")
setupHiName <- parseRelFile (setupStub ++ ".hi")
setupOName <- parseRelFile (setupStub ++ ".o")
let setupHs = setupSrcDir </> setupFileName
setupHi = setupSrcDir </> setupHiName
setupO = setupSrcDir </> setupOName
setupHsExists <- doesFileExist setupHs
unless setupHsExists $ writeBinaryFileAtomic setupHs simpleSetupCode
let setupShimStub = "setup-shim-" ++ simpleSetupHash
setupShimFileName <- parseRelFile (setupShimStub ++ ".hs")
setupShimHiName <- parseRelFile (setupShimStub ++ ".hi")
setupShimOName <- parseRelFile (setupShimStub ++ ".o")
let setupShimHs = setupSrcDir </> setupShimFileName
setupShimHi = setupSrcDir </> setupShimHiName
setupShimO = setupSrcDir </> setupShimOName
setupShimHsExists <- doesFileExist setupShimHs
unless setupShimHsExists $
writeBinaryFileAtomic setupShimHs setupGhciShimCode
setupExe <- getSetupExe setupHs setupShimHs tempDir
-- See https://github.com/commercialhaskell/stack/issues/6267. Remove any
-- historical *.hi or *.o files. This can be dropped when Stack drops
-- support for the problematic versions of GHC.
ignoringAbsence (removeFile setupHi)
ignoringAbsence (removeFile setupO)
ignoringAbsence (removeFile setupShimHi)
ignoringAbsence (removeFile setupShimO)
cabalPkgVer <- view cabalVersionL
globalDB <- view $ compilerPathsL . to (.globalDB)
let globalDumpPkgs = toDumpPackagesByGhcPkgId globalPackages
snapshotDumpPkgs <-
liftIO $ newTVarIO (toDumpPackagesByGhcPkgId snapshotPackages)
localDumpPkgs <-
liftIO $ newTVarIO (toDumpPackagesByGhcPkgId localPackages)
logFiles <- liftIO $ atomically newTChan
let totalWanted = length $ filter (.wanted) locals
pathEnvVar <- liftIO $ maybe mempty T.pack <$> lookupEnv "PATH"
inner ExecuteEnv
{ buildOpts
, buildOptsCLI
-- 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.
, installLock
, baseConfigOpts
, ghcPkgIds
, tempDir
, setupHs
, setupShimHs
, setupExe
, cabalPkgVer
, totalWanted
, locals
, globalDB
, globalDumpPkgs
, snapshotDumpPkgs
, localDumpPkgs
, logFiles
, customBuilt
, largestPackageName
, pathEnvVar
} `finally` dumpLogs logFiles totalWanted
where
toDumpPackagesByGhcPkgId = Map.fromList . map (\dp -> (dp.ghcPkgId, dp))
createTempDirFunction
| buildOpts.keepTmpFiles = 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
view (configL . to (.dumpLogs)) >>= \case
DumpAllLogs -> mapM_ (dumpLog "") allLogs
DumpWarningLogs -> mapM_ dumpLogIfWarning allLogs
DumpNoLogs
| totalWanted > 1 ->
prettyInfoL
[ flow "Build output has been captured to log files, use"
, style Shell "--dump-logs"
, flow "to see it on the console."
]
| otherwise -> pure ()
prettyInfoL
[ flow "Log files have been written to:"
, pretty (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 =
tryReadTChan chan >>= \case
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
prettyNote $
fillSep
( ( fillSep
( flow "Dumping log file"
: [ flow msgSuffix | not (L.null msgSuffix) ]
)
<> ":"
)
: [ pretty filepath <> "." ]
)
<> line
withSourceFile (toFilePath filepath) $ \src ->
runConduit
$ src
.| CT.decodeUtf8Lenient
.| mungeBuildOutput ExcludeTHLoading ConvertPathsToAbsolute pkgDir
.| CL.mapM_ (logInfo . display)
prettyNote $
fillSep
[ flow "End of log file:"
, pretty filepath <> "."
]
<> line
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
whenJust mnext $ \x -> assert (x == 27) $ do
-- Color sequences always end with an m
CB.dropWhile (/= 109) -- m
CB.drop 1 -- drop the m itself
noColors
-- | Make a padded prefix for log messages
packageNamePrefix :: ExecuteEnv -> PackageName -> String
packageNamePrefix ee name' =
let name = packageNameString name'
paddedName =
case ee.largestPackageName of
Nothing -> name
Just len ->
assert (len >= length name) $ take len $ name ++ L.repeat ' '
in paddedName <> "> "
announceTask ::
HasLogFunc env
=> ExecuteEnv
-> TaskType
-> Utf8Builder
-> RIO env ()
announceTask ee taskType action = logInfo $
fromString
(packageNamePrefix ee (pkgName (taskTypePackageIdentifier taskType)))
<> action
prettyAnnounceTask ::
HasTerm env
=> ExecuteEnv
-> TaskType
-> StyleDoc
-> RIO env ()
prettyAnnounceTask ee taskType action = prettyInfo $
fromString
(packageNamePrefix ee (pkgName (taskTypePackageIdentifier taskType)))
<> action
-- | Ensure we're the only action using the directory. See
-- <https://github.com/commercialhaskell/stack/issues/2730>
withLockedDistDir ::
forall env a. HasEnvConfig env
=> (StyleDoc -> RIO env ())
-- ^ A pretty announce function
-> 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 :: Companion (RIO env)
complainer delay = do
delay 5000000 -- 5 seconds
announce $ fillSep
[ flow "blocking for directory lock on"
, pretty lockFP
]
forever $ do
delay 30000000 -- 30 seconds
announce $ fillSep
[ flow "still blocking for directory lock on"
, pretty lockFP <> ";"
, flow "maybe another Stack process is running?"
]
withCompanion complainer $
\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
-> TaskType
-> 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 plain 'announce' function, for different build phases
-> OutputType
-> RIO env a)
-> RIO env a
withSingleContext
ac
ee
taskType
allDeps
msuffix
inner0
= withPackage $ \package cabalFP pkgDir ->
withOutputType pkgDir package $ \outputType ->
withCabal package pkgDir outputType $ \cabal ->
inner0 package cabalFP pkgDir cabal announce outputType
where
pkgId = taskTypePackageIdentifier taskType
announce = announceTask ee taskType
prettyAnnounce = prettyAnnounceTask ee taskType
wanted =
case taskType of
TTLocalMutable lp -> lp.wanted
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 == pkgId)
(Set.toList ac.remaining)
&& ee.totalWanted == 1
)
|| ac.concurrency == ConcurrencyDisallowed
withPackage inner =
case taskType of
TTLocalMutable lp -> do
let root = parent lp.cabalFP
withLockedDistDir prettyAnnounce root $
inner lp.package lp.cabalFP root
TTRemotePackage _ package pkgloc -> do
suffix <-
parseRelDir $ packageIdentifierString $ packageIdentifier package
let dir = ee.tempDir </> 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 pkgId
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.
| ee.buildOpts.interleavedOutput = inner $
OTConsole $ Just $ fromString (packageNamePrefix ee package.name)
-- 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 | lp.wanted ->
liftIO $ atomically $ writeTChan ee.logFiles (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 config.allowDifferentUser $
checkOwnership (pkgDir </> config.workDir)
let envSettings = EnvSettings
{ includeLocals = taskTypeLocation taskType == Local
, includeGhcPackagePath = False
, stackExe = False
, localeUtf8 = True
, keepGhcRts = False
}
menv <- liftIO $ config.processContextSettings envSettings
distRelativeDir' <- distRelativeDir
setupexehs <-
-- Avoid broken Setup.hs files causing problems for simple build
-- types, see:
-- https://github.com/commercialhaskell/stack/issues/370
case (package.buildType, ee.setupExe) of
(C.Simple, Just setupExe) -> pure $ SimpleSetupExe setupExe
_ -> liftIO $ OtherSetupHs <$> getSetupHs pkgDir
inner $ \keepOutputOpen stripTHLoading args -> do
let cabalPackageArg
-- Omit cabal package dependency when building
-- Cabal. See
-- https://github.com/commercialhaskell/stack/issues/1356
| package.name == mkPackageName "Cabal" = []
| otherwise =
["-package=" ++ packageIdentifierString
(PackageIdentifier cabalPackageName
ee.cabalPkgVer)]
packageDBArgs =
( "-clear-package-db"
: "-global-package-db"
: map
(("-package-db=" ++) . toFilePathNoTrailingSep)
ee.baseConfigOpts.extraDBs
) ++
( ( "-package-db="
++ toFilePathNoTrailingSep ee.baseConfigOpts.snapDB
)
: ( "-package-db="
++ toFilePathNoTrailingSep ee.baseConfigOpts.localDB
)
: ["-hide-all-packages"]
)
warnCustomNoDeps :: RIO env ()
warnCustomNoDeps =
case (taskType, package.buildType) of
(TTLocalMutable lp, C.Custom) | lp.wanted ->
prettyWarnL
[ flow "Package"
, fromPackageName package.name
, 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 package.setupDeps 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
cabalPackageArg' <-
if Map.member (mkPackageName "Cabal") customSetupDeps
then pure []
else do
prettyWarnL
[ style Current (fromPackageName package.name)
, flow "has a"
, style Shell "setup-depends"
, flow "field, but it does not mention a"
, style Current "Cabal"
, flow "dependency. Stack customizes setup using \
\Cabal, so it has added the GHC boot package as \
\a dependency."
]
pure cabalPackageArg
matchedDeps <-
forM (Map.toList customSetupDeps) $ \(name, depValue) -> do
let matches (PackageIdentifier name' version) =
name == name'
&& version `withinRange` depValue.versionRange
case filter (matches . fst) (Map.toList allDeps) of
x:xs -> do
unless (null xs) $
prettyWarnL
[ flow "Found multiple installed packages for \
\custom-setup dep:"
, style Current (fromPackageName name) <> "."
]
pure ("-package-id=" ++ ghcPkgIdString (snd x), Just (fst x))
[] -> do
prettyWarnL
[ flow "Could not find custom-setup dep:"
, style Current (fromPackageName 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
package.version
macroDeps
)
)
)
pure (packageDBArgs ++ depsArgs ++ cabalPackageArg' ++ 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
let packageDBArgs' = case package.buildType of
-- The Configure build type is very similar to Simple. As
-- such, Stack builds the setup executable in much the
-- same way as it would in the case of Simple.
C.Configure ->
[ "-hide-all-packages"
, "-package base"
]
-- 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
_ ->
map
(("-package-db=" ++) . toFilePathNoTrailingSep)
ee.baseConfigOpts.extraDBs
<> [ "-package-db="
<> toFilePathNoTrailingSep ee.baseConfigOpts.snapDB
]
pure $
[ "-clear-package-db"
, "-global-package-db"
]
<> packageDBArgs'
<> cabalPackageArg
setupArgs =
("--builddir=" ++ toFilePathNoTrailingSep distRelativeDir') : args
runExe :: Path Abs File -> [String] -> RIO env ()
runExe exeName fullArgs = do
runAndOutput `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
.| CL.consume
prettyThrowM $ CabalExitedUnsuccessfully
(eceExitCode ece) pkgId exeName fullArgs mlogFile bss
where
runAndOutput :: RIO env ()
runAndOutput = withWorkingDir (toFilePath pkgDir) $
withProcessContext menv $ case outputType of
OTLogFile _ h -> do
let prefixWithTimestamps =
if config.prefixTimestamps
then PrefixWithTimestamps
else WithoutTimestamps
void $ sinkProcessStderrStdout (toFilePath exeName) fullArgs
(sinkWithTimestamps prefixWithTimestamps h)
(sinkWithTimestamps prefixWithTimestamps h)
OTConsole mprefix ->
let prefix = fromMaybe mempty mprefix
in void $ sinkProcessStderrStdout
(toFilePath exeName)
fullArgs
(outputSink KeepTHLoading LevelWarn prefix)
(outputSink stripTHLoading LevelInfo prefix)
outputSink ::
HasCallStack
=> ExcludeTHLoading
-> LogLevel
-> Utf8Builder
-> ConduitM S.ByteString Void (RIO env) ()
outputSink excludeTH level prefix =
CT.decodeUtf8Lenient
.| mungeBuildOutput excludeTH makeAbsolute pkgDir
.| 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 setupexehs of
SimpleSetupExe setupExe -> pure setupExe
OtherSetupHs setuphs -> do
distDir <- distDirFromDir pkgDir
let setupDir = distDir </> relDirSetup
outputFile = setupDir </> relFileSetupLower
customBuilt <- liftIO $ readIORef ee.customBuilt
if Set.member package.name customBuilt
then pure outputFile
else do
ensureDir setupDir
compilerPath <- view $ compilerPathsL . to (.compiler)
packageArgs <- getPackageArgs setupDir
runExe compilerPath $
[ "--make"
, "-odir", toFilePathNoTrailingSep setupDir
, "-hidir", toFilePathNoTrailingSep setupDir
, "-i", "-i."
]
<> packageArgs
<> [ toFilePath setuphs
, toFilePath ee.setupShimHs
, "-main-is"
, "StackSetupShim.mainOverride"
, "-o", toFilePath outputFile
, "-threaded"
]
-- Apply GHC options
-- https://github.com/commercialhaskell/stack/issues/4526
<> map
T.unpack
( Map.findWithDefault
[]
AGOEverything
config.ghcOptionsByCat
<> case config.applyGhcOptions of
AGOEverything -> ee.buildOptsCLI.ghcOptions
AGOTargets -> []
AGOLocals -> []
)
liftIO $ atomicModifyIORef' ee.customBuilt $
\oldCustomBuilt ->
(Set.insert package.name oldCustomBuilt, ())
pure outputFile
let cabalVerboseArg =
let CabalVerbosity cv = ee.buildOpts.cabalVerbose
in "--verbose=" <> showForCabal cv
runExe exeName $ cabalVerboseArg:setupArgs
-- | Strip Template Haskell "Loading package" lines and making paths absolute.
mungeBuildOutput ::
forall m. (MonadIO m, MonadUnliftIO m)
=> ExcludeTHLoading
-- ^ exclude TH loading?
-> ConvertPathsToAbsolute
-- ^ convert paths to absolute?
-> Path Abs Dir
-- ^ package's root directory
-> ConduitM Text Text m ()
mungeBuildOutput excludeTHLoading makeAbsolute pkgDir = 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
doNothing
-- | 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
fmap (fmap ((T.takeWhile isSpace x <>) . T.pack . toFilePath)) $
forgivingResolveFile 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