module Hix.Managed.Handlers.Build.Prod where

import Control.Monad.Catch (catch)
import Control.Monad.Trans.Reader (asks)
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.Error (IOError)
import System.Process.Typed (
  ExitCode (ExitFailure, ExitSuccess),
  ProcessConfig,
  inherit,
  nullStream,
  proc,
  setStderr,
  setStdout,
  setWorkingDir,
  waitExitCode,
  withProcessTerm,
  )
import System.Timeout (timeout)

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 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.Cabal.Data.Config (CabalConfig)
import Hix.Managed.Data.EnvConfig (EnvConfig)
import qualified Hix.Managed.Data.EnvContext
import Hix.Managed.Data.EnvContext (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 (BuildResult (Finished, TimedOut), BuildStatus (Failure, Success), 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,
  BuildTimeout,
  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 (packageOverrides)
import Hix.Managed.Path (rootOrCwd)
import Hix.Managed.StateFile (writeBuildStateFor, writeInitialEnvState)
import Hix.Monad (throwM, tryIOM, withTempDir)

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 -> Maybe BuildTimeout
buildTimeout :: Maybe BuildTimeout
  }

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. Exception e => M a -> (e -> M a) -> M a
forall (m :: * -> *) e a.
(MonadCatch m, 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))

nixProc ::
  Path Abs Dir ->
  [Text] ->
  Text ->
  [Text] ->
  M (ProcessConfig () () ())
nixProc :: Path Abs Dir
-> [Text] -> Text -> [Text] -> M (ProcessConfig () () ())
nixProc 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}|]
  Bool -> ProcessConfig () () ()
conf (Bool -> ProcessConfig () () ())
-> M Bool -> M (ProcessConfig () () ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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))
  where
    conf :: Bool -> ProcessConfig () () ()
conf Bool
debug = Bool -> ProcessConfig () () () -> ProcessConfig () () ()
forall {stdin} {stdout} {stderr0}.
Bool
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout ()
err Bool
debug (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 :: Bool
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout ()
err = \case
      Bool
True -> StreamSpec 'STOutput ()
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout ()
forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
setStderr StreamSpec 'STOutput ()
forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
inherit
      Bool
False -> StreamSpec 'STOutput ()
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout ()
forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
setStderr 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

buildPackage ::
  Maybe BuildTimeout ->
  Path Abs Dir ->
  EnvName ->
  LocalPackage ->
  M BuildResult
buildPackage :: Maybe BuildTimeout
-> Path Abs Dir -> EnvName -> LocalPackage -> M BuildResult
buildPackage Maybe BuildTimeout
processTimeout Path Abs Dir
root EnvName
env LocalPackage
target = do
  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 () () ()
conf <- Path Abs Dir
-> [Text] -> Text -> [Text] -> M (ProcessConfig () () ())
nixProc Path Abs Dir
root [Text
Item [Text]
"-L", Text
Item [Text]
"build"] [exon|env.##{env}.##{target}|] []
  IO (Maybe ExitCode) -> M (Maybe ExitCode)
forall a. IO a -> M a
tryIOM (ProcessConfig () () ()
-> (Process () () () -> IO (Maybe ExitCode)) -> IO (Maybe ExitCode)
forall (m :: * -> *) stdin stdout stderr a.
MonadUnliftIO m =>
ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a) -> m a
withProcessTerm (Bool -> ProcessConfig () () () -> ProcessConfig () () ()
forall {stdin} {stderr}.
Bool
-> ProcessConfig stdin () stderr -> ProcessConfig stdin () stderr
err Bool
debug ProcessConfig () () ()
conf) (IO ExitCode -> IO (Maybe ExitCode)
limit (IO ExitCode -> IO (Maybe ExitCode))
-> (Process () () () -> IO ExitCode)
-> Process () () ()
-> IO (Maybe ExitCode)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Process () () () -> IO ExitCode
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
Process stdin stdout stderr -> m ExitCode
waitExitCode)) M (Maybe ExitCode)
-> (Maybe ExitCode -> BuildResult) -> M BuildResult
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    Just ExitCode
ExitSuccess -> BuildStatus -> BuildResult
Finished BuildStatus
Success
    Just (ExitFailure Int
_) -> BuildStatus -> BuildResult
Finished BuildStatus
Failure
    Maybe ExitCode
Nothing -> BuildResult
TimedOut
  where
    limit :: IO ExitCode -> IO (Maybe ExitCode)
limit | Just BuildTimeout
t <- Maybe BuildTimeout
processTimeout = Int -> IO ExitCode -> IO (Maybe 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 = (ExitCode -> Maybe ExitCode) -> IO ExitCode -> IO (Maybe ExitCode)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ExitCode -> Maybe ExitCode
forall a. a -> Maybe a
Just

    err :: Bool
-> ProcessConfig stdin () stderr -> ProcessConfig stdin () stderr
err = \case
      Bool
True -> StreamSpec 'STOutput ()
-> ProcessConfig stdin () stderr -> ProcessConfig stdin () stderr
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
      Bool
False -> ProcessConfig stdin () stderr -> ProcessConfig stdin () stderr
forall a. a -> a
id

buildWithState ::
  EnvBuilderResources ->
  Versions ->
  [PackageId] ->
  M (Overrides, BuildResult)
buildWithState :: EnvBuilderResources
-> Versions -> [PackageId] -> M (Overrides, BuildResult)
buildWithState EnvBuilderResources {BuilderResources
$sel:global:EnvBuilderResources :: EnvBuilderResources -> BuilderResources
global :: BuilderResources
global, $sel:context:EnvBuilderResources :: EnvBuilderResources -> EnvContext
context = context :: EnvContext
context@EnvContext {EnvName
env :: EnvName
$sel:env:EnvContext :: EnvContext -> EnvName
env, Targets
targets :: Targets
$sel:targets:EnvContext :: EnvContext -> Targets
targets}} Versions
_ [PackageId]
overrideVersions = do
  Overrides
overrides <- HackageHandlers -> [PackageId] -> M Overrides
packageOverrides BuilderResources
global.hackage [PackageId]
overrideVersions
  Text
-> StateFileHandlers
-> Path Abs Dir
-> EnvContext
-> Overrides
-> M ()
writeBuildStateFor Text
"current build" BuilderResources
global.stateFileHandlers BuilderResources
global.root EnvContext
context Overrides
overrides
  BuildResult
status <- BuildResult
-> (BuildResult -> Bool)
-> (LocalPackage -> M BuildResult)
-> Targets
-> M BuildResult
forall (m :: * -> *) a.
Monad m =>
a -> (a -> Bool) -> (LocalPackage -> m a) -> Targets -> m a
firstMTargets (BuildStatus -> BuildResult
Finished BuildStatus
Success) BuildResult -> Bool
buildUnsuccessful (Maybe BuildTimeout
-> Path Abs Dir -> EnvName -> LocalPackage -> M BuildResult
buildPackage BuilderResources
global.buildTimeout BuilderResources
global.root EnvName
env) Targets
targets
  pure (Overrides
overrides, BuildResult
status)

-- | 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
$sel:cabal:EnvBuilder :: CabalHandlers
cabal,
        $sel:buildWithState:EnvBuilder :: Versions -> [PackageId] -> M (Overrides, BuildResult)
buildWithState = EnvBuilderResources
-> Versions -> [PackageId] -> M (Overrides, BuildResult)
buildWithState EnvBuilderResources
resources
      }

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

withBuilder ::
  HackageHandlers ->
  StateFileHandlers ->
  StateFileConfig ->
  Envs EnvConfig ->
  Maybe BuildOutputsPrefix ->
  Maybe BuildTimeout ->
  (Builder -> M a) ->
  M a
withBuilder :: forall a.
HackageHandlers
-> StateFileHandlers
-> StateFileConfig
-> Envs EnvConfig
-> Maybe BuildOutputsPrefix
-> Maybe BuildTimeout
-> (Builder -> M a)
-> M a
withBuilder HackageHandlers
hackage StateFileHandlers
stateFileHandlers StateFileConfig
stateFileConf Envs EnvConfig
envsConf Maybe BuildOutputsPrefix
buildOutputsPrefix Maybe BuildTimeout
buildTimeout 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 BuildTimeout
Maybe BuildOutputsPrefix
Path Abs Dir
StateFileHandlers
HackageHandlers
Envs EnvConfig
$sel:hackage:BuilderResources :: HackageHandlers
$sel:stateFileHandlers:BuilderResources :: StateFileHandlers
$sel:envsConf:BuilderResources :: Envs EnvConfig
$sel:buildOutputsPrefix:BuilderResources :: Maybe BuildOutputsPrefix
$sel:root:BuilderResources :: Path Abs Dir
$sel:buildTimeout:BuilderResources :: Maybe BuildTimeout
hackage :: HackageHandlers
stateFileHandlers :: StateFileHandlers
envsConf :: Envs EnvConfig
buildOutputsPrefix :: Maybe BuildOutputsPrefix
buildTimeout :: Maybe BuildTimeout
root :: Path Abs Dir
..}
    Builder -> M a
