-- | This module is the entry point to the @Shrun@ library used by
-- the @Shrun@ executable.
module Shrun
  ( ShellT,
    runShellT,
    shrun,
    TermException (..),
  )
where

import Data.List qualified as L
import Effects.Concurrent.Async qualified as Async
import Effects.Concurrent.Thread (MonadThread (throwTo), ThreadId, myThreadId)
import Effects.System.Posix.Signals qualified as Signals
import Effects.Time (TimeSpec)
import Effects.Time qualified as Time
import Shrun.Command qualified as Command
import Shrun.Command.Types (CommandP1, CommandStatus (CommandRunning))
import Shrun.Configuration.Data.CommonLogging (CommonLoggingEnv)
import Shrun.Configuration.Data.ConsoleLogging (ConsoleLoggingEnv)
import Shrun.Configuration.Data.ConsoleLogging.TimerFormat (TimerFormat (ProseCompact))
import Shrun.Configuration.Data.ConsoleLogging.TimerFormat qualified as TimerFormat
import Shrun.Configuration.Data.Core.Timeout (Timeout (MkTimeout))
import Shrun.Configuration.Data.FileLogging
  ( FileLogOpened (MkFileLogOpened),
    FileLoggingEnv,
  )
import Shrun.Configuration.Data.Notify
  ( _NotifyActionsActiveCompleteAny,
    _NotifyActionsActiveStartAny,
  )
import Shrun.Configuration.Data.Notify.Action
  ( NotifyActionComplete
      ( NotifyActionCompleteAll,
        NotifyActionCompleteCommand,
        NotifyActionCompleteFinal
      ),
  )
import Shrun.Configuration.Data.WithDisabled (WithDisabled (Disabled, With))
import Shrun.Configuration.Env.Types
  ( HasAnyError (getAnyError),
    HasCommands,
    HasCommonLogging (getCommonLogging),
    HasConsoleLogging (getConsoleLogging),
    HasFileLogging (getFileLogging),
    HasInit,
    HasLogging,
    HasNotifyConfig (getNotifyConfig),
    HasTimeout (getTimeout),
    getReadCommandStatus,
    setAnyErrorTrue,
    setTimedOut,
    whenTimedOut,
  )
import Shrun.Data.Text (UnlinedText)
import Shrun.Data.Text qualified as ShrunText
import Shrun.Data.Text qualified as Text
import Shrun.IO
  ( CommandResult (CommandResultFailure, CommandResultSuccess),
    Stderr (MkStderr),
    tryCommandLogging,
  )
import Shrun.IO qualified
import Shrun.Logging qualified as Logging
import Shrun.Logging.Formatting qualified as Formatting
import Shrun.Logging.Formatting qualified as LogFmt
import Shrun.Logging.MonadRegionLogger
  ( MonadRegionLogger
      ( Region,
        displayRegions,
        logGlobal,
        logRegion,
        withRegion
      ),
  )
import Shrun.Logging.Types
  ( ConsoleLog,
    FileLog,
    Log (MkLog, cmd, lvl, mode, msg),
    LogLevel
      ( LevelError,
        LevelFatal,
        LevelFinished,
        LevelKilled,
        LevelSuccess,
        LevelTimer,
        LevelWarn
      ),
    LogMode (LogModeFinish, LogModeSet),
    LogRegion (LogNoRegion, LogRegion),
  )
import Shrun.Logging.Types qualified as Types
import Shrun.Notify (NotifyMessage)
import Shrun.Notify qualified as Notify
import Shrun.Prelude
import Shrun.ShellT (ShellT, runShellT)
import Shrun.Utils qualified as Utils
import System.Posix.Signals qualified as Posix

-- | Entry point
shrun ::
  forall m env notifyEnv.
  ( HasAnyError env,
    HasCallStack,
    HasCommands env,
    HasInit env,
    HasLogging env m,
    HasNotifyConfig env notifyEnv,
    HasTimeout env,
    MonadAsync m,
    MonadAtomic m,
    MonadEvaluate m,
    MonadHandleReader m,
    MonadHandleWriter m,
    MonadIORef m,
    MonadMask m,
    MonadNotify m,
    MonadPathReader m,
    MonadPathWriter m,
    MonadPosixFiles m,
    MonadPosixSignals m,
    MonadProcess m,
    MonadMVar m,
    MonadReader env m,
    MonadRegionLogger m,
    MonadThread m,
    MonadTime m,
    NotifyEnvF m ~ notifyEnv
  ) =>
  -- | .
  m ()
shrun :: forall (m :: Type -> Type) env notifyEnv.
(HasAnyError env, HasCallStack, HasCommands env, HasInit env,
 HasLogging env m, HasNotifyConfig env notifyEnv, HasTimeout env,
 MonadAsync m, MonadAtomic m, MonadEvaluate m, MonadHandleReader m,
 MonadHandleWriter m, MonadIORef m, MonadMask m, MonadNotify m,
 MonadPathReader m, MonadPathWriter m, MonadPosixFiles m,
 MonadPosixSignals m, MonadProcess m, MonadMVar m,
 MonadReader env m, MonadRegionLogger m, MonadThread m, MonadTime m,
 NotifyEnvF m ~ notifyEnv) =>
m ()
shrun = do
  -- install handler that turns SIGTERM into an exception in the main thread.
  m ThreadId
forall (m :: Type -> Type).
(MonadThread m, HasCallStack) =>
m ThreadId
myThreadId m ThreadId -> (ThreadId -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= ThreadId -> m ()
forall (m :: Type -> Type) env.
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadHandleWriter m, MonadPosixSignals m, MonadRegionLogger m,
 MonadReader env m, MonadThread m, MonadTime m) =>
ThreadId -> m ()
handleTerminate

  Double
startTime <- m Double
forall (m :: Type -> Type). (MonadTime m, HasCallStack) => m Double
Time.getMonotonicTime

  m () -> m ()
forall (m :: Type -> Type) a.
(MonadMask m, MonadHandleReader m, MonadHandleWriter m) =>
m a -> m a
Utils.withHiddenInput (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ m () -> m ()
forall a. HasCallStack => m a -> m a
forall (m :: Type -> Type) a.
(MonadRegionLogger m, HasCallStack) =>
m a -> m a
displayRegions (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ (m () -> m () -> m ()) -> m () -> m () -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip m () -> m () -> m ()
forall (m :: Type -> Type) a b.
(HasCallStack, MonadCatch m) =>
m a -> m b -> m a
onMyAsync (Double -> m ()
forall (m :: Type -> Type) env notifyEnv.
(HasAnyError env, HasCallStack, HasCommands env, HasLogging env m,
 HasNotifyConfig env notifyEnv, MonadAtomic m, MonadCatch m,
 MonadHandleWriter m, MonadNotify m, MonadProcess m,
 MonadReader env m, MonadRegionLogger m, MonadTime m,
 NotifyEnvF m ~ notifyEnv) =>
Double -> m ()
teardown Double
startTime) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe FileLoggingEnv
mFileLogging <- (env -> Maybe FileLoggingEnv) -> m (Maybe FileLoggingEnv)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> Maybe FileLoggingEnv
forall env. HasFileLogging env => env -> Maybe FileLoggingEnv
getFileLogging
    (ConsoleLoggingEnv
_, TBQueue (LogRegion (Region m))
consoleQueue, IORef (Maybe (Region m))
_) <- (env
 -> (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)),
     IORef (Maybe (Region m))))
-> m (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)),
      IORef (Maybe (Region m)))
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env
-> (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)),
    IORef (Maybe (Region m)))
forall env r.
HasConsoleLogging env r =>
env -> (ConsoleLoggingEnv, TBQueue (LogRegion r), IORef (Maybe r))
getConsoleLogging

    -- always start console logger
    m (ZonkAny 2) -> (Async (ZonkAny 2) -> m ()) -> m ()
forall a b. HasCallStack => m a -> (Async a -> m b) -> m b
forall (m :: Type -> Type) a b.
(MonadAsync m, HasCallStack) =>
m a -> (Async a -> m b) -> m b
Async.withAsync (TBQueue (LogRegion (Region m)) -> m (ZonkAny 2)
forall (m :: Type -> Type) void.
(HasCallStack, MonadAtomic m, MonadMask m, MonadRegionLogger m) =>
TBQueue (LogRegion (Region m)) -> m void
pollQueueToConsole TBQueue (LogRegion (Region m))
consoleQueue) ((Async (ZonkAny 2) -> m ()) -> m ())
-> (Async (ZonkAny 2) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Async (ZonkAny 2)
consoleLogger -> do
      -- run commands, running file logger if requested
      m () -> (FileLoggingEnv -> m ()) -> Maybe FileLoggingEnv -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (HasCallStack => Double -> m ()
Double -> m ()
runCommands Double
startTime)
        (HasCallStack => Double -> FileLoggingEnv -> m ()
Double -> FileLoggingEnv -> m ()
runWithFileLogging Double
startTime)
        Maybe FileLoggingEnv
mFileLogging

      -- cancel consoleLogger, print remaining logs
      Async (ZonkAny 2) -> m ()
forall a. HasCallStack => Async a -> m ()
forall (m :: Type -> Type) a.
(MonadAsync m, HasCallStack) =>
Async a -> m ()
Async.cancel Async (ZonkAny 2)
consoleLogger
      TBQueue (LogRegion (Region m)) -> m [LogRegion (Region m)]
forall (m :: Type -> Type) a.
(HasCallStack, MonadAtomic m) =>
TBQueue a -> m [a]
flushTBQueueA' TBQueue (LogRegion (Region m))
consoleQueue m [LogRegion (Region m)]
-> ([LogRegion (Region m)] -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= (LogRegion (Region m) -> m ()) -> [LogRegion (Region m)] -> m ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ LogRegion (Region m) -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadRegionLogger m) =>
LogRegion (Region m) -> m ()
printConsoleLog

      -- Need to run cleanup if we have timed out.
      m () -> m ()
forall env (m :: Type -> Type).
(HasTimeout env, MonadAtomic m, MonadReader env m) =>
m () -> m ()
whenTimedOut m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadCatch m, MonadHandleWriter m, MonadProcess m,
 MonadReader env m, MonadRegionLogger m, MonadTime m) =>
m ()
cleanupCommands

      -- One final attempt draining stdin.
      m ()
forall (m :: Type -> Type).
(MonadCatch m, MonadHandleReader m) =>
m ()
Utils.drainStdin

      -- if any processes have failed, exit with an error
      Bool
anyError <- TVar Bool -> m Bool
forall (m :: Type -> Type) a.
(HasCallStack, MonadAtomic m) =>
TVar a -> m a
readTVarA' (TVar Bool -> m Bool) -> m (TVar Bool) -> m Bool
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< (env -> TVar Bool) -> m (TVar Bool)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> TVar Bool
forall env. HasAnyError env => env -> TVar Bool
getAnyError
      Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when Bool
anyError m ()
forall (m :: Type -> Type) a. (HasCallStack, MonadThrow m) => m a
exitFailure
  where
    runWithFileLogging :: (HasCallStack) => Double -> FileLoggingEnv -> m ()
    runWithFileLogging :: HasCallStack => Double -> FileLoggingEnv -> m ()
runWithFileLogging Double
startTime FileLoggingEnv
fileLogging =
      m (ZonkAny 1) -> (Async (ZonkAny 1) -> m ()) -> m ()
forall a b. HasCallStack => m a -> (Async a -> m b) -> m b
forall (m :: Type -> Type) a b.
(MonadAsync m, HasCallStack) =>
m a -> (Async a -> m b) -> m b
Async.withAsync (FileLoggingEnv -> m (ZonkAny 1)
forall (m :: Type -> Type) void.
(HasCallStack, MonadAtomic m, MonadHandleWriter m, MonadMask m) =>
FileLoggingEnv -> m void
pollQueueToFile FileLoggingEnv
fileLogging) ((Async (ZonkAny 1) -> m ()) -> m ())
-> (Async (ZonkAny 1) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Async (ZonkAny 1)
fileLoggerThread -> do
        HasCallStack => Double -> m ()
Double -> m ()
runCommands Double
startTime

        Async (ZonkAny 1) -> m ()
forall a. HasCallStack => Async a -> m ()
forall (m :: Type -> Type) a.
(MonadAsync m, HasCallStack) =>
Async a -> m ()
Async.cancel Async (ZonkAny 1)
fileLoggerThread

        -- handle any remaining file logs
        TBQueue FileLog -> m [FileLog]
forall (m :: Type -> Type) a.
(HasCallStack, MonadAtomic m) =>
TBQueue a -> m [a]
flushTBQueueA' TBQueue FileLog
fileQueue m [FileLog] -> ([FileLog] -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FileLog -> m ()) -> [FileLog] -> m ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (LockedHandle 'HandleModeWrite -> FileLog -> m ()
forall (p :: HandleMode) (m :: Type -> Type).
(CanWrite p, HasCallStack, MonadHandleWriter m) =>
LockedHandle p -> FileLog -> m ()
Logging.logFile LockedHandle 'HandleModeWrite
h)
        (HasCallStack => Handle 'HandleModeWrite -> m ())
-> LockedHandle 'HandleModeWrite -> m ()
forall (p :: HandleMode) a.
HasCallStack =>
(HasCallStack => Handle p -> a) -> LockedHandle p -> a
liftLocked HasCallStack => Handle 'HandleModeWrite -> m ()
Handle 'HandleModeWrite -> m ()
forall (p :: HandleMode).
(CanWrite p, HasCallStack) =>
Handle p -> m ()
forall (m :: Type -> Type) (p :: HandleMode).
(MonadHandleWriter m, CanWrite p, HasCallStack) =>
Handle p -> m ()
hFlush LockedHandle 'HandleModeWrite
h
      where
        MkFileLogOpened LockedHandle 'HandleModeWrite
h OsPath
_ TBQueue FileLog
fileQueue = FileLoggingEnv
fileLogging FileLoggingEnv
-> Optic' A_Lens NoIx FileLoggingEnv FileLogOpened -> FileLogOpened
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx FileLoggingEnv FileLogOpened
#file

    runCommands :: (HasCallStack) => Double -> m ()
    runCommands :: HasCallStack => Double -> m ()
runCommands Double
startTime = do
      let actions :: m ()
actions = (HasCallStack => CommandP1 -> m ()) -> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, HasLogging env m, MonadAsync m,
 MonadAtomic m, MonadEvaluate m, MonadMVar m, MonadReader env m,
 MonadRegionLogger m, MonadThrow m, MonadTime m) =>
(HasCallStack => CommandP1 -> m ()) -> m ()
Command.runCommands (Double -> CommandP1 -> m ()
forall (m :: Type -> Type) env notifyEnv.
(HasAnyError env, HasCallStack, HasCommands env, HasInit env,
 HasLogging env m, HasNotifyConfig env notifyEnv, MonadAtomic m,
 MonadHandleReader m, MonadHandleWriter m, MonadIORef m,
 MonadMask m, MonadNotify m, MonadPathReader m, MonadPathWriter m,
 MonadPosixFiles m, MonadProcess m, MonadReader env m,
 MonadRegionLogger m, MonadThread m, MonadTime m,
 NotifyEnvF m ~ notifyEnv) =>
Double -> CommandP1 -> m ()
runCommand Double
startTime)
          actionsWithTimer :: m ()
actionsWithTimer =
            m ()
actions
              m () -> m () -> m ()
forall (m :: Type -> Type) a b.
(HasCallStack, MonadAsync m) =>
m a -> m b -> m ()
`Async.race_` m ()
forall env (m :: Type -> Type).
(HasAnyError env, HasCallStack, HasCommands env, HasLogging env m,
 HasTimeout env, MonadAtomic m, MonadIORef m, MonadReader env m,
 MonadRegionLogger m, MonadThread m, MonadTime m) =>
m ()
counter
              m () -> m (ZonkAny 0) -> m ()
forall (m :: Type -> Type) a b.
(HasCallStack, MonadAsync m) =>
m a -> m b -> m ()
`Async.race_` m (ZonkAny 0)
forall (m :: Type -> Type) void.
(MonadCatch m, MonadHandleReader m, MonadThread m) =>
m void
drainStdinLoop

      Either SomeException ()
result <- m () -> m (Either SomeException ())
forall (m :: Type -> Type) a.
(HasCallStack, MonadCatch m) =>
m a -> m (Either SomeException a)
tryMySync m ()
actionsWithTimer
      Double
endTime <- m Double
forall (m :: Type -> Type). (MonadTime m, HasCallStack) => m Double
Time.getMonotonicTime
      TimeSpec -> Either SomeException () -> m ()
forall (m :: Type -> Type) env notifyEnv e b.
(Exception e, HasAnyError env, HasCallStack, HasCommands env,
 HasLogging env m, HasNotifyConfig env notifyEnv, MonadAtomic m,
 MonadCatch m, MonadNotify m, MonadReader env m,
 MonadRegionLogger m, MonadTime m, NotifyEnvF m ~ notifyEnv) =>
TimeSpec -> Either e b -> m ()
printFinalResult (Double -> TimeSpec
Time.fromSeconds (Double -> TimeSpec) -> Double -> TimeSpec
forall a b. (a -> b) -> a -> b
$ Double
endTime Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
startTime) Either SomeException ()
result
{-# INLINEABLE shrun #-}

runCommand ::
  forall m env notifyEnv.
  ( HasAnyError env,
    HasCallStack,
    HasCommands env,
    HasInit env,
    HasLogging env m,
    HasNotifyConfig env notifyEnv,
    MonadAtomic m,
    MonadHandleReader m,
    MonadHandleWriter m,
    MonadIORef m,
    MonadMask m,
    MonadNotify m,
    MonadPathReader m,
    MonadPathWriter m,
    MonadPosixFiles m,
    MonadProcess m,
    MonadReader env m,
    MonadRegionLogger m,
    MonadThread m,
    MonadTime m,
    NotifyEnvF m ~ notifyEnv
  ) =>
  Double ->
  CommandP1 ->
  m ()
runCommand :: forall (m :: Type -> Type) env notifyEnv.
(HasAnyError env, HasCallStack, HasCommands env, HasInit env,
 HasLogging env m, HasNotifyConfig env notifyEnv, MonadAtomic m,
 MonadHandleReader m, MonadHandleWriter m, MonadIORef m,
 MonadMask m, MonadNotify m, MonadPathReader m, MonadPathWriter m,
 MonadPosixFiles m, MonadProcess m, MonadReader env m,
 MonadRegionLogger m, MonadThread m, MonadTime m,
 NotifyEnvF m ~ notifyEnv) =>
Double -> CommandP1 -> m ()
runCommand Double
globalStartTime CommandP1
cmd = do
  Maybe (NotificationEnv notifyEnv)
cfg <- (env -> Maybe (NotificationEnv notifyEnv))
-> m (Maybe (NotificationEnv notifyEnv))
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks (forall env r.
HasNotifyConfig env r =>
env -> Maybe (NotificationEnv r)
getNotifyConfig @_ @notifyEnv)
  CommonLoggingEnv
commonLogging <- (env -> CommonLoggingEnv) -> m CommonLoggingEnv
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> CommonLoggingEnv
forall env. HasCommonLogging env => env -> CommonLoggingEnv
getCommonLogging
  (ConsoleLoggingEnv
consoleLogging, TBQueue (LogRegion (Region m))
consoleQueue, IORef (Maybe (Region m))
_) <- (env
 -> (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)),
     IORef (Maybe (Region m))))
-> m (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)),
      IORef (Maybe (Region m)))
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks (forall env r.
HasConsoleLogging env r =>
env -> (ConsoleLoggingEnv, TBQueue (LogRegion r), IORef (Maybe r))
getConsoleLogging @env @(Region m))

  let commandNameTrunc :: Maybe (Truncation 'TruncCommandName)
commandNameTrunc = ConsoleLoggingEnv
consoleLogging ConsoleLoggingEnv
-> Optic'
     A_Lens
     NoIx
     ConsoleLoggingEnv
     (Maybe (Truncation 'TruncCommandName))
-> Maybe (Truncation 'TruncCommandName)
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic'
  A_Lens
  NoIx
  ConsoleLoggingEnv
  (Maybe (Truncation 'TruncCommandName))
#commandNameTrunc
      keyHide :: KeyHideSwitch
keyHide = CommonLoggingEnv
commonLogging CommonLoggingEnv
-> Optic' A_Lens NoIx CommonLoggingEnv KeyHideSwitch
-> KeyHideSwitch
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CommonLoggingEnv KeyHideSwitch
#keyHide
      formattedCmd :: UnlinedText
formattedCmd = KeyHideSwitch
-> Maybe (Truncation 'TruncCommandName) -> CommandP1 -> UnlinedText
LogFmt.formatCommand KeyHideSwitch
keyHide Maybe (Truncation 'TruncCommandName)
commandNameTrunc CommandP1
cmd

  case Maybe (NotificationEnv notifyEnv)
cfg Maybe (NotificationEnv notifyEnv)
-> Optic' An_AffineFold NoIx (Maybe (NotificationEnv notifyEnv)) ()
-> Maybe ()
forall k s (is :: IxList) a.
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? (Prism
  (Maybe (NotificationEnv notifyEnv))
  (Maybe (NotificationEnv notifyEnv))
  (NotificationEnv notifyEnv)
  (NotificationEnv notifyEnv)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just Prism
  (Maybe (NotificationEnv notifyEnv))
  (Maybe (NotificationEnv notifyEnv))
  (NotificationEnv notifyEnv)
  (NotificationEnv notifyEnv)
-> Optic
     A_Lens
     NoIx
     (NotificationEnv notifyEnv)
     (NotificationEnv notifyEnv)
     NotifyActionsActive
     NotifyActionsActive
-> Optic
     An_AffineTraversal
     NoIx
     (Maybe (NotificationEnv notifyEnv))
     (Maybe (NotificationEnv notifyEnv))
     NotifyActionsActive
     NotifyActionsActive
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Lens
  NoIx
  (NotificationEnv notifyEnv)
  (NotificationEnv notifyEnv)
  NotifyActionsActive
  NotifyActionsActive
#actions Optic
  An_AffineTraversal
  NoIx
  (Maybe (NotificationEnv notifyEnv))
  (Maybe (NotificationEnv notifyEnv))
  NotifyActionsActive
  NotifyActionsActive
-> Optic
     An_AffineFold NoIx NotifyActionsActive NotifyActionsActive () ()
-> Optic' An_AffineFold NoIx (Maybe (NotificationEnv notifyEnv)) ()
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  An_AffineFold NoIx NotifyActionsActive NotifyActionsActive () ()
_NotifyActionsActiveStartAny) of
    Just () -> do
      Double
cmdStartTimeDouble <- m Double
forall (m :: Type -> Type). (MonadTime m, HasCallStack) => m Double
Time.getMonotonicTime
      let cmdStartTime :: TimeSpec
cmdStartTime = Double -> TimeSpec
Time.fromSeconds (Double
cmdStartTimeDouble Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
globalStartTime)
          rt :: RelativeTime
rt = TimeSpec -> RelativeTime
Utils.timeSpecToRelTime TimeSpec
cmdStartTime
          startTimeMsg :: UnlinedText
startTimeMsg = TimerFormat -> RelativeTime -> UnlinedText
TimerFormat.formatRelativeTime TimerFormat
ProseCompact RelativeTime
rt
          notifyMsg :: UnlinedText
notifyMsg = UnlinedText
"Started after " UnlinedText -> UnlinedText -> UnlinedText
forall a. Semigroup a => a -> a -> a
<> UnlinedText
startTimeMsg
      NotifyMessage -> NotifyMessage -> NotifyUrgency -> m ()
forall (m :: Type -> Type) env notifyEnv.
(HasAnyError env, HasCallStack, HasCommands env, HasLogging env m,
 HasNotifyConfig env notifyEnv, MonadAtomic m, MonadCatch m,
 MonadNotify m, MonadReader env m, MonadRegionLogger m, MonadTime m,
 NotifyEnvF m ~ notifyEnv) =>
NotifyMessage -> NotifyMessage -> NotifyUrgency -> m ()
Notify.sendNotif
        (UnlinedText -> NotifyMessage
Notify.fromUnlined (UnlinedText -> NotifyMessage) -> UnlinedText -> NotifyMessage
forall a b. (a -> b) -> a -> b
$ UnlinedText
formattedCmd UnlinedText -> UnlinedText -> UnlinedText
forall a. Semigroup a => a -> a -> a
<> UnlinedText
" Started")
        (UnlinedText -> NotifyMessage
Notify.fromUnlined UnlinedText
notifyMsg)
        NotifyUrgency
NotifyUrgencyNormal
    Maybe ()
_ -> () -> m ()
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()

  CommandResult
cmdResult <- CommandP1 -> m CommandResult
forall (m :: Type -> Type) env.
(HasAnyError env, HasCallStack, HasCommands env, HasInit env,
 HasLogging env m, MonadAtomic m, MonadHandleReader m,
 MonadHandleWriter m, MonadIORef m, MonadPathReader m,
 MonadPathWriter m, MonadPosixFiles m, MonadProcess m, MonadMask m,
 MonadReader env m, MonadRegionLogger m, MonadThread m,
 MonadTime m) =>
CommandP1 -> m CommandResult
tryCommandLogging CommandP1
cmd

  let (NotifyUrgency
urgency, m ConsoleLog
mkConsoleLog, FileLoggingEnv -> m FileLog
mkFileLog, NotifyMessage
notifyMsg) =
        CommonLoggingEnv
-> ConsoleLoggingEnv
-> CommandP1
-> CommandResult
-> (NotifyUrgency, m ConsoleLog, FileLoggingEnv -> m FileLog,
    NotifyMessage)
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadAtomic m, MonadReader env m,
 MonadTime m) =>
CommonLoggingEnv
-> ConsoleLoggingEnv
-> CommandP1
-> CommandResult
-> CommandResultData m
mkResultData CommonLoggingEnv
commonLogging ConsoleLoggingEnv
consoleLogging CommandP1
cmd CommandResult
cmdResult

  TBQueue (LogRegion (Region m))
-> m ConsoleLog -> (FileLoggingEnv -> m FileLog) -> m ()
forall (m :: Type -> Type) env.
(HasCallStack, HasFileLogging env, MonadAtomic m,
 MonadReader env m, MonadRegionLogger m) =>
TBQueue (LogRegion (Region m))
-> m ConsoleLog -> (FileLoggingEnv -> m FileLog) -> m ()
putCommandFinalLog TBQueue (LogRegion (Region m))
consoleQueue m ConsoleLog
mkConsoleLog FileLoggingEnv -> m FileLog
mkFileLog

  -- Sent off notif if NotifyActionCompleteAll or NotifyActionCompleteCommand is set
  case Maybe (NotificationEnv notifyEnv)
cfg Maybe (NotificationEnv notifyEnv)
-> Optic'
     An_AffineFold
     NoIx
     (Maybe (NotificationEnv notifyEnv))
     NotifyActionComplete
-> Maybe NotifyActionComplete
forall k s (is :: IxList) a.
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? (Prism
  (Maybe (NotificationEnv notifyEnv))
  (Maybe (NotificationEnv notifyEnv))
  (NotificationEnv notifyEnv)
  (NotificationEnv notifyEnv)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just Prism
  (Maybe (NotificationEnv notifyEnv))
  (Maybe (NotificationEnv notifyEnv))
  (NotificationEnv notifyEnv)
  (NotificationEnv notifyEnv)
-> Optic
     A_Lens
     NoIx
     (NotificationEnv notifyEnv)
     (NotificationEnv notifyEnv)
     NotifyActionsActive
     NotifyActionsActive
-> Optic
     An_AffineTraversal
     NoIx
     (Maybe (NotificationEnv notifyEnv))
     (Maybe (NotificationEnv notifyEnv))
     NotifyActionsActive
     NotifyActionsActive
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Lens
  NoIx
  (NotificationEnv notifyEnv)
  (NotificationEnv notifyEnv)
  NotifyActionsActive
  NotifyActionsActive
#actions Optic
  An_AffineTraversal
  NoIx
  (Maybe (NotificationEnv notifyEnv))
  (Maybe (NotificationEnv notifyEnv))
  NotifyActionsActive
  NotifyActionsActive
-> Optic
     An_AffineFold
     NoIx
     NotifyActionsActive
     NotifyActionsActive
     NotifyActionComplete
     NotifyActionComplete
-> Optic'
     An_AffineFold
     NoIx
     (Maybe (NotificationEnv notifyEnv))
     NotifyActionComplete
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  An_AffineFold
  NoIx
  NotifyActionsActive
  NotifyActionsActive
  NotifyActionComplete
  NotifyActionComplete
_NotifyActionsActiveCompleteAny) of
    Just NotifyActionComplete
NotifyActionCompleteAll ->
      NotifyMessage -> NotifyMessage -> NotifyUrgency -> m ()
forall (m :: Type -> Type) env notifyEnv.
(HasAnyError env, HasCallStack, HasCommands env, HasLogging env m,
 HasNotifyConfig env notifyEnv, MonadAtomic m, MonadCatch m,
 MonadNotify m, MonadReader env m, MonadRegionLogger m, MonadTime m,
 NotifyEnvF m ~ notifyEnv) =>
NotifyMessage -> NotifyMessage -> NotifyUrgency -> m ()
Notify.sendNotif (UnlinedText -> NotifyMessage
Notify.fromUnlined (UnlinedText -> NotifyMessage) -> UnlinedText -> NotifyMessage
forall a b. (a -> b) -> a -> b
$ UnlinedText
formattedCmd UnlinedText -> UnlinedText -> UnlinedText
forall a. Semigroup a => a -> a -> a
<> UnlinedText
" Finished") NotifyMessage
notifyMsg NotifyUrgency
urgency
    Just NotifyActionComplete
NotifyActionCompleteCommand ->
      NotifyMessage -> NotifyMessage -> NotifyUrgency -> m ()
forall (m :: Type -> Type) env notifyEnv.
(HasAnyError env, HasCallStack, HasCommands env, HasLogging env m,
 HasNotifyConfig env notifyEnv, MonadAtomic m, MonadCatch m,
 MonadNotify m, MonadReader env m, MonadRegionLogger m, MonadTime m,
 NotifyEnvF m ~ notifyEnv) =>
NotifyMessage -> NotifyMessage -> NotifyUrgency -> m ()
Notify.sendNotif (UnlinedText -> NotifyMessage
Notify.fromUnlined (UnlinedText -> NotifyMessage) -> UnlinedText -> NotifyMessage
forall a b. (a -> b) -> a -> b
$ UnlinedText
formattedCmd UnlinedText -> UnlinedText -> UnlinedText
forall a. Semigroup a => a -> a -> a
<> UnlinedText
" Finished") NotifyMessage
notifyMsg NotifyUrgency
urgency
    Maybe NotifyActionComplete
_ -> () -> m ()
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
{-# INLINEABLE runCommand #-}

-- | Prints the final log from the command (i.e. success/error message).
-- Has different log depending on the output (i.e. if we should log
-- multiple lines).
putCommandFinalLog ::
  forall m env.
  ( HasCallStack,
    HasFileLogging env,
    MonadAtomic m,
    MonadReader env m,
    MonadRegionLogger m
  ) =>
  TBQueue (LogRegion (Region m)) ->
  m ConsoleLog ->
  (FileLoggingEnv -> m FileLog) ->
  m ()
putCommandFinalLog :: forall (m :: Type -> Type) env.
(HasCallStack, HasFileLogging env, MonadAtomic m,
 MonadReader env m, MonadRegionLogger m) =>
TBQueue (LogRegion (Region m))
-> m ConsoleLog -> (FileLoggingEnv -> m FileLog) -> m ()
putCommandFinalLog TBQueue (LogRegion (Region m))
consoleQueue m ConsoleLog
mkConsoleLog FileLoggingEnv -> m FileLog
mkFileLog = do
  ConsoleLog
consoleLog <- m ConsoleLog
mkConsoleLog
  RegionLayout -> (Region m -> m ()) -> m ()
forall a. HasCallStack => RegionLayout -> (Region m -> m a) -> m a
forall (m :: Type -> Type) a.
(MonadRegionLogger m, HasCallStack) =>
RegionLayout -> (Region m -> m a) -> m a
withRegion RegionLayout
Linear ((Region m -> m ()) -> m ()) -> (Region m -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Region m
r -> TBQueue (LogRegion (Region m)) -> LogRegion (Region m) -> m ()
forall (m :: Type -> Type) a.
(HasCallStack, MonadAtomic m) =>
TBQueue a -> a -> m ()
writeTBQueueA' TBQueue (LogRegion (Region m))
consoleQueue (LogMode -> Region m -> ConsoleLog -> LogRegion (Region m)
forall r. LogMode -> r -> ConsoleLog -> LogRegion r
LogRegion LogMode
mode Region m
r ConsoleLog
consoleLog)

  Maybe FileLoggingEnv
mFileLogging <- (env -> Maybe FileLoggingEnv) -> m (Maybe FileLoggingEnv)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> Maybe FileLoggingEnv
forall env. HasFileLogging env => env -> Maybe FileLoggingEnv
getFileLogging
  Maybe FileLoggingEnv -> (FileLoggingEnv -> m ()) -> m ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe FileLoggingEnv
mFileLogging ((FileLoggingEnv -> m ()) -> m ())
-> (FileLoggingEnv -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \FileLoggingEnv
fl -> do
    FileLog
fileLog <- FileLoggingEnv -> m FileLog
mkFileLog FileLoggingEnv
fl
    FileLoggingEnv -> FileLog -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadAtomic m) =>
FileLoggingEnv -> FileLog -> m ()
Logging.logToFileQueue FileLoggingEnv
fl FileLog
fileLog
  where
    mode :: LogMode
mode = LogMode
LogModeFinish
{-# INLINEABLE putCommandFinalLog #-}

-- | All of the command result data needed for final log.
type CommandResultData m =
  Tuple4
    -- Urgency level for notifs
    NotifyUrgency
    -- Console log
    (m ConsoleLog)
    -- File log, if active
    (FileLoggingEnv -> m FileLog)
    -- Notif body
    NotifyMessage

-- | Gets log data from CommandResult.
mkResultData ::
  forall env m.
  ( HasCallStack,
    HasCommands env,
    MonadAtomic m,
    MonadReader env m,
    MonadTime m
  ) =>
  CommonLoggingEnv ->
  ConsoleLoggingEnv ->
  CommandP1 ->
  CommandResult ->
  CommandResultData m
mkResultData :: forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadAtomic m, MonadReader env m,
 MonadTime m) =>
CommonLoggingEnv
-> ConsoleLoggingEnv
-> CommandP1
-> CommandResult
-> CommandResultData m
mkResultData CommonLoggingEnv
commonLogging ConsoleLoggingEnv
consoleLogging CommandP1
cmd CommandResult
cmdResult =
  (NotifyUrgency
urgency, m ConsoleLog
consoleLog, FileLoggingEnv -> m FileLog
mMkFileLog, NotifyMessage
notifyMsg)
  where
    timerFormat :: TimerFormat
timerFormat = ConsoleLoggingEnv
consoleLogging ConsoleLoggingEnv
-> Optic' A_Lens NoIx ConsoleLoggingEnv TimerFormat -> TimerFormat
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ConsoleLoggingEnv TimerFormat
#timerFormat
    keyHide :: KeyHideSwitch
keyHide = CommonLoggingEnv
commonLogging CommonLoggingEnv
-> Optic' A_Lens NoIx CommonLoggingEnv KeyHideSwitch
-> KeyHideSwitch
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CommonLoggingEnv KeyHideSwitch
#keyHide

    (NotifyUrgency
urgency, LogLevel
lvl, RelativeTime
rt, [UnlinedText]
messages) = case CommandResult
cmdResult of
      CommandResultFailure RelativeTime
t (MkStderr []) -> (NotifyUrgency
NotifyUrgencyCritical, LogLevel
LevelError, RelativeTime
t, [UnlinedText
"<no error message>"])
      CommandResultFailure RelativeTime
t (MkStderr [UnlinedText]
errs) -> (NotifyUrgency
NotifyUrgencyCritical, LogLevel
LevelError, RelativeTime
t, [UnlinedText]
errs)
      CommandResultSuccess RelativeTime
t -> (NotifyUrgency
NotifyUrgencyNormal, LogLevel
LevelSuccess, RelativeTime
t, [])

    timeMsg :: UnlinedText
timeMsg = TimerFormat -> RelativeTime -> UnlinedText
TimerFormat.formatRelativeTime TimerFormat
timerFormat RelativeTime
rt
    notifyMsg :: NotifyMessage
notifyMsg = UnlinedText -> [UnlinedText] -> NotifyMessage
Notify.formatNotifyMessage UnlinedText
timeMsg [UnlinedText]
messages

    -- NOTE: Strip leading and trailing "whitespace only" lines, as we do not
    -- want them in the final logs. We do want internal whitespace.
    --
    -- Note that this whitespace originally comes from when Handle uses
    -- 'ShrunText.fromText :: UnlinedText -> List UnlinedText', which removes
    -- newlines but does nothing else i.e. whitespace is preserved.
    --
    -- We attempted stripping there, but that has other unwanted consequences,
    -- like removing internal whitespace when we buffer logs. Hence we go
    -- with the least invasive method that does what we want: strip them
    -- from the final result here.
    messages' :: [UnlinedText]
messages' =
      (UnlinedText -> Bool) -> [UnlinedText] -> [UnlinedText]
forall a. (a -> Bool) -> [a] -> [a]
L.dropWhileEnd UnlinedText -> Bool
Text.isWhitespace
        ([UnlinedText] -> [UnlinedText])
-> ([UnlinedText] -> [UnlinedText])
-> [UnlinedText]
-> [UnlinedText]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (UnlinedText -> Bool) -> [UnlinedText] -> [UnlinedText]
forall a. (a -> Bool) -> [a] -> [a]
L.dropWhile UnlinedText -> Bool
Text.isWhitespace
        ([UnlinedText] -> [UnlinedText]) -> [UnlinedText] -> [UnlinedText]
forall a b. (a -> b) -> a -> b
$ [UnlinedText]
messages

    (m ConsoleLog
consoleLog, FileLoggingEnv -> m FileLog
mMkFileLog) = case [UnlinedText]
messages' of
      -- 1. No message (success). Just print out the time.
      [] ->
        let log :: Log
log =
              MkLog
                { cmd :: Maybe CommandP1
cmd = CommandP1 -> Maybe CommandP1
forall a. a -> Maybe a
Just CommandP1
cmd,
                  msg :: LogMessage
msg = UnlinedText -> LogMessage
Types.fromUnlined UnlinedText
timeMsg,
                  LogLevel
lvl :: LogLevel
lvl :: LogLevel
lvl,
                  LogMode
mode :: LogMode
mode :: LogMode
mode
                }
         in ( KeyHideSwitch -> ConsoleLoggingEnv -> Log -> m ConsoleLog
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadAtomic m,
 MonadReader env m) =>
KeyHideSwitch -> ConsoleLoggingEnv -> Log -> m ConsoleLog
Formatting.formatConsoleLog KeyHideSwitch
keyHide ConsoleLoggingEnv
consoleLogging Log
log,
              \FileLoggingEnv
fl -> KeyHideSwitch -> FileLoggingEnv -> Log -> m FileLog
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadAtomic m, MonadReader env m,
 MonadTime m) =>
KeyHideSwitch -> FileLoggingEnv -> Log -> m FileLog
Formatting.formatFileLog KeyHideSwitch
keyHide FileLoggingEnv
fl Log
log
            )
      -- 2. Exactly one message. Print normally.
      [UnlinedText
m] ->
        let log :: Log
log =
              MkLog
                { cmd :: Maybe CommandP1
cmd = CommandP1 -> Maybe CommandP1
forall a. a -> Maybe a
Just CommandP1
cmd,
                  msg :: LogMessage
msg = UnlinedText -> LogMessage
Types.fromUnlined (UnlinedText -> LogMessage) -> UnlinedText -> LogMessage
forall a b. (a -> b) -> a -> b
$ UnlinedText
timeMsg UnlinedText -> UnlinedText -> UnlinedText
forall a. Semigroup a => a -> a -> a
<> UnlinedText
": " UnlinedText -> UnlinedText -> UnlinedText
forall a. Semigroup a => a -> a -> a
<> UnlinedText
m,
                  LogLevel
lvl :: LogLevel
lvl :: LogLevel
lvl,
                  LogMode
mode :: LogMode
mode :: LogMode
mode
                }
         in ( KeyHideSwitch -> ConsoleLoggingEnv -> Log -> m ConsoleLog
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadAtomic m,
 MonadReader env m) =>
KeyHideSwitch -> ConsoleLoggingEnv -> Log -> m ConsoleLog
Formatting.formatConsoleLog KeyHideSwitch
keyHide ConsoleLoggingEnv
consoleLogging Log
log,
              \FileLoggingEnv
fl -> KeyHideSwitch -> FileLoggingEnv -> Log -> m FileLog
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadAtomic m, MonadReader env m,
 MonadTime m) =>
KeyHideSwitch -> FileLoggingEnv -> Log -> m FileLog
Formatting.formatFileLog KeyHideSwitch
keyHide FileLoggingEnv
fl Log
log
            )
      -- Received multiple messages (lines). Use custom formatters.
      (UnlinedText
m : [UnlinedText]
ms) ->
        let logs :: NonEmpty Log
logs =
              (UnlinedText
timeMsg UnlinedText -> [UnlinedText] -> NonEmpty UnlinedText
forall a. a -> [a] -> NonEmpty a
:| UnlinedText
m UnlinedText -> [UnlinedText] -> [UnlinedText]
forall a. a -> [a] -> [a]
: [UnlinedText]
ms) NonEmpty UnlinedText -> (UnlinedText -> Log) -> NonEmpty Log
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> \UnlinedText
msg ->
                MkLog
                  { cmd :: Maybe CommandP1
cmd = CommandP1 -> Maybe CommandP1
forall a. a -> Maybe a
Just CommandP1
cmd,
                    msg :: LogMessage
msg = UnlinedText -> LogMessage
Types.fromUnlined UnlinedText
msg,
                    LogLevel
lvl :: LogLevel
lvl :: LogLevel
lvl,
                    LogMode
mode :: LogMode
mode :: LogMode
mode
                  }
         in ( KeyHideSwitch -> ConsoleLoggingEnv -> NonEmpty Log -> m ConsoleLog
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadAtomic m,
 MonadReader env m) =>
KeyHideSwitch -> ConsoleLoggingEnv -> NonEmpty Log -> m ConsoleLog
Formatting.formatConsoleMultiLineLogs KeyHideSwitch
keyHide ConsoleLoggingEnv
consoleLogging NonEmpty Log
logs,
              \FileLoggingEnv
fl -> KeyHideSwitch -> FileLoggingEnv -> NonEmpty Log -> m FileLog
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadAtomic m, MonadReader env m,
 MonadTime m) =>
KeyHideSwitch -> FileLoggingEnv -> NonEmpty Log -> m FileLog
Formatting.formatFileMultiLineLogs KeyHideSwitch
keyHide FileLoggingEnv
fl NonEmpty Log
logs
            )

    mode :: LogMode
mode = LogMode
LogModeFinish

printFinalResult ::
  forall m env notifyEnv e b.
  ( Exception e,
    HasAnyError env,
    HasCallStack,
    HasCommands env,
    HasLogging env m,
    HasNotifyConfig env notifyEnv,
    MonadAtomic m,
    MonadCatch m,
    MonadNotify m,
    MonadReader env m,
    MonadRegionLogger m,
    MonadTime m,
    NotifyEnvF m ~ notifyEnv
  ) =>
  TimeSpec ->
  Either e b ->
  m ()
printFinalResult :: forall (m :: Type -> Type) env notifyEnv e b.
(Exception e, HasAnyError env, HasCallStack, HasCommands env,
 HasLogging env m, HasNotifyConfig env notifyEnv, MonadAtomic m,
 MonadCatch m, MonadNotify m, MonadReader env m,
 MonadRegionLogger m, MonadTime m, NotifyEnvF m ~ notifyEnv) =>
TimeSpec -> Either e b -> m ()
printFinalResult TimeSpec
totalTime Either e b
result = RegionLayout -> (Region m -> m ()) -> m ()
forall a. HasCallStack => RegionLayout -> (Region m -> m a) -> m a
forall (m :: Type -> Type) a.
(MonadRegionLogger m, HasCallStack) =>
RegionLayout -> (Region m -> m a) -> m a
withRegion RegionLayout
Linear ((Region m -> m ()) -> m ()) -> (Region m -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Region m
r -> do
  Either e b -> (e -> m ()) -> m ()
forall (f :: Type -> Type) a b.
Applicative f =>
Either a b -> (a -> f ()) -> f ()
Utils.whenLeft Either e b
result ((e -> m ()) -> m ()) -> (e -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \e
ex -> do
    let errMsg :: UnlinedText
errMsg =
          [UnlinedText] -> UnlinedText
forall a. Monoid a => [a] -> a
mconcat
            [ UnlinedText
"Encountered an exception. This is likely not an error in any ",
              UnlinedText
"of the commands run but rather an error in Shrun itself: ",
              Text -> UnlinedText
ShrunText.fromTextReplace (Text -> UnlinedText) -> Text -> UnlinedText
forall a b. (a -> b) -> a -> b
$ e -> Text
forall e. Exception e => e -> Text
displayExceptiont e
ex
            ]
        fatalLog :: Log
fatalLog =
          MkLog
            { cmd :: Maybe CommandP1
cmd = Maybe CommandP1
forall a. Maybe a
Nothing,
              msg :: LogMessage
msg = UnlinedText -> LogMessage
Types.fromUnlined UnlinedText
errMsg,
              lvl :: LogLevel
lvl = LogLevel
LevelFatal,
              LogMode
mode :: LogMode
mode :: LogMode
mode
            }

    Region m -> Log -> m ()
forall (m :: Type -> Type) env.
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadReader env m, MonadTime m) =>
Region m -> Log -> m ()
Logging.putRegionLog Region m
r Log
fatalLog

    -- update anyError
    m ()
forall env (m :: Type -> Type).
(HasAnyError env, HasCallStack, MonadAtomic m,
 MonadReader env m) =>
m ()
setAnyErrorTrue

  -- print out any unfinished commands
  (Maybe (NonEmpty Log)
mWaitingLog, Maybe (NonEmpty Log)
mRunningLog) <- m (Maybe (NonEmpty Log), Maybe (NonEmpty Log))
forall (m :: Type -> Type) env.
(HasCallStack, HasCommands env, HasCommonLogging env,
 MonadAtomic m, MonadReader env m) =>
m (Maybe (NonEmpty Log), Maybe (NonEmpty Log))
Logging.mkUnfinishedCmdLogs
  Maybe (NonEmpty Log) -> (NonEmpty Log -> m ()) -> m ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (NonEmpty Log)
mWaitingLog (Region m -> NonEmpty Log -> m ()
forall (m :: Type -> Type) env.
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadReader env m, MonadTime m) =>
Region m -> NonEmpty Log -> m ()
Logging.putRegionMultiLineLog Region m
r)
  Maybe (NonEmpty Log) -> (NonEmpty Log -> m ()) -> m ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (NonEmpty Log)
mRunningLog (Region m -> NonEmpty Log -> m ()
forall (m :: Type -> Type) env.
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadReader env m, MonadTime m) =>
Region m -> NonEmpty Log -> m ()
Logging.putRegionMultiLineLog Region m
r)

  UnlinedText
totalTimeTxt <- TimeSpec -> m UnlinedText
forall env (m :: Type -> Type).
(HasConsoleLogging env (Region m), MonadReader env m) =>
TimeSpec -> m UnlinedText
formatTimeSpec TimeSpec
totalTime
  let finalLog :: Log
finalLog =
        MkLog
          { cmd :: Maybe CommandP1
cmd = Maybe CommandP1
forall a. Maybe a
Nothing,
            msg :: LogMessage
msg = UnlinedText -> LogMessage
Types.fromUnlined UnlinedText
totalTimeTxt,
            lvl :: LogLevel
lvl = LogLevel
LevelFinished,
            mode :: LogMode
mode = LogMode
LogModeFinish
          }

  -- Send off a 'finished' notification
  Bool
anyError <- TVar Bool -> m Bool
forall (m :: Type -> Type) a.
(HasCallStack, MonadAtomic m) =>
TVar a -> m a
readTVarA' (TVar Bool -> m Bool) -> m (TVar Bool) -> m Bool
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< (env -> TVar Bool) -> m (TVar Bool)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> TVar Bool
forall env. HasAnyError env => env -> TVar Bool
getAnyError
  let urgency :: NotifyUrgency
urgency = if Bool
anyError then NotifyUrgency
NotifyUrgencyCritical else NotifyUrgency
NotifyUrgencyNormal
      notifyBody :: NotifyMessage
notifyBody = UnlinedText -> [UnlinedText] -> NotifyMessage
Notify.formatNotifyMessage UnlinedText
totalTimeTxt []

  -- Sent off notif if NotifyActionCompleteAll or NotifyActionCompleteFinal is set
  Maybe (NotificationEnv notifyEnv)
cfg <- (env -> Maybe (NotificationEnv notifyEnv))
-> m (Maybe (NotificationEnv notifyEnv))
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks (forall env r.
HasNotifyConfig env r =>
env -> Maybe (NotificationEnv r)
getNotifyConfig @_ @notifyEnv)
  case Maybe (NotificationEnv notifyEnv)
cfg Maybe (NotificationEnv notifyEnv)
-> Optic'
     An_AffineFold
     NoIx
     (Maybe (NotificationEnv notifyEnv))
     NotifyActionComplete
-> Maybe NotifyActionComplete
forall k s (is :: IxList) a.
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? (Prism
  (Maybe (NotificationEnv notifyEnv))
  (Maybe (NotificationEnv notifyEnv))
  (NotificationEnv notifyEnv)
  (NotificationEnv notifyEnv)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just Prism
  (Maybe (NotificationEnv notifyEnv))
  (Maybe (NotificationEnv notifyEnv))
  (NotificationEnv notifyEnv)
  (NotificationEnv notifyEnv)
-> Optic
     A_Lens
     NoIx
     (NotificationEnv notifyEnv)
     (NotificationEnv notifyEnv)
     NotifyActionsActive
     NotifyActionsActive
-> Optic
     An_AffineTraversal
     NoIx
     (Maybe (NotificationEnv notifyEnv))
     (Maybe (NotificationEnv notifyEnv))
     NotifyActionsActive
     NotifyActionsActive
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Lens
  NoIx
  (NotificationEnv notifyEnv)
  (NotificationEnv notifyEnv)
  NotifyActionsActive
  NotifyActionsActive
#actions Optic
  An_AffineTraversal
  NoIx
  (Maybe (NotificationEnv notifyEnv))
  (Maybe (NotificationEnv notifyEnv))
  NotifyActionsActive
  NotifyActionsActive
-> Optic
     An_AffineFold
     NoIx
     NotifyActionsActive
     NotifyActionsActive
     NotifyActionComplete
     NotifyActionComplete
-> Optic'
     An_AffineFold
     NoIx
     (Maybe (NotificationEnv notifyEnv))
     NotifyActionComplete
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  An_AffineFold
  NoIx
  NotifyActionsActive
  NotifyActionsActive
  NotifyActionComplete
  NotifyActionComplete
_NotifyActionsActiveCompleteAny) of
    Just NotifyActionComplete
NotifyActionCompleteAll -> NotifyMessage -> NotifyMessage -> NotifyUrgency -> m ()
forall (m :: Type -> Type) env notifyEnv.
(HasAnyError env, HasCallStack, HasCommands env, HasLogging env m,
 HasNotifyConfig env notifyEnv, MonadAtomic m, MonadCatch m,
 MonadNotify m, MonadReader env m, MonadRegionLogger m, MonadTime m,
 NotifyEnvF m ~ notifyEnv) =>
NotifyMessage -> NotifyMessage -> NotifyUrgency -> m ()
Notify.sendNotif NotifyMessage
"Shrun Finished" NotifyMessage
notifyBody NotifyUrgency
urgency
    Just NotifyActionComplete
NotifyActionCompleteFinal -> NotifyMessage -> NotifyMessage -> NotifyUrgency -> m ()
forall (m :: Type -> Type) env notifyEnv.
(HasAnyError env, HasCallStack, HasCommands env, HasLogging env m,
 HasNotifyConfig env notifyEnv, MonadAtomic m, MonadCatch m,
 MonadNotify m, MonadReader env m, MonadRegionLogger m, MonadTime m,
 NotifyEnvF m ~ notifyEnv) =>
NotifyMessage -> NotifyMessage -> NotifyUrgency -> m ()
Notify.sendNotif NotifyMessage
"Shrun Finished" NotifyMessage
notifyBody NotifyUrgency
urgency
    Maybe NotifyActionComplete
_ -> () -> m ()
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()

  Region m -> Log -> m ()
forall (m :: Type -> Type) env.
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadReader env m, MonadTime m) =>
Region m -> Log -> m ()
Logging.putRegionLog Region m
r Log
finalLog
  where
    mode :: LogMode
mode = LogMode
LogModeFinish
{-# INLINEABLE printFinalResult #-}

formatTimeSpec ::
  forall env m.
  ( HasConsoleLogging env (Region m),
    MonadReader env m
  ) =>
  TimeSpec ->
  m UnlinedText
formatTimeSpec :: forall env (m :: Type -> Type).
(HasConsoleLogging env (Region m), MonadReader env m) =>
TimeSpec -> m UnlinedText
formatTimeSpec TimeSpec
totalTime = do
  TimerFormat
timerFormat <- (env -> TimerFormat) -> m TimerFormat
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks (Optic'
  A_Lens
  NoIx
  (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)),
   IORef (Maybe (Region m)))
  TimerFormat
-> (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)),
    IORef (Maybe (Region m)))
-> TimerFormat
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Lens
  (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)),
   IORef (Maybe (Region m)))
  (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)),
   IORef (Maybe (Region m)))
  ConsoleLoggingEnv
  ConsoleLoggingEnv
forall s t a b. Field1 s t a b => Lens s t a b
_1 Lens
  (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)),
   IORef (Maybe (Region m)))
  (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)),
   IORef (Maybe (Region m)))
  ConsoleLoggingEnv
  ConsoleLoggingEnv
-> Optic' A_Lens NoIx ConsoleLoggingEnv TimerFormat
-> Optic'
     A_Lens
     NoIx
     (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)),
      IORef (Maybe (Region m)))
     TimerFormat
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic' A_Lens NoIx ConsoleLoggingEnv TimerFormat
#timerFormat) ((ConsoleLoggingEnv, TBQueue (LogRegion (Region m)),
  IORef (Maybe (Region m)))
 -> TimerFormat)
-> (env
    -> (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)),
        IORef (Maybe (Region m))))
-> env
-> TimerFormat
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall env r.
HasConsoleLogging env r =>
env -> (ConsoleLoggingEnv, TBQueue (LogRegion r), IORef (Maybe r))
getConsoleLogging @_ @(Region m))
  pure
    $ TimerFormat -> RelativeTime -> UnlinedText
TimerFormat.formatRelativeTime
      TimerFormat
timerFormat
      (TimeSpec -> RelativeTime
Utils.timeSpecToRelTime TimeSpec
totalTime)
{-# INLINEABLE formatTimeSpec #-}

counter ::
  forall env m.
  ( HasAnyError env,
    HasCallStack,
    HasCommands env,
    HasLogging env m,
    HasTimeout env,
    MonadAtomic m,
    MonadIORef m,
    MonadReader env m,
    MonadRegionLogger m,
    MonadThread m,
    MonadTime m
  ) =>
  m ()
counter :: forall env (m :: Type -> Type).
(HasAnyError env, HasCallStack, HasCommands env, HasLogging env m,
 HasTimeout env, MonadAtomic m, MonadIORef m, MonadReader env m,
 MonadRegionLogger m, MonadThread m, MonadTime m) =>
m ()
counter = do
  -- HACK: This brief delay is so that our timer starts "last" i.e. after each
  -- individual command. This way the running timer console region is below all
  -- the commands' in the console.
  Natural -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadThread m) =>
Natural -> m ()
microsleep Natural
100_000
  RegionLayout -> (Region m -> m ()) -> m ()
forall a. HasCallStack => RegionLayout -> (Region m -> m a) -> m a
forall (m :: Type -> Type) a.
(MonadRegionLogger m, HasCallStack) =>
RegionLayout -> (Region m -> m a) -> m a
withRegion RegionLayout
Linear ((Region m -> m ()) -> m ()) -> (Region m -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Region m
r -> do
    (ConsoleLoggingEnv
_, TBQueue (LogRegion (Region m))
_, IORef (Maybe (Region m))
regionVar) <- (env
 -> (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)),
     IORef (Maybe (Region m))))
-> m (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)),
      IORef (Maybe (Region m)))
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks (forall env r.
HasConsoleLogging env r =>
env -> (ConsoleLoggingEnv, TBQueue (LogRegion r), IORef (Maybe r))
getConsoleLogging @_ @(Region m))
    IORef (Maybe (Region m)) -> Maybe (Region m) -> m ()
forall a. HasCallStack => IORef a -> a -> m ()
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
IORef a -> a -> m ()
writeIORef' IORef (Maybe (Region m))
regionVar (Region m -> Maybe (Region m)
forall a. a -> Maybe a
Just Region m
r)

    WithDisabled Timeout
timeout <- (env -> WithDisabled Timeout) -> m (WithDisabled Timeout)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> WithDisabled Timeout
forall env. HasTimeout env => env -> WithDisabled Timeout
getTimeout
    IORef Natural
timer <- Natural -> m (IORef Natural)
forall a. HasCallStack => a -> m (IORef a)
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
a -> m (IORef a)
newIORef' Natural
0
    m Bool -> m () -> m ()
forall (m :: Type -> Type) a. Monad m => m Bool -> m a -> m ()
Utils.whileM_ (Region m -> IORef Natural -> WithDisabled Timeout -> m Bool
forall (m :: Type -> Type) env.
(HasAnyError env, HasCallStack, HasCommands env, HasLogging env m,
 MonadAtomic m, MonadIORef m, MonadReader env m, MonadTime m) =>
Region m -> IORef Natural -> WithDisabled Timeout -> m Bool
keepRunning Region m
r IORef Natural
timer WithDisabled Timeout
timeout) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      Natural -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadThread m) =>
Natural -> m ()
sleep Natural
1
      Natural
elapsed <- IORef Natural -> (Natural -> (Natural, Natural)) -> m Natural
forall a b. HasCallStack => IORef a -> (a -> (a, b)) -> m b
forall (m :: Type -> Type) a b.
(MonadIORef m, HasCallStack) =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef Natural
timer ((Natural -> (Natural, Natural)) -> m Natural)
-> (Natural -> (Natural, Natural)) -> m Natural
forall a b. (a -> b) -> a -> b
$ \Natural
t -> (Natural
t Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1, Natural
t Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1)
      Region m -> Natural -> m ()
forall (m :: Type -> Type) env.
(HasCallStack, HasCommands env, HasCommonLogging env,
 HasConsoleLogging env (Region m), MonadAtomic m,
 MonadReader env m) =>
Region m -> Natural -> m ()
logCounter Region m
r Natural
elapsed

    m ()
forall env (m :: Type -> Type).
(HasTimeout env, MonadAtomic m, MonadReader env m) =>
m ()
setTimedOut
{-# INLINEABLE counter #-}

-- | Periodically attempts to read stdin, so any entered keystrokes are
-- thrown away. Does not apply to commands that spawn sudo, sadly.
drainStdinLoop ::
  ( MonadCatch m,
    MonadHandleReader m,
    MonadThread m
  ) =>
  m void
drainStdinLoop :: forall (m :: Type -> Type) void.
(MonadCatch m, MonadHandleReader m, MonadThread m) =>
m void
drainStdinLoop = m void
forall {a}. m a
go
  where
    go :: m a
go = do
      m ()
forall (m :: Type -> Type).
(MonadCatch m, MonadHandleReader m) =>
m ()
Utils.drainStdin
      -- Choosing a good drain period is pretty ad-hoc. We have two goals:
      --
      --   1. Prevent stdin from appearing after shrun exits.
      --   2. Prevent stdin from being held in memory for shrun's duration.
      --
      -- 1 is mostly accomplished by having a single drain at the end, so we
      -- theoretically do not need this loop at all. The loop is only
      -- necessary for 2.
      --
      -- However, it could be the case that the amount of stdin is greater
      -- than a single drain amount, in which case having periodic drains
      -- would be a mitigation. This is pretty unlikely as any stdin is
      -- likely to be a mistake (i.e. merely a few keystrokes), but it is
      -- worth mentioning.
      --
      -- We therefore have the following considerations:
      --
      --   - The importance of periodic drains is pretty low, and we do
      --     not want performance to be impacted.
      --
      --   - This is likely only a benefit to long-lived commands i.e.
      --     minutes.
      --
      --   - Hence while _some_ periodic drain is probably a good idea,
      --     we should make the period long enough that it is not
      --     noticeable.
      --
      Natural -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadThread m) =>
Natural -> m ()
sleep Natural
60
      m a
go
{-# INLINEABLE drainStdinLoop #-}

logCounter ::
  forall m env.
  ( HasCallStack,
    HasCommands env,
    HasCommonLogging env,
    HasConsoleLogging env (Region m),
    MonadAtomic m,
    MonadReader env m
  ) =>
  Region m ->
  Natural ->
  m ()
logCounter :: forall (m :: Type -> Type) env.
(HasCallStack, HasCommands env, HasCommonLogging env,
 HasConsoleLogging env (Region m), MonadAtomic m,
 MonadReader env m) =>
Region m -> Natural -> m ()
logCounter Region m
region Natural
elapsed = do
  (ConsoleLoggingEnv
consoleLogging, TBQueue (LogRegion (Region m))
queue, IORef (Maybe (Region m))
_) <- (env
 -> (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)),
     IORef (Maybe (Region m))))
-> m (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)),
      IORef (Maybe (Region m)))
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks (forall env r.
HasConsoleLogging env r =>
env -> (ConsoleLoggingEnv, TBQueue (LogRegion r), IORef (Maybe r))
getConsoleLogging @_ @(Region m))
  KeyHideSwitch
keyHide <- (env -> KeyHideSwitch) -> m KeyHideSwitch
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks (Optic' A_Lens NoIx CommonLoggingEnv KeyHideSwitch
-> CommonLoggingEnv -> KeyHideSwitch
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx CommonLoggingEnv KeyHideSwitch
#keyHide (CommonLoggingEnv -> KeyHideSwitch)
-> (env -> CommonLoggingEnv) -> env -> KeyHideSwitch
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. env -> CommonLoggingEnv
forall env. HasCommonLogging env => env -> CommonLoggingEnv
getCommonLogging)

  let timerFormat :: TimerFormat
timerFormat = ConsoleLoggingEnv
consoleLogging ConsoleLoggingEnv
-> Optic' A_Lens NoIx ConsoleLoggingEnv TimerFormat -> TimerFormat
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ConsoleLoggingEnv TimerFormat
#timerFormat
      msg :: LogMessage
msg = UnlinedText -> LogMessage
Types.fromUnlined (UnlinedText -> LogMessage) -> UnlinedText -> LogMessage
forall a b. (a -> b) -> a -> b
$ TimerFormat -> Natural -> UnlinedText
TimerFormat.formatSeconds TimerFormat
timerFormat Natural
elapsed
      lg :: Log
lg =
        MkLog
          { cmd :: Maybe CommandP1
cmd = Maybe CommandP1
forall a. Maybe a
Nothing,
            LogMessage
msg :: LogMessage
msg :: LogMessage
msg,
            lvl :: LogLevel
lvl = LogLevel
LevelTimer,
            mode :: LogMode
mode = LogMode
LogModeSet
          }
  ConsoleLog
formatted <- KeyHideSwitch -> ConsoleLoggingEnv -> Log -> m ConsoleLog
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadAtomic m,
 MonadReader env m) =>
KeyHideSwitch -> ConsoleLoggingEnv -> Log -> m ConsoleLog
Formatting.formatConsoleLog KeyHideSwitch
keyHide ConsoleLoggingEnv
consoleLogging Log
lg
  let regionLog :: LogRegion (Region m)
regionLog = LogMode -> Region m -> ConsoleLog -> LogRegion (Region m)
forall r. LogMode -> r -> ConsoleLog -> LogRegion r
LogRegion LogMode
LogModeSet Region m
region ConsoleLog
formatted
  TBQueue (LogRegion (Region m)) -> LogRegion (Region m) -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadAtomic m) =>
TBQueue (LogRegion (Region m)) -> LogRegion (Region m) -> m ()
Logging.regionLogToConsoleQueue TBQueue (LogRegion (Region m))
queue LogRegion (Region m)
regionLog
{-# INLINEABLE logCounter #-}

keepRunning ::
  forall m env.
  ( HasAnyError env,
    HasCallStack,
    HasCommands env,
    HasLogging env m,
    MonadAtomic m,
    MonadIORef m,
    MonadReader env m,
    MonadTime m
  ) =>
  Region m ->
  IORef Natural ->
  WithDisabled Timeout ->
  m Bool
keepRunning :: forall (m :: Type -> Type) env.
(HasAnyError env, HasCallStack, HasCommands env, HasLogging env m,
 MonadAtomic m, MonadIORef m, MonadReader env m, MonadTime m) =>
Region m -> IORef Natural -> WithDisabled Timeout -> m Bool
keepRunning Region m
region IORef Natural
timer WithDisabled Timeout
mto = do
  Natural
elapsed <- IORef Natural -> m Natural
forall a. HasCallStack => IORef a -> m a
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
IORef a -> m a
readIORef' IORef Natural
timer
  if Natural -> WithDisabled Timeout -> Bool
timedOut Natural
elapsed WithDisabled Timeout
mto
    then do
      -- update anyError
      m ()
forall env (m :: Type -> Type).
(HasAnyError env, HasCallStack, MonadAtomic m,
 MonadReader env m) =>
m ()
setAnyErrorTrue
      let log :: Log
log =
            MkLog
              { cmd :: Maybe CommandP1
cmd = Maybe CommandP1
forall a. Maybe a
Nothing,
                msg :: LogMessage
msg = LogMessage
"Timed out",
                lvl :: LogLevel
lvl = LogLevel
LevelWarn,
                mode :: LogMode
mode = LogMode
LogModeFinish
              }
      Region m -> Log -> m ()
forall (m :: Type -> Type) env.
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadReader env m, MonadTime m) =>
Region m -> Log -> m ()
Logging.putRegionLog Region m
region Log
log
      pure Bool
False
    else Bool -> m Bool
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Bool
True
{-# INLINEABLE keepRunning #-}

timedOut :: Natural -> WithDisabled Timeout -> Bool
timedOut :: Natural -> WithDisabled Timeout -> Bool
timedOut Natural
_ WithDisabled Timeout
Disabled = Bool
False
timedOut Natural
timer (With (MkTimeout Natural
t)) = Natural
timer Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
t

pollQueueToConsole ::
  ( HasCallStack,
    MonadAtomic m,
    MonadMask m,
    MonadRegionLogger m
  ) =>
  TBQueue (LogRegion (Region m)) ->
  m void
pollQueueToConsole :: forall (m :: Type -> Type) void.
(HasCallStack, MonadAtomic m, MonadMask m, MonadRegionLogger m) =>
TBQueue (LogRegion (Region m)) -> m void
pollQueueToConsole TBQueue (LogRegion (Region m))
queue = do
  -- NOTE: Same masking behavior as pollQueueToFile.
  m () -> m void
forall (f :: Type -> Type) a b. Applicative f => f a -> f b
forever (m () -> m void) -> m () -> m void
forall a b. (a -> b) -> a -> b
$ TBQueue (LogRegion (Region m))
-> (LogRegion (Region m) -> m ()) -> m ()
forall (m :: Type -> Type) a b.
(HasCallStack, MonadAtomic m, MonadMask m) =>
TBQueue a -> (a -> m b) -> m ()
Utils.atomicReadWrite TBQueue (LogRegion (Region m))
queue LogRegion (Region m) -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadRegionLogger m) =>
LogRegion (Region m) -> m ()
printConsoleLog
{-# INLINEABLE pollQueueToConsole #-}

printConsoleLog ::
  ( HasCallStack,
    MonadRegionLogger m
  ) =>
  LogRegion (Region m) ->
  m ()
printConsoleLog :: forall (m :: Type -> Type).
(HasCallStack, MonadRegionLogger m) =>
LogRegion (Region m) -> m ()
printConsoleLog (LogNoRegion ConsoleLog
consoleLog) = Text -> m ()
forall (m :: Type -> Type).
(MonadRegionLogger m, HasCallStack) =>
Text -> m ()
logGlobal (ConsoleLog
consoleLog ConsoleLog -> Optic' A_Getter NoIx ConsoleLog Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Getter NoIx ConsoleLog Text
#unConsoleLog)
printConsoleLog (LogRegion LogMode
m Region m
r ConsoleLog
consoleLog) = LogMode -> Region m -> Text -> m ()
forall (m :: Type -> Type).
(MonadRegionLogger m, HasCallStack) =>
LogMode -> Region m -> Text -> m ()
logRegion LogMode
m Region m
r (ConsoleLog
consoleLog ConsoleLog -> Optic' A_Getter NoIx ConsoleLog Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Getter NoIx ConsoleLog Text
#unConsoleLog)
{-# INLINEABLE printConsoleLog #-}

pollQueueToFile ::
  ( HasCallStack,
    MonadAtomic m,
    MonadHandleWriter m,
    MonadMask m
  ) =>
  FileLoggingEnv ->
  m void
pollQueueToFile :: forall (m :: Type -> Type) void.
(HasCallStack, MonadAtomic m, MonadHandleWriter m, MonadMask m) =>
FileLoggingEnv -> m void
pollQueueToFile FileLoggingEnv
fileLogging = do
  m () -> m void
forall (f :: Type -> Type) a b. Applicative f => f a -> f b
forever
    (m () -> m void) -> m () -> m void
forall a b. (a -> b) -> a -> b
$
    -- NOTE: Read+write needs to be atomic, otherwise we can lose logs
    -- (i.e. thread reads the log and is cancelled before it can write it).
    -- Hence the mask.
    TBQueue FileLog -> (FileLog -> m ()) -> m ()
forall (m :: Type -> Type) a b.
(HasCallStack, MonadAtomic m, MonadMask m) =>
TBQueue a -> (a -> m b) -> m ()
Utils.atomicReadWrite TBQueue FileLog
queue (LockedHandle 'HandleModeWrite -> FileLog -> m ()
forall (p :: HandleMode) (m :: Type -> Type).
(CanWrite p, HasCallStack, MonadHandleWriter m) =>
LockedHandle p -> FileLog -> m ()
Logging.logFile LockedHandle 'HandleModeWrite
h)
  where
    MkFileLogOpened LockedHandle 'HandleModeWrite
h OsPath
_ TBQueue FileLog
queue = FileLoggingEnv
fileLogging FileLoggingEnv
-> Optic' A_Lens NoIx FileLoggingEnv FileLogOpened -> FileLogOpened
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx FileLoggingEnv FileLogOpened
#file
{-# INLINEABLE pollQueueToFile #-}

-- | Cancels running commands and prints a final log message about going
-- down. Intended to be used when shrun has been cancelled.
teardown ::
  forall m env notifyEnv.
  ( HasAnyError env,
    HasCallStack,
    HasCommands env,
    HasLogging env m,
    HasNotifyConfig env notifyEnv,
    MonadAtomic m,
    MonadCatch m,
    MonadHandleWriter m,
    MonadNotify m,
    MonadProcess m,
    MonadReader env m,
    MonadRegionLogger m,
    MonadTime m,
    NotifyEnvF m ~ notifyEnv
  ) =>
  Double ->
  m ()
teardown :: forall (m :: Type -> Type) env notifyEnv.
(HasAnyError env, HasCallStack, HasCommands env, HasLogging env m,
 HasNotifyConfig env notifyEnv, MonadAtomic m, MonadCatch m,
 MonadHandleWriter m, MonadNotify m, MonadProcess m,
 MonadReader env m, MonadRegionLogger m, MonadTime m,
 NotifyEnvF m ~ notifyEnv) =>
Double -> m ()
teardown Double
startTime = do
  Double
endTime <- m Double
forall (m :: Type -> Type). (MonadTime m, HasCallStack) => m Double
Time.getMonotonicTime
  let totalTime :: TimeSpec
totalTime = Double -> TimeSpec
Time.fromSeconds (Double -> TimeSpec) -> Double -> TimeSpec
forall a b. (a -> b) -> a -> b
$ Double
endTime Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
startTime
  UnlinedText
timeFormatted <- TimeSpec -> m UnlinedText
forall env (m :: Type -> Type).
(HasConsoleLogging env (Region m), MonadReader env m) =>
TimeSpec -> m UnlinedText
formatTimeSpec TimeSpec
totalTime

  let cancelTasksMsg :: UnlinedText
cancelTasksMsg = UnlinedText
"Received cancel"
      finalErrMsg :: UnlinedText
finalErrMsg = UnlinedText
cancelTasksMsg UnlinedText -> UnlinedText -> UnlinedText
forall a. Semigroup a => a -> a -> a
<> UnlinedText
" after running for: " UnlinedText -> UnlinedText -> UnlinedText
forall a. Semigroup a => a -> a -> a
<> UnlinedText
timeFormatted

  -- update anyError
  m ()
forall env (m :: Type -> Type).
(HasAnyError env, HasCallStack, MonadAtomic m,
 MonadReader env m) =>
m ()
setAnyErrorTrue

  (Maybe (NonEmpty Log)
mWaitingLog, Maybe (NonEmpty Log)
mRunningLog) <- m (Maybe (NonEmpty Log), Maybe (NonEmpty Log))
forall (m :: Type -> Type) env.
(HasCallStack, HasCommands env, HasCommonLogging env,
 MonadAtomic m, MonadReader env m) =>
m (Maybe (NonEmpty Log), Maybe (NonEmpty Log))
Logging.mkUnfinishedCmdLogs

  -- NOTE: Manual logging because the logging queues have been shutdown at this
  -- point. We must write to the console (logRegion) and file (logFile)
  -- directly.

  -- 1. Send message about cancelling commands.
  (NonEmpty Log -> m ()) -> Maybe (NonEmpty Log) -> m ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ NonEmpty Log -> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadHandleWriter m, MonadReader env m, MonadRegionLogger m,
 MonadTime m) =>
NonEmpty Log -> m ()
Logging.putRegionMultiLineLogDirect Maybe (NonEmpty Log)
mWaitingLog
  (NonEmpty Log -> m ()) -> Maybe (NonEmpty Log) -> m ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ NonEmpty Log -> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadHandleWriter m, MonadReader env m, MonadRegionLogger m,
 MonadTime m) =>
NonEmpty Log -> m ()
Logging.putRegionMultiLineLogDirect Maybe (NonEmpty Log)
mRunningLog

  -- Clean up remaining commands.
  m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadCatch m, MonadHandleWriter m, MonadProcess m,
 MonadReader env m, MonadRegionLogger m, MonadTime m) =>
m ()
cleanupCommands

  let notifyBody :: NotifyMessage
notifyBody = UnlinedText -> [UnlinedText] -> NotifyMessage
Notify.formatNotifyMessage UnlinedText
finalErrMsg []

  -- 2. Send finished message.
  let finalLog :: Log
finalLog =
        MkLog
          { cmd :: Maybe CommandP1
cmd = Maybe CommandP1
forall a. Maybe a
Nothing,
            msg :: LogMessage
msg = UnlinedText -> LogMessage
Types.fromUnlined UnlinedText
finalErrMsg,
            lvl :: LogLevel
lvl = LogLevel
LevelKilled,
            mode :: LogMode
mode = LogMode
LogModeFinish
          }

  Log -> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadHandleWriter m, MonadReader env m, MonadRegionLogger m,
 MonadTime m) =>
Log -> m ()
Logging.putRegionLogDirect Log
finalLog

  -- 3. Send notification
  Maybe (NotificationEnv notifyEnv)
cfg <- (env -> Maybe (NotificationEnv notifyEnv))
-> m (Maybe (NotificationEnv notifyEnv))
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks (forall env r.
HasNotifyConfig env r =>
env -> Maybe (NotificationEnv r)
getNotifyConfig @_ @notifyEnv)
  case Maybe (NotificationEnv notifyEnv)
cfg Maybe (NotificationEnv notifyEnv)
-> Optic'
     An_AffineFold
     NoIx
     (Maybe (NotificationEnv notifyEnv))
     NotifyActionComplete
-> Maybe NotifyActionComplete
forall k s (is :: IxList) a.
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? (Prism
  (Maybe (NotificationEnv notifyEnv))
  (Maybe (NotificationEnv notifyEnv))
  (NotificationEnv notifyEnv)
  (NotificationEnv notifyEnv)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just Prism
  (Maybe (NotificationEnv notifyEnv))
  (Maybe (NotificationEnv notifyEnv))
  (NotificationEnv notifyEnv)
  (NotificationEnv notifyEnv)
-> Optic
     A_Lens
     NoIx
     (NotificationEnv notifyEnv)
     (NotificationEnv notifyEnv)
     NotifyActionsActive
     NotifyActionsActive
-> Optic
     An_AffineTraversal
     NoIx
     (Maybe (NotificationEnv notifyEnv))
     (Maybe (NotificationEnv notifyEnv))
     NotifyActionsActive
     NotifyActionsActive
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Lens
  NoIx
  (NotificationEnv notifyEnv)
  (NotificationEnv notifyEnv)
  NotifyActionsActive
  NotifyActionsActive
#actions Optic
  An_AffineTraversal
  NoIx
  (Maybe (NotificationEnv notifyEnv))
  (Maybe (NotificationEnv notifyEnv))
  NotifyActionsActive
  NotifyActionsActive
-> Optic
     An_AffineFold
     NoIx
     NotifyActionsActive
     NotifyActionsActive
     NotifyActionComplete
     NotifyActionComplete
-> Optic'
     An_AffineFold
     NoIx
     (Maybe (NotificationEnv notifyEnv))
     NotifyActionComplete
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  An_AffineFold
  NoIx
  NotifyActionsActive
  NotifyActionsActive
  NotifyActionComplete
  NotifyActionComplete
_NotifyActionsActiveCompleteAny) of
    -- If complete notifcations are on at all, send one
    Just NotifyActionComplete
_ -> NotifyMessage -> NotifyMessage -> NotifyUrgency -> m ()
forall (m :: Type -> Type) env notifyEnv.
(HasAnyError env, HasCallStack, HasCommands env, HasLogging env m,
 HasNotifyConfig env notifyEnv, MonadAtomic m, MonadCatch m,
 MonadNotify m, MonadReader env m, MonadRegionLogger m, MonadTime m,
 NotifyEnvF m ~ notifyEnv) =>
NotifyMessage -> NotifyMessage -> NotifyUrgency -> m ()
Notify.sendNotif NotifyMessage
notifyBody NotifyMessage
"" NotifyUrgency
NotifyUrgencyCritical
    Maybe NotifyActionComplete
_ -> () -> m ()
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
{-# INLINEABLE teardown #-}

-- | Installs a handler for SIGTERM, so shrun can be cancelled with kill -15.
-- The signal is logged then rethrown to the main thread as TermException,
-- which ensures that cleanup is handled normally (i.e. subcommands killed).
-- By default, subthreads are __not__ killed when the RTS handles SIGTERM.
handleTerminate ::
  forall m env.
  ( HasCallStack,
    HasCommands env,
    HasLogging env m,
    MonadAtomic m,
    MonadHandleWriter m,
    MonadPosixSignals m,
    MonadRegionLogger m,
    MonadReader env m,
    MonadThread m,
    MonadTime m
  ) =>
  ThreadId ->
  m ()
handleTerminate :: forall (m :: Type -> Type) env.
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadHandleWriter m, MonadPosixSignals m, MonadRegionLogger m,
 MonadReader env m, MonadThread m, MonadTime m) =>
ThreadId -> m ()
handleTerminate ThreadId
tid = do
  let handler :: Handler m
handler = (SignalInfo -> m ()) -> Handler m
forall (m :: Type -> Type). (SignalInfo -> m ()) -> Handler m
Signals.CatchInfo ((SignalInfo -> m ()) -> Handler m)
-> (SignalInfo -> m ()) -> Handler m
forall a b. (a -> b) -> a -> b
$ \SignalInfo
si -> do
        let errMsg :: UnlinedText
errMsg =
              UnlinedText
"Received terminate signal: "
                UnlinedText -> UnlinedText -> UnlinedText
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Text -> UnlinedText
Text -> UnlinedText
Text.unsafeUnlinedText (Signal -> Text
forall a. Show a => a -> Text
showt (SignalInfo -> Signal
Posix.siginfoSignal SignalInfo
si))
            baseLog :: Log
baseLog =
              MkLog
                { cmd :: Maybe CommandP1
cmd = Maybe CommandP1
forall a. Maybe a
Nothing,
                  msg :: LogMessage
msg = UnlinedText -> LogMessage
Types.fromUnlined UnlinedText
errMsg,
                  lvl :: LogLevel
lvl = LogLevel
LevelFatal,
                  mode :: LogMode
mode = LogMode
LogModeFinish
                }

        Log -> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadHandleWriter m, MonadReader env m, MonadRegionLogger m,
 MonadTime m) =>
Log -> m ()
Logging.putRegionLogDirect Log
baseLog

        -- Need to throw exception to main thread since this handler is run
        -- in a different thread.
        ThreadId -> TermException -> m ()
forall e. (Exception e, HasCallStack) => ThreadId -> e -> m ()
forall (m :: Type -> Type) e.
(MonadThread m, Exception e, HasCallStack) =>
ThreadId -> e -> m ()
throwTo ThreadId
tid TermException
MkTermException

  m (Handler m) -> m ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void (m (Handler m) -> m ()) -> m (Handler m) -> m ()
forall a b. (a -> b) -> a -> b
$ Signal -> Handler m -> Maybe SignalSet -> m (Handler m)
forall (m :: Type -> Type).
MonadPosixSignals m =>
Signal -> Handler m -> Maybe SignalSet -> m (Handler m)
Signals.installHandler Signal
Posix.sigTERM Handler m
handler Maybe SignalSet
forall a. Maybe a
Nothing

-- NOTE: [Command cleanup]
--
-- When shrun is going to terminate prematurely (e.g. killed externally or
-- a fatal exception is encountered), we want all subcommands to terminate
-- as well. We generally rely on our libraries to handle this automatically:
--
--   - async ensures an exception in the main thread is rethrown to all
--     subthreads.
--
--   - process forwards this exception to the running command.
--
-- While this is often enough, unfortunately there are some situations where
-- it is not. First, note that command running is complicated by the fact
-- that we are running through the shell, so e.g. "shrun 'some command'"
-- actually runs "/bin/sh -c 'some command'", which in turn runs
-- 'some command' in a platform-specific way.
--
-- For example, my local (linux) machine and CI OSX appear to immediately
-- terminate the /bin/sh command, and run 'some command' directly, whereas
-- CI Linux has both running.
--
-- Unfortunately, while an exception will terminate the /bin/sh command
-- on CI Linux, this exception does _not_ get proprogated to the underlying
-- 'some command'. To make matters worse, 'some command' has its parent PID
-- reassigned to PID 1, meaning we no longer have any connection to this
-- process.
--
-- To combat this, when we launch a command, we immediately store its PID
-- and any child PIDs in our command status map. Then, we attempt to kill all
-- of this upon cleanup. While this is overkill on some platforms,
-- it is necessary for CI linux (and presumably others), and does not appear
-- to be harmful. Note that this requires the following utilities:
--
--   - kill
--   - pgrep
--
-- Note that this _does not_ replace the need for commands to implement their
-- own cleanup as needed. That is, if a command spawns its own processes then
-- is that command's responsibilities to clean up these commands. Our cleanup
-- logic is only intended for handling the case where our spawned /bin/sh
-- does not forward the kill signal to its child.
cleanupCommands ::
  ( HasCallStack,
    HasCommands env,
    HasLogging env m,
    MonadAtomic m,
    MonadCatch m,
    MonadHandleWriter m,
    MonadProcess m,
    MonadReader env m,
    MonadRegionLogger m,
    MonadTime m
  ) =>
  m ()
cleanupCommands :: forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadCatch m, MonadHandleWriter m, MonadProcess m,
 MonadReader env m, MonadRegionLogger m, MonadTime m) =>
m ()
cleanupCommands = do
  -- Read all commands in a single transaction, then process. This should be
  -- safe in the sense that the command status map should not receive any
  -- updates because this is only called in two situations:
  --
  -- 1. All commands have finished.
  -- 2. Shrun main thread receives an exception.
  --
  -- In both cases, all command threads should have been killed hence no more
  -- status writes.
  --
  -- We cannot process the status in the same transaction -- in any case --
  -- because that would involve mixing IO effects in STM.
  HashMap CommandIndex (CommandP1, CommandStatus)
commandsStatusMap <- m CommandStatusMap
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadAtomic m,
 MonadReader env m) =>
m CommandStatusMap
getReadCommandStatus m CommandStatusMap
-> (CommandStatusMap
    -> HashMap CommandIndex (CommandP1, CommandStatus))
-> m (HashMap CommandIndex (CommandP1, CommandStatus))
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> Optic'
  An_Iso
  NoIx
  CommandStatusMap
  (HashMap CommandIndex (CommandP1, CommandStatus))
-> CommandStatusMap
-> HashMap CommandIndex (CommandP1, CommandStatus)
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic'
  An_Iso
  NoIx
  CommandStatusMap
  (HashMap CommandIndex (CommandP1, CommandStatus))
#unCommandStatusMap

  HashMap CommandIndex (CommandP1, CommandStatus)
-> ((CommandP1, CommandStatus) -> m ()) -> m ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ HashMap CommandIndex (CommandP1, CommandStatus)
commandsStatusMap (((CommandP1, CommandStatus) -> m ()) -> m ())
-> ((CommandP1, CommandStatus) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(CommandP1
_cmd, CommandStatus
status) ->
    case CommandStatus
status of
      CommandRunning (Maybe Pid
mPid, [Pid]
childPids) -> do
        -- 1. Kill the commands' children that were immediately spawned.
        -- This is the primary 'fix', as it is what happens on CI Linux,
        -- at least. This ensures we kill some_command when our /bin/sh
        -- commands do not forward the signal.
        --
        -- For platforms that end the /bin/sh immediately, this generally
        -- does nothing (which is fine, as then some_command will receive
        -- the normal terminate signal).
        [Pid] -> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadCatch m, MonadHandleWriter m, MonadProcess m,
 MonadReader env m, MonadRegionLogger m, MonadTime m) =>
[Pid] -> m ()
Shrun.IO.killPids [Pid]
childPids

        -- 2. Needed for CI OSX to pass the test_script.sh test. That is,
        -- the spawned sleep commands are not cancelled. We have the log:
        --
        --   [Debug] Failed finding child pids of '13456': out: '', err: ' '
        --
        -- Where 13456 is the PPID of sleep command i.e. the PID of the script.
        -- This is correct, but we fail to find the child pids anyway.
        -- Either there is a bug in getChildPids, or the child's PPID has
        -- been reassigned by the time we run getChildPids, which seems
        -- more likely.
        Maybe Pid -> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadCatch m, MonadHandleWriter m, MonadProcess m,
 MonadReader env m, MonadRegionLogger m, MonadTime m) =>
Maybe Pid -> m ()
Shrun.IO.killChildPids Maybe Pid
mPid

        -- 3. Needed for CI Linux to pass the test_script.sh test.
        [Pid] -> (Pid -> m ()) -> m ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Pid]
childPids Pid -> m ()
killChildPids
      CommandStatus
_ -> () -> m ()
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
  where
    killChildPids :: Pid -> m ()
killChildPids = Maybe Pid -> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadCatch m, MonadHandleWriter m, MonadProcess m,
 MonadReader env m, MonadRegionLogger m, MonadTime m) =>
Maybe Pid -> m ()
Shrun.IO.killChildPids (Maybe Pid -> m ()) -> (Pid -> Maybe Pid) -> Pid -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Pid -> Maybe Pid
forall a. a -> Maybe a
Just