module Hix.Managed.Handlers.Build.Prod where

import Control.Monad.Catch (catch)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader (ask, asks)
import Control.Monad.Trans.State.Strict (StateT (runStateT), gets, modify')
import qualified Data.ByteString.Char8 as ByteString
import Data.List.Extra (firstJust)
import qualified Data.Set as Set
import Exon (exon)
import Network.HTTP.Client (newManager)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Path (Abs, Dir, Path, toFilePath)
import Path.IO (copyDirRecur')
import System.IO (BufferMode (LineBuffering), Handle, hSetBuffering)
import System.IO.Error (IOError, tryIOError)
import System.Process.Typed (
  ExitCode (ExitFailure, ExitSuccess),
  ProcessConfig,
  createPipe,
  getStderr,
  inherit,
  nullStream,
  proc,
  setStderr,
  setStdout,
  setWorkingDir,
  waitExitCode,
  withProcessTerm,
  )
import System.Timeout (timeout)

import Hix.Class.Map (nInsert, nMember)
import Hix.Data.EnvName (EnvName)
import Hix.Data.Error (Error (Fatal))
import qualified Hix.Data.Monad
import Hix.Data.Monad (M (M))
import Hix.Data.Overrides (Overrides)
import qualified Hix.Data.PackageId
import Hix.Data.PackageId (PackageId)
import Hix.Data.PackageName (LocalPackage)
import Hix.Data.Version (Versions)
import Hix.Error (pathText)
import Hix.Hackage (latestVersionHackage, versionsHackage)
import qualified Hix.Log as Log
import Hix.Managed.Build.NixOutput (OutputResult (OutputResult), PackageDerivation (..), outputParse, runOutputState)
import Hix.Managed.Build.NixOutput.Analysis (analyzeLog)
import Hix.Managed.Cabal.Data.Config (CabalConfig)
import qualified Hix.Managed.Data.BuildConfig
import Hix.Managed.Data.BuildConfig (BuildConfig)
import Hix.Managed.Data.EnvConfig (EnvConfig)
import qualified Hix.Managed.Data.EnvContext
import Hix.Managed.Data.EnvContext (EnvContext)
import Hix.Managed.Data.EnvState (EnvState)
import Hix.Managed.Data.Envs (Envs)
import Hix.Managed.Data.Initial (Initial)
import Hix.Managed.Data.StageState (BuildFailure (..), BuildResult (..), buildUnsuccessful)
import qualified Hix.Managed.Data.StateFileConfig
import Hix.Managed.Data.StateFileConfig (StateFileConfig)
import Hix.Managed.Data.Targets (firstMTargets)
import qualified Hix.Managed.Handlers.Build
import Hix.Managed.Handlers.Build (BuildHandlers (..), BuildOutputsPrefix, Builder (Builder), EnvBuilder (EnvBuilder))
import Hix.Managed.Handlers.Cabal (CabalHandlers)
import qualified Hix.Managed.Handlers.Cabal.Prod as CabalHandlers
import Hix.Managed.Handlers.Hackage (HackageHandlers)
import qualified Hix.Managed.Handlers.Hackage.Prod as HackageHandlers
import qualified Hix.Managed.Handlers.Report.Prod as ReportHandlers
import Hix.Managed.Handlers.StateFile (StateFileHandlers)
import qualified Hix.Managed.Handlers.StateFile.Prod as StateFileHandlers
import Hix.Managed.Overrides (packageOverride, packageOverrides)
import Hix.Managed.Path (rootOrCwd)
import Hix.Managed.StateFile (writeBuildStateFor, writeInitialEnvState)
import Hix.Monad (runMUsing, throwM, tryIOM, withTempDir)
import Hix.Pretty (showP)

data BuilderResources =
  BuilderResources {
    BuilderResources -> HackageHandlers
hackage :: HackageHandlers,
    BuilderResources -> StateFileHandlers
stateFileHandlers :: StateFileHandlers,
    BuilderResources -> Envs EnvConfig
envsConf :: Envs EnvConfig,
    BuilderResources -> Maybe BuildOutputsPrefix
buildOutputsPrefix :: Maybe BuildOutputsPrefix,
    BuilderResources -> Path Abs Dir
root :: Path Abs Dir,
    BuilderResources -> BuildConfig
buildConfig :: BuildConfig
  }

data EnvBuilderResources =
  EnvBuilderResources {
    EnvBuilderResources -> BuilderResources
global :: BuilderResources,
    EnvBuilderResources -> EnvContext
context :: EnvContext
  }

withTempProject ::
  Maybe (Path Abs Dir) ->
  (Path Abs Dir -> M a) ->
  M a
withTempProject :: forall a. Maybe (Path Abs Dir) -> (Path Abs Dir -> M a) -> M a
withTempProject Maybe (Path Abs Dir)
rootOverride Path Abs Dir -> M a
use = do
  Path Abs Dir
projectRoot <- Maybe (Path Abs Dir) -> M (Path Abs Dir)
rootOrCwd Maybe (Path Abs Dir)
rootOverride
  M a -> (IOError -> M a) -> M a
forall e a. (HasCallStack, Exception e) => M a -> (e -> M a) -> M a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
catch
    do
      String -> (Path Abs Dir -> M a) -> M a
forall a. String -> (Path Abs Dir -> M a) -> M a
withTempDir String
"managed-build" \ Path Abs Dir
tmpRoot -> do
        Path Abs Dir -> Path Abs Dir -> M ()
forall (m :: * -> *) b0 b1.
(MonadIO m, MonadCatch m) =>
Path b0 Dir -> Path b1 Dir -> m ()
copyDirRecur' Path Abs Dir
projectRoot Path Abs Dir
tmpRoot
        Path Abs Dir -> M a
use Path Abs Dir
tmpRoot
    \ (IOError
err :: IOError) -> Error -> M a
forall a. Error -> M a
throwM (Text -> Error
Fatal (IOError -> Text
forall b a. (Show a, IsString b) => a -> b
show IOError
err))

data OutputConfig =
  OutputDebug
  |
  OutputParse
  |
  OutputIgnore

data NixProcResult =
  NixProcSuccess [Text]
  |
  NixProcFailure Text
  deriving stock (NixProcResult -> NixProcResult -> Bool
(NixProcResult -> NixProcResult -> Bool)
-> (NixProcResult -> NixProcResult -> Bool) -> Eq NixProcResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NixProcResult -> NixProcResult -> Bool
== :: NixProcResult -> NixProcResult -> Bool
$c/= :: NixProcResult -> NixProcResult -> Bool
/= :: NixProcResult -> NixProcResult -> Bool
Eq, Int -> NixProcResult -> ShowS
[NixProcResult] -> ShowS
NixProcResult -> String
(Int -> NixProcResult -> ShowS)
-> (NixProcResult -> String)
-> ([NixProcResult] -> ShowS)
-> Show NixProcResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NixProcResult -> ShowS
showsPrec :: Int -> NixProcResult -> ShowS
$cshow :: NixProcResult -> String
show :: NixProcResult -> String
$cshowList :: [NixProcResult] -> ShowS
showList :: [NixProcResult] -> ShowS
Show, (forall x. NixProcResult -> Rep NixProcResult x)
-> (forall x. Rep NixProcResult x -> NixProcResult)
-> Generic NixProcResult
forall x. Rep NixProcResult x -> NixProcResult
forall x. NixProcResult -> Rep NixProcResult x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NixProcResult -> Rep NixProcResult x
from :: forall x. NixProcResult -> Rep NixProcResult x
$cto :: forall x. Rep NixProcResult x -> NixProcResult
to :: forall x. Rep NixProcResult x -> NixProcResult
Generic)

outputLines ::
  MonadIO m =>
  (ByteString -> m ()) ->
  Handle ->
  m (Maybe Text)
outputLines :: forall (m :: * -> *).
MonadIO m =>
(ByteString -> m ()) -> Handle -> m (Maybe Text)
outputLines ByteString -> m ()
parse Handle
handle = do
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> BufferMode -> IO ()
hSetBuffering Handle
handle BufferMode
LineBuffering)
  ByteString -> m (Maybe Text)
spin ByteString
forall a. Monoid a => a
mempty
  where
    spin :: ByteString -> m (Maybe Text)
spin ByteString
buf = do
      IO (Either IOError ByteString) -> m (Either IOError ByteString)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> IO (Either IOError ByteString)
forall a. IO a -> IO (Either IOError a)
tryIOError (Handle -> Int -> IO ByteString
ByteString.hGet Handle
handle Int
4096)) m (Either IOError ByteString)
-> (Either IOError ByteString -> m (Maybe Text)) -> m (Maybe Text)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left IOError
err -> Maybe Text -> m (Maybe Text)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe Text
forall a. a -> Maybe a
Just (IOError -> Text
forall b a. (Show a, IsString b) => a -> b
show IOError
err))
        Right ByteString
new ->
          Maybe (Maybe Text) -> Maybe Text
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe Text) -> Maybe Text)
-> m (Maybe (Maybe Text)) -> m (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ([ByteString], ByteString)
-> (([ByteString], ByteString) -> m (Maybe Text))
-> m (Maybe (Maybe Text))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (ByteString -> ByteString -> Maybe ([ByteString], ByteString)
completeLines ByteString
buf ByteString
new) \ ([ByteString]
lns, ByteString
newBuf) -> do
            [ByteString] -> (ByteString -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [ByteString]
lns ByteString -> m ()
parse
            ByteString -> m (Maybe Text)
spin ByteString
newBuf

    completeLines :: ByteString -> ByteString -> Maybe ([ByteString], ByteString)
completeLines = \cases
      -- Empty output means the handle was closed, empty buffer means we can terminate
      ByteString
"" ByteString
"" ->
        Maybe ([ByteString], ByteString)
forall a. Maybe a
Nothing
      -- First iteration after handle was closed, need to emit the last line
      ByteString
buf ByteString
"" ->
        ([ByteString], ByteString) -> Maybe ([ByteString], ByteString)
forall a. a -> Maybe a
Just ([ByteString
Item [ByteString]
buf], ByteString
"")
      ByteString
buf ByteString
new ->
        ([ByteString], ByteString) -> Maybe ([ByteString], ByteString)
forall a. a -> Maybe a
Just ([ByteString] -> ByteString -> ([ByteString], ByteString)
breakNl [] (ByteString
buf ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
new))

    breakNl :: [ByteString] -> ByteString -> ([ByteString], ByteString)
breakNl [ByteString]
acc ByteString
s =
      case (Char -> Bool) -> ByteString -> (ByteString, ByteString)
ByteString.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') ByteString
s of
        (ByteString
rest, ByteString
"") -> ([ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
acc, ByteString
rest)
        (ByteString
ln, ByteString
rest) -> [ByteString] -> ByteString -> ([ByteString], ByteString)
breakNl (ByteString
ln ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
acc) (Int -> ByteString -> ByteString
ByteString.drop Int
1 ByteString
rest)

nixProc ::
  OutputConfig ->
  Path Abs Dir ->
  [Text] ->
  Text ->
  [Text] ->
  M (ProcessConfig () () (Maybe Handle))
nixProc :: OutputConfig
-> Path Abs Dir
-> [Text]
-> Text
-> [Text]
-> M (ProcessConfig () () (Maybe Handle))
nixProc OutputConfig
output Path Abs Dir
root [Text]
cmd Text
installable [Text]
extra = do
  Text -> M ()
Log.debug [exon|Running nix at '#{pathText root}' with args #{show args}|]
  pure ProcessConfig () () (Maybe Handle)
conf
  where
    conf :: ProcessConfig () () (Maybe Handle)
conf = ProcessConfig () () () -> ProcessConfig () () (Maybe Handle)
err (String -> ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdout stderr.
String
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setWorkingDir (Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
root) (String -> [String] -> ProcessConfig () () ()
proc String
"nix" [String]
args))

    err :: ProcessConfig () () () -> ProcessConfig () () (Maybe Handle)
err = case OutputConfig
output of
      OutputConfig
OutputParse -> StreamSpec 'STOutput (Maybe Handle)
-> ProcessConfig () () () -> ProcessConfig () () (Maybe Handle)
forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
setStderr (Handle -> Maybe Handle
forall a. a -> Maybe a
Just (Handle -> Maybe Handle)
-> StreamSpec 'STOutput Handle
-> StreamSpec 'STOutput (Maybe Handle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StreamSpec 'STOutput Handle
forall (anyStreamType :: StreamType).
StreamSpec anyStreamType Handle
createPipe)
      OutputConfig
OutputDebug -> StreamSpec 'STOutput ()
-> ProcessConfig () () (Maybe Handle)
-> ProcessConfig () () (Maybe Handle)
forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout StreamSpec 'STOutput ()
forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
inherit (ProcessConfig () () (Maybe Handle)
 -> ProcessConfig () () (Maybe Handle))
-> (ProcessConfig () () () -> ProcessConfig () () (Maybe Handle))
-> ProcessConfig () () ()
-> ProcessConfig () () (Maybe Handle)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamSpec 'STOutput (Maybe Handle)
-> ProcessConfig () () () -> ProcessConfig () () (Maybe Handle)
forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
setStderr (Maybe Handle
forall a. Maybe a
Nothing Maybe Handle
-> StreamSpec 'STOutput () -> StreamSpec 'STOutput (Maybe Handle)
forall a b. a -> StreamSpec 'STOutput b -> StreamSpec 'STOutput a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ StreamSpec 'STOutput ()
forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
inherit)
      OutputConfig
OutputIgnore -> StreamSpec 'STOutput (Maybe Handle)
-> ProcessConfig () () () -> ProcessConfig () () (Maybe Handle)
forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
setStderr (Maybe Handle
forall a. Maybe a
Nothing Maybe Handle
-> StreamSpec 'STOutput () -> StreamSpec 'STOutput (Maybe Handle)
forall a b. a -> StreamSpec 'STOutput b -> StreamSpec 'STOutput a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ StreamSpec 'STOutput ()
forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
nullStream)

    args :: [String]
args = Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> [Text] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
cmd [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [exon|path:#{".#"}#{installable}|] Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
extra [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
logArgs

    logArgs :: [Text]
logArgs = case OutputConfig
output of
      OutputConfig
OutputParse -> [Text
Item [Text]
"--log-format", Text
Item [Text]
"internal-json"]
      OutputConfig
OutputDebug -> [Text
Item [Text]
"-L"]
      OutputConfig
OutputIgnore -> []

runProc ::
  BuildConfig ->
  (Handle -> IO a) ->
  ProcessConfig () () (Maybe Handle) ->
  M (Maybe (Maybe a, ExitCode))
runProc :: forall a.
BuildConfig
-> (Handle -> IO a)
-> ProcessConfig () () (Maybe Handle)
-> M (Maybe (Maybe a, ExitCode))
runProc BuildConfig
buildConf Handle -> IO a
pipeHandler ProcessConfig () () (Maybe Handle)
conf =
  IO (Maybe (Maybe a, ExitCode)) -> M (Maybe (Maybe a, ExitCode))
forall a. IO a -> M a
tryIOM (ProcessConfig () () (Maybe Handle)
-> (Process () () (Maybe Handle) -> IO (Maybe (Maybe a, ExitCode)))
-> IO (Maybe (Maybe a, ExitCode))
forall (m :: * -> *) stdin stdout stderr a.
MonadUnliftIO m =>
ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a) -> m a
withProcessTerm ProcessConfig () () (Maybe Handle)
conf Process () () (Maybe Handle) -> IO (Maybe (Maybe a, ExitCode))
interact)
  where
    interact :: Process () () (Maybe Handle) -> IO (Maybe (Maybe a, ExitCode))
interact Process () () (Maybe Handle)
prc =
      IO (Maybe a, ExitCode) -> IO (Maybe (Maybe a, ExitCode))
limit do
        Maybe a
output <- (Handle -> IO a) -> Maybe Handle -> IO (Maybe a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse Handle -> IO a
pipeHandler (Process () () (Maybe Handle) -> Maybe Handle
forall stdin stdout stderr. Process stdin stdout stderr -> stderr
getStderr Process () () (Maybe Handle)
prc)
        ExitCode
res <- Process () () (Maybe Handle) -> IO ExitCode
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
Process stdin stdout stderr -> m ExitCode
waitExitCode Process () () (Maybe Handle)
prc
        pure (Maybe a
output, ExitCode
res)

    limit :: IO (Maybe a, ExitCode) -> IO (Maybe (Maybe a, ExitCode))
limit | Just BuildTimeout
t <- BuildConfig
buildConf.timeout
          , BuildTimeout
t BuildTimeout -> BuildTimeout -> Bool
forall a. Ord a => a -> a -> Bool
> BuildTimeout
0
          = Int -> IO (Maybe a, ExitCode) -> IO (Maybe (Maybe a, ExitCode))
forall a. Int -> IO a -> IO (Maybe a)
timeout (BuildTimeout -> Int
forall a b. Coercible a b => a -> b
coerce BuildTimeout
t Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1_000_000)
          | Bool
otherwise = ((Maybe a, ExitCode) -> Maybe (Maybe a, ExitCode))
-> IO (Maybe a, ExitCode) -> IO (Maybe (Maybe a, ExitCode))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe a, ExitCode) -> Maybe (Maybe a, ExitCode)
forall a. a -> Maybe a
Just

outputResult ::
  Maybe (Either Error (Maybe Text, OutputResult)) ->
  ExitCode ->
  M BuildResult
outputResult :: Maybe (Either Error (Maybe Text, OutputResult))
-> ExitCode -> M BuildResult
outputResult Maybe (Either Error (Maybe Text, OutputResult))
result = \case
  ExitCode
ExitSuccess -> BuildResult -> M BuildResult
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BuildResult
BuildSuccess
  ExitFailure Int
_ -> BuildResult -> M BuildResult
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BuildFailure -> BuildResult
BuildFailure (BuildFailure
-> (NonEmpty PackageDerivation -> BuildFailure)
-> Maybe (NonEmpty PackageDerivation)
-> BuildFailure
forall b a. b -> (a -> b) -> Maybe a -> b
maybe BuildFailure
UnknownFailure NonEmpty PackageDerivation -> BuildFailure
PackageFailure Maybe (NonEmpty PackageDerivation)
failedPackage))
  where
    failedPackage :: Maybe (NonEmpty PackageDerivation)
failedPackage =
      Maybe (Either Error (Maybe Text, OutputResult))
result Maybe (Either Error (Maybe Text, OutputResult))
-> (Either Error (Maybe Text, OutputResult)
    -> Maybe (NonEmpty PackageDerivation))
-> Maybe (NonEmpty PackageDerivation)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right (Maybe Text
_, OutputResult Maybe (NonEmpty PackageDerivation)
pkg) -> Maybe (NonEmpty PackageDerivation)
pkg
        Left Error
_ -> Maybe (NonEmpty PackageDerivation)
forall a. Maybe a
Nothing

buildTarget ::
  BuildConfig ->
  Path Abs Dir ->
  EnvName ->
  LocalPackage ->
  M BuildResult
buildTarget :: BuildConfig
-> Path Abs Dir -> EnvName -> LocalPackage -> M BuildResult
buildTarget BuildConfig
buildConf Path Abs Dir
root EnvName
env LocalPackage
target = do
  AppResources
appRes <- ReaderT AppResources (ExceptT Error IO) AppResources
-> M AppResources
forall a. ReaderT AppResources (ExceptT Error IO) a -> M a
M ReaderT AppResources (ExceptT Error IO) AppResources
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  Bool
debug <- ReaderT AppResources (ExceptT Error IO) Bool -> M Bool
forall a. ReaderT AppResources (ExceptT Error IO) a -> M a
M ((AppResources -> Bool)
-> ReaderT AppResources (ExceptT Error IO) Bool
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks (.debug))
  ProcessConfig () () (Maybe Handle)
conf <- OutputConfig
-> Path Abs Dir
-> [Text]
-> Text
-> [Text]
-> M (ProcessConfig () () (Maybe Handle))
nixProc (Bool -> OutputConfig
outputHandler Bool
debug) Path Abs Dir
root [Text
Item [Text]
"build"] [exon|env.##{env}.##{target}|] []
  BuildConfig
-> (Handle -> IO (Either Error (Maybe Text, OutputResult)))
-> ProcessConfig () () (Maybe Handle)
-> M (Maybe
        (Maybe (Either Error (Maybe Text, OutputResult)), ExitCode))
forall a.
BuildConfig
-> (Handle -> IO a)
-> ProcessConfig () () (Maybe Handle)
-> M (Maybe (Maybe a, ExitCode))
runProc BuildConfig
buildConf (AppResources
-> Handle -> IO (Either Error (Maybe Text, OutputResult))
runOutput AppResources
appRes) ProcessConfig () () (Maybe Handle)
conf M (Maybe
     (Maybe (Either Error (Maybe Text, OutputResult)), ExitCode))
-> (Maybe
      (Maybe (Either Error (Maybe Text, OutputResult)), ExitCode)
    -> M BuildResult)
-> M BuildResult
forall a b. M a -> (a -> M b) -> M b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just (Maybe (Either Error (Maybe Text, OutputResult))
output, ExitCode
code) ->
      Maybe (Either Error (Maybe Text, OutputResult))
-> ExitCode -> M BuildResult
outputResult Maybe (Either Error (Maybe Text, OutputResult))
output ExitCode
code
    Maybe (Maybe (Either Error (Maybe Text, OutputResult)), ExitCode)
Nothing -> BuildResult -> M BuildResult
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BuildFailure -> BuildResult
BuildFailure ([PackageId] -> BuildFailure
TimeoutFailure []))
  where
    runOutput :: AppResources
-> Handle -> IO (Either Error (Maybe Text, OutputResult))
runOutput AppResources
appRes Handle
handle =
      AppResources
-> M (Maybe Text, OutputResult)
-> IO (Either Error (Maybe Text, OutputResult))
forall a. AppResources -> M a -> IO (Either Error a)
runMUsing AppResources
appRes (StateT OutputState M (Maybe Text) -> M (Maybe Text, OutputResult)
forall (m :: * -> *) a.
Monad m =>
StateT OutputState m a -> m (a, OutputResult)
runOutputState ((ByteString -> StateT OutputState M ())
-> Handle -> StateT OutputState M (Maybe Text)
forall (m :: * -> *).
MonadIO m =>
(ByteString -> m ()) -> Handle -> m (Maybe Text)
outputLines ByteString -> StateT OutputState M ()
outputParse Handle
handle))

    outputHandler :: Bool -> OutputConfig
outputHandler Bool
debug
      | BuildConfig
buildConf.buildOutput Bool -> Bool -> Bool
|| (BuildConfig
buildConf.disableNixMonitor Bool -> Bool -> Bool
&& Bool
debug)
      = OutputConfig
OutputDebug
      | BuildConfig
buildConf.disableNixMonitor
      = OutputConfig
OutputIgnore
      | Bool
otherwise
      = OutputConfig
OutputParse

buildAdaptive ::
  EnvBuilderResources ->
  Bool ->
  LocalPackage ->
  StateT (Overrides, Set PackageId) M BuildResult
buildAdaptive :: EnvBuilderResources
-> Bool
-> LocalPackage
-> StateT (Overrides, Set PackageId) M BuildResult
buildAdaptive EnvBuilderResources {BuilderResources
global :: EnvBuilderResources -> BuilderResources
global :: BuilderResources
global, EnvContext
context :: EnvBuilderResources -> EnvContext
context :: EnvContext
context} Bool
allowRevisions LocalPackage
target = do
  StateT (Overrides, Set PackageId) M BuildResult
build
  where
    build :: StateT (Overrides, Set PackageId) M BuildResult
build = do
      Overrides
overrides <- ((Overrides, Set PackageId) -> Overrides)
-> StateT (Overrides, Set PackageId) M Overrides
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (Overrides, Set PackageId) -> Overrides
forall a b. (a, b) -> a
fst
      BuildResult
result <- M BuildResult -> StateT (Overrides, Set PackageId) M BuildResult
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Overrides, Set PackageId) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift do
        Text
-> StateFileHandlers
-> Path Abs Dir
-> EnvContext
-> Overrides
-> M ()
writeBuildStateFor Text
"current build" BuilderResources
global.stateFileHandlers BuilderResources
global.root EnvContext
context Overrides
overrides
        BuildConfig
-> Path Abs Dir -> EnvName -> LocalPackage -> M BuildResult
buildTarget BuilderResources
global.buildConfig BuilderResources
global.root EnvContext
context.env LocalPackage
target
      Overrides
-> BuildResult -> StateT (Overrides, Set PackageId) M BuildResult
checkResult Overrides
overrides BuildResult
result

    checkResult :: Overrides
-> BuildResult -> StateT (Overrides, Set PackageId) M BuildResult
checkResult Overrides
overrides BuildResult
result
      | Bool
allowRevisions
      , BuildFailure (PackageFailure NonEmpty PackageDerivation
pkgs) <- BuildResult
result
      , Just PackageId
package <- (PackageDerivation -> Maybe PackageId)
-> [PackageDerivation] -> Maybe PackageId
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstJust PackageDerivation -> Maybe PackageId
logFailure (NonEmpty PackageDerivation -> [PackageDerivation]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty PackageDerivation
pkgs)
      , Bool -> Bool
not (PackageName -> Overrides -> Bool
forall map k v sort. NMap map k v sort => k -> map -> Bool
nMember PackageId
package.name Overrides
overrides)
      = PackageId -> StateT (Overrides, Set PackageId) M BuildResult
retry PackageId
package
      | Bool
otherwise
      = BuildResult -> StateT (Overrides, Set PackageId) M BuildResult
forall a. a -> StateT (Overrides, Set PackageId) M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BuildResult
result

    logFailure :: PackageDerivation -> Maybe PackageId
logFailure PackageDerivation {PackageId
package :: PackageId
package :: PackageDerivation -> PackageId
package, [Text]
log :: [Text]
log :: PackageDerivation -> [Text]
log} =
      PackageId
package PackageId -> Maybe (NonEmpty Dep) -> Maybe PackageId
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Text] -> Maybe (NonEmpty Dep)
analyzeLog [Text]
log

    retry :: PackageId -> StateT (Overrides, Set PackageId) M BuildResult
retry PackageId
broken = do
      M () -> StateT (Overrides, Set PackageId) M ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Overrides, Set PackageId) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M () -> StateT (Overrides, Set PackageId) M ())
-> M () -> StateT (Overrides, Set PackageId) M ()
forall a b. (a -> b) -> a -> b
$ Text -> M ()
Log.verbose [exon|Installed package failed with bounds error, retrying with override: #{showP broken}|]
      (PackageName
package, Override
newOverride) <- M (PackageName, Override)
-> StateT (Overrides, Set PackageId) M (PackageName, Override)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Overrides, Set PackageId) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M (PackageName, Override)
 -> StateT (Overrides, Set PackageId) M (PackageName, Override))
-> M (PackageName, Override)
-> StateT (Overrides, Set PackageId) M (PackageName, Override)
forall a b. (a -> b) -> a -> b
$ HackageHandlers -> PackageId -> M (PackageName, Override)
packageOverride BuilderResources
global.hackage PackageId
broken
      ((Overrides, Set PackageId) -> (Overrides, Set PackageId))
-> StateT (Overrides, Set PackageId) M ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' \ (Overrides
overrides, Set PackageId
revisions) -> (PackageName -> Override -> Overrides -> Overrides
forall map k v sort. NMap map k v sort => k -> v -> map -> map
nInsert PackageName
package Override
newOverride Overrides
overrides, PackageId -> Set PackageId -> Set PackageId
forall a. Ord a => a -> Set a -> Set a
Set.insert PackageId
broken Set PackageId
revisions)
      StateT (Overrides, Set PackageId) M BuildResult
build

buildWithState ::
  EnvBuilderResources ->
  Bool ->
  Versions ->
  [PackageId] ->
  M (BuildResult, (Overrides, Set PackageId))
buildWithState :: EnvBuilderResources
-> Bool
-> Versions
-> [PackageId]
-> M (BuildResult, (Overrides, Set PackageId))
buildWithState EnvBuilderResources
builder Bool
allowRevisions Versions
_ [PackageId]
overrideVersions = do
  Overrides
overrides <- HackageHandlers -> [PackageId] -> M Overrides
packageOverrides EnvBuilderResources
builder.global.hackage [PackageId]
overrideVersions
  let build :: LocalPackage -> StateT (Overrides, Set PackageId) M BuildResult
build = EnvBuilderResources
-> Bool
-> LocalPackage
-> StateT (Overrides, Set PackageId) M BuildResult
buildAdaptive EnvBuilderResources
builder Bool
allowRevisions
      s0 :: (Overrides, Set PackageId)
s0 = (Overrides
overrides, Set PackageId
forall a. Set a
Set.empty)
  StateT (Overrides, Set PackageId) M BuildResult
-> (Overrides, Set PackageId)
-> M (BuildResult, (Overrides, Set PackageId))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (BuildResult
-> (BuildResult -> Bool)
-> (LocalPackage
    -> StateT (Overrides, Set PackageId) M BuildResult)
-> Targets
-> StateT (Overrides, Set PackageId) M BuildResult
forall (m :: * -> *) a.
Monad m =>
a -> (a -> Bool) -> (LocalPackage -> m a) -> Targets -> m a
firstMTargets BuildResult
BuildSuccess BuildResult -> Bool
buildUnsuccessful LocalPackage -> StateT (Overrides, Set PackageId) M BuildResult
build EnvBuilderResources
builder.context.targets) (Overrides, Set PackageId)
s0

-- | This used to have the purpose of reading an updated GHC package db using the current managed state, but this has
-- become obsolete.
--
-- TODO Decide whether to keep this for abstraction purposes.
withEnvBuilder ::
  ∀ a .
  BuilderResources ->
  CabalHandlers ->
  EnvContext ->
  Initial EnvState ->
  (EnvBuilder -> M a) ->
  M a
withEnvBuilder :: forall a.
BuilderResources
-> CabalHandlers
-> EnvContext
-> Initial EnvState
-> (EnvBuilder -> M a)
-> M a
withEnvBuilder BuilderResources
global CabalHandlers
cabal EnvContext
context Initial EnvState
initialState EnvBuilder -> M a
use = do
  StateFileHandlers
-> Path Abs Dir -> EnvContext -> Initial EnvState -> M ()
writeInitialEnvState BuilderResources
global.stateFileHandlers BuilderResources
global.root EnvContext
context Initial EnvState
initialState
  EnvBuilder -> M a
use EnvBuilder
builder
  where
    builder :: EnvBuilder
builder =
      EnvBuilder {
        CabalHandlers
cabal :: CabalHandlers
cabal :: CabalHandlers
cabal,
        buildWithState :: Bool
-> Versions
-> [PackageId]
-> M (BuildResult, (Overrides, Set PackageId))
buildWithState = EnvBuilderResources
-> Bool
-> Versions
-> [PackageId]
-> M (BuildResult, (Overrides, Set PackageId))
buildWithState EnvBuilderResources
resources
      }

    resources :: EnvBuilderResources
resources = EnvBuilderResources {EnvContext
BuilderResources
global :: BuilderResources
context :: EnvContext
global :: BuilderResources
context :: EnvContext
..}

withBuilder ::
  HackageHandlers ->
  StateFileHandlers ->
  StateFileConfig ->
  Envs EnvConfig ->
  Maybe BuildOutputsPrefix ->
  BuildConfig ->
  (Builder -> M a) ->
  M a
withBuilder :: forall a.
HackageHandlers
-> StateFileHandlers
-> StateFileConfig
-> Envs EnvConfig
-> Maybe BuildOutputsPrefix
-> BuildConfig
-> (Builder -> M a)
-> M a
withBuilder HackageHandlers
hackage StateFileHandlers
stateFileHandlers StateFileConfig
stateFileConf Envs EnvConfig
envsConf Maybe BuildOutputsPrefix
buildOutputsPrefix BuildConfig
buildConfig Builder -> M a
use =
  Maybe (Path Abs Dir) -> (Path Abs Dir -> M a) -> M a
forall a. Maybe (Path Abs Dir) -> (Path Abs Dir -> M a) -> M a
withTempProject StateFileConfig
stateFileConf.projectRoot \ Path Abs Dir
root -> do
    let resources :: BuilderResources
resources = BuilderResources {Maybe BuildOutputsPrefix
Path Abs Dir
StateFileHandlers
HackageHandlers
Envs EnvConfig
BuildConfig
hackage :: HackageHandlers
stateFileHandlers :: StateFileHandlers
envsConf :: Envs EnvConfig
buildOutputsPrefix :: Maybe BuildOutputsPrefix
root :: Path Abs Dir
buildConfig :: BuildConfig
hackage :: HackageHandlers
stateFileHandlers :: StateFileHandlers
envsConf :: Envs EnvConfig
buildOutputsPrefix :: Maybe BuildOutputsPrefix
buildConfig :: BuildConfig
root :: Path Abs Dir
..}
    Builder -> M a
use Builder {withEnvBuilder :: forall a.
CabalHandlers
-> EnvContext -> Initial EnvState -> (EnvBuilder -> M a) -> M a
withEnvBuilder = BuilderResources
-> CabalHandlers
-> EnvContext
-> Initial EnvState
-> (EnvBuilder -> M a)
-> M a
forall a.
BuilderResources
-> CabalHandlers
-> EnvContext
-> Initial EnvState
-> (EnvBuilder -> M a)
-> M a
withEnvBuilder BuilderResources
resources}

handlersProd ::
  MonadIO m =>
  StateFileConfig ->
  Envs EnvConfig ->
  Maybe BuildOutputsPrefix ->
  BuildConfig ->
  CabalConfig ->
  Bool ->
  m BuildHandlers
handlersProd :: forall (m :: * -> *).
MonadIO m =>
StateFileConfig
-> Envs EnvConfig
-> Maybe BuildOutputsPrefix
-> BuildConfig
-> CabalConfig
-> Bool
-> m BuildHandlers
handlersProd StateFileConfig
stateFileConf Envs EnvConfig
envsConf Maybe BuildOutputsPrefix
buildOutputsPrefix BuildConfig
buildConfig CabalConfig
cabalConf Bool
oldest = do
  Manager
manager <- IO Manager -> m Manager
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings)
  HackageHandlers
hackage <- m HackageHandlers
forall (m :: * -> *). MonadIO m => m HackageHandlers
HackageHandlers.handlersProd
  let stateFile :: StateFileHandlers
stateFile = StateFileConfig -> StateFileHandlers
StateFileHandlers.handlersProd StateFileConfig
stateFileConf
  pure BuildHandlers {
    StateFileHandlers
stateFile :: StateFileHandlers
stateFile :: StateFileHandlers
stateFile,
    report :: ReportHandlers
report = ReportHandlers
ReportHandlers.handlersProd,
    cabal :: Packages ManagedPackage -> GhcDb -> M CabalHandlers
cabal = CabalConfig
-> Bool -> Packages ManagedPackage -> GhcDb -> M CabalHandlers
CabalHandlers.handlersProd CabalConfig
cabalConf Bool
oldest,
    withBuilder :: forall a. (Builder -> M a) -> M a
withBuilder = HackageHandlers
-> StateFileHandlers
-> StateFileConfig
-> Envs EnvConfig
-> Maybe BuildOutputsPrefix
-> BuildConfig
-> (Builder -> M a)
-> M a
forall a.
HackageHandlers
-> StateFileHandlers
-> StateFileConfig
-> Envs EnvConfig
-> Maybe BuildOutputsPrefix
-> BuildConfig
-> (Builder -> M a)
-> M a
withBuilder HackageHandlers
hackage StateFileHandlers
stateFile StateFileConfig
stateFileConf Envs EnvConfig
envsConf Maybe BuildOutputsPrefix
buildOutputsPrefix BuildConfig
buildConfig,
    versions :: PackageName -> M [Version]
versions = Manager -> PackageName -> M [Version]
versionsHackage Manager
manager,
    latestVersion :: PackageName -> M (Maybe Version)
latestVersion = Manager -> PackageName -> M (Maybe Version)
latestVersionHackage Manager
manager
  }