use Builder {$sel:withEnvBuilder:Builder :: 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 ->
  Maybe BuildTimeout ->
  CabalConfig ->
  Bool ->
  m BuildHandlers
handlersProd :: forall (m :: * -> *).
MonadIO m =>
StateFileConfig
-> Envs EnvConfig
-> Maybe BuildOutputsPrefix
-> Maybe BuildTimeout
-> CabalConfig
-> Bool
-> m BuildHandlers
handlersProd StateFileConfig
stateFileConf Envs EnvConfig
envsConf Maybe BuildOutputsPrefix
buildOutputsPrefix Maybe BuildTimeout
buildTimeout 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
$sel:stateFile:BuildHandlers :: StateFileHandlers
stateFile,
    $sel:report:BuildHandlers :: ReportHandlers
report = ReportHandlers
ReportHandlers.handlersProd,
    $sel:cabal:BuildHandlers :: Packages ManagedPackage -> GhcDb -> M CabalHandlers
cabal = CabalConfig
-> Bool -> Packages ManagedPackage -> GhcDb -> M CabalHandlers
CabalHandlers.handlersProd CabalConfig
cabalConf Bool
oldest,
    $sel:withBuilder:BuildHandlers :: forall a. (Builder -> M a) -> M a
withBuilder = HackageHandlers
-> StateFileHandlers
-> StateFileConfig
-> Envs EnvConfig
-> Maybe BuildOutputsPrefix
-> Maybe BuildTimeout
-> (Builder -> M a)
-> M a
forall a.
HackageHandlers
-> StateFileHandlers
-> StateFileConfig
-> Envs EnvConfig
-> Maybe BuildOutputsPrefix
-> Maybe BuildTimeout
-> (Builder -> M a)
-> M a
withBuilder HackageHandlers
hackage StateFileHandlers
stateFile StateFileConfig
stateFileConf Envs EnvConfig
envsConf Maybe BuildOutputsPrefix
buildOutputsPrefix Maybe BuildTimeout
buildTimeout,
    $sel:versions:BuildHandlers :: PackageName -> M [Version]
versions = Manager -> PackageName -> M [Version]
versionsHackage Manager
manager,
    $sel:latestVersion:BuildHandlers :: PackageName -> M (Maybe Version)
latestVersion = Manager -> PackageName -> M (Maybe Version)
latestVersionHackage Manager
manager
  }