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           Distribution.Version ( mkVersion )
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 (..), RunCabalWithArgs
                   )
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
                   , getGhcVersion, 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
                   ( DepLibrary (..), DepType (..), 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
                   , toCabalMungedPackageName
                   )
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 )
import           System.Semaphore
                   ( Semaphore, destroySemaphore, freshSemaphore )

-- | 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
  , semaphore :: !(Maybe Semaphore)
    -- ^ The semaphore that is used for job control, if --semaphore is given
  }

-- | 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

semaphorePrefix :: String
semaphorePrefix = "stack"

-- | 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)
      compilerVersion <- view actualCompilerVersionL
      let ghcVersion = getGhcVersion compilerVersion
      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"
      jobs <- view $ configL . to (.jobs)
      let semaphoreSupported =
               (cabalPkgVer >= mkVersion [3, 12, 0, 0])
            && (ghcVersion >= mkVersion [9, 8, 1])
          semaphoreUnsupportedWarning =
            prettyWarnL
              [ "The"
              , style Shell "--semaphore"
              , flow "flag was specified, which is supported by GHC 9.8.1 or \
                     \later with Cabal 3.12.0.0 (a boot package of GHC 9.10.1) \
                     \or later. GHC version"
              , fromString (versionString ghcVersion)
              , flow "and Cabal version"
              , fromString (versionString cabalPkgVer)
              , flow "was found. The flag will be ignored."
              ]
      semaphore <- if not buildOpts.semaphore
        then pure Nothing
        else if semaphoreSupported
          then Just <$> liftIO (freshSemaphore semaphorePrefix jobs)
          else semaphoreUnsupportedWarning >> pure Nothing
      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
        , semaphore
        } `finally` do
          liftIO (whenJust semaphore destroySemaphore)
          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 MungedPackageId GhcPkgId
     -- ^ Ids of Installed packages that are assumed to be available to build a
     -- package's custom @Setup.hs@, given its dependencies specified in its
     -- @custom-setup@ stanza of its Cabal file.
  -> Maybe String
     -- ^ An optional suffix for the build log's file name.
  -> (  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`.
     -> RunCabalWithArgs env
        -- Function to run Cabal (the library) with arguments.
     -> (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
    -> (  RunCabalWithArgs env
          -- Function to run Cabal (the library) with arguments.
       -> 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
    distDir' <- distDirFromDir pkgDir
    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 mungedPkgNames = depToMungedPkgNames name depValue
                        countMungedPkgNames = Set.size mungedPkgNames
                        matches (MungedPackageId mungedPkgName version) _ =
                             mungedPkgName `Set.member` mungedPkgNames
                          && version `withinRange` depValue.versionRange
                    case Map.filterWithKey matches allDeps of
                      matchedDeps | Map.null matchedDeps -> do
                        prettyWarnL
                          [ flow "Could not find custom-setup dep:"
                          , style Current (fromPackageName name) <> "."
                          ]
                        pure (["-package=" <> packageNameString name], Nothing)
                      matchedDeps -> do
                        let groupMatchedByVersion =
                              Map.foldlWithKey'
                                ( \acc k v ->
                                    let p = mungedVersion k
                                        innerMap = Map.singleton k v
                                    in  Map.insertWith Map.union p innerMap acc
                                )
                                Map.empty
                                matchedDeps
                            countMatchedDeps = Map.size matchedDeps
                        if Map.size groupMatchedByVersion == 1
                          then do
                            when (countMatchedDeps < countMungedPkgNames) $
                              prettyWarnL
                                [ flow "Found insufficent installed packages \
                                       \for custom-setup dep:"
                                , style Current (fromPackageName name) <> "."
                                ]
                          else do
                            prettyWarnL
                              [ flow "Found installed packages with multiple \
                                     \versions for custom-setup dep:"
                              , style Current (fromPackageName name) <> "."
                              ]
                        let packageIdOpt ghcPkgId =
                              "-package-id=" <> ghcPkgIdString ghcPkgId
                            -- The previous algorithm (arbitrarily?) selected
                            -- the first relevant item yielded by Map.toList
                            -- (which is Map.toAscList), so we select the
                            -- minimum:
                            selectedGroup = Map.findMin groupMatchedByVersion
                            selectedVersion = fst selectedGroup
                            packageIdOpts =
                              map packageIdOpt $ Map.elems $ snd selectedGroup
                            selectedPkgId =
                              PackageIdentifier name selectedVersion
                        pure (packageIdOpts, Just selectedPkgId)
                let depsArgs = L.concatMap 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 distDir') : args

          depToMungedPkgNames ::
               PackageName
               -- ^ The name of the Cabal package.
            -> DepValue
               -- ^ The dependency value for that package.
            -> Set.Set MungedPackageName
          depToMungedPkgNames pkgName depValue
            | AsLibrary depLibrary <- depValue.depType =
                let addMain = if depLibrary.main
                      then Set.insert mungedMainPkgName
                      else id
                    mungedMainPkgName = toCabalMungedPackageName pkgName Nothing
                    subLibSet =
                      Set.map
                        (toCabalMungedPackageName pkgName . Just)
                        depLibrary.subLib
                in  addMain subLibSet
            | otherwise = Set.empty

          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