{-# LANGUAGE ViewPatterns #-}

-- | Provides the low-level `IO` functions for running shell commands.
module Shrun.IO
  ( -- * Types
    CommandResult (..),
    Stderr (..),

    -- * Running commands
    tryCommandLogging,

    -- * Misc
    killChildPids,
    killPids,
  )
where

import Control.Monad (filterM)
import Data.List qualified as L
import Data.Text qualified as T
import Data.Time.Relative (RelativeTime)
import Effects.FileSystem.Handle qualified as H
import Effects.FileSystem.HandleWriter qualified as HW
import Effects.System.Process (Pid, ProcessHandle)
import Effects.System.Process qualified as P
import Effects.Time (MonadTime (getMonotonicTime))
import Shrun.Command.Types
  ( CommandP1,
    CommandStatus (CommandFailure, CommandRunning, CommandSuccess),
    commandToProcess,
  )
import Shrun.Configuration.Data.CommandLogging
  ( BufferLength,
    BufferTimeout,
    ReportReadErrorsSwitch,
  )
import Shrun.Configuration.Data.CommandLogging.ReadStrategy
  ( ReadStrategy
      ( ReadBlock,
        ReadBlockLineBuffer
      ),
  )
import Shrun.Configuration.Data.CommonLogging.KeyHideSwitch (KeyHideSwitch)
import Shrun.Configuration.Data.FileLogging qualified as FL
import Shrun.Configuration.Data.FileLogging.FileMode qualified as FileMode
import Shrun.Configuration.Env.Types
  ( HasAnyError,
    HasCommandLogging (getCommandLogging),
    HasCommands (getCleanup),
    HasCommonLogging (getCommonLogging),
    HasConsoleLogging (getConsoleLogging),
    HasFileLogging (getFileLogging),
    HasInit (getInit),
    HasLogging,
    setAnyErrorTrue,
    updateCommandStatus,
  )
import Shrun.Data.Text (UnlinedText)
import Shrun.Data.Text qualified as ShrunText
import Shrun.IO.Handle
  ( HandleResult,
    ReadHandleResult (ReadErr, ReadErrSuccess, ReadNoData, ReadSuccess),
  )
import Shrun.IO.Handle qualified as Handle
import Shrun.Logging qualified as Logging
import Shrun.Logging.Formatting (formatConsoleLog, formatFileLog)
import Shrun.Logging.MonadRegionLogger
  ( MonadRegionLogger
      ( Region,
        withRegion
      ),
    restoreTimerRegion,
  )
import Shrun.Logging.Types
  ( Log (MkLog, cmd, lvl, mode, msg),
    LogLevel (LevelCommand),
    LogMode (LogModeSet),
    LogRegion (LogRegion),
  )
import Shrun.Logging.Types qualified as Types
import Shrun.Prelude
import Shrun.Utils qualified as U
import System.IO qualified as IO
import Text.Read qualified as TR

-- | Newtype wrapper for stderr.
newtype Stderr = MkStderr {Stderr -> [UnlinedText]
unStderr :: List UnlinedText}
  deriving stock (Stderr -> Stderr -> Bool
(Stderr -> Stderr -> Bool)
-> (Stderr -> Stderr -> Bool) -> Eq Stderr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Stderr -> Stderr -> Bool
== :: Stderr -> Stderr -> Bool
$c/= :: Stderr -> Stderr -> Bool
/= :: Stderr -> Stderr -> Bool
Eq, Int -> Stderr -> ShowS
[Stderr] -> ShowS
Stderr -> String
(Int -> Stderr -> ShowS)
-> (Stderr -> String) -> ([Stderr] -> ShowS) -> Show Stderr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Stderr -> ShowS
showsPrec :: Int -> Stderr -> ShowS
$cshow :: Stderr -> String
show :: Stderr -> String
$cshowList :: [Stderr] -> ShowS
showList :: [Stderr] -> ShowS
Show)

-- | Turns a 'ReadHandleResult' into a 'Stderr'.
readHandleResultToStderr :: ReadHandleResult -> Stderr
readHandleResultToStderr :: ReadHandleResult -> Stderr
readHandleResultToStderr ReadHandleResult
ReadNoData = [UnlinedText] -> Stderr
MkStderr ([UnlinedText] -> Stderr) -> [UnlinedText] -> Stderr
forall a b. (a -> b) -> a -> b
$ Text -> [UnlinedText]
ShrunText.fromText Text
"<No data>"
readHandleResultToStderr (ReadErr NonEmpty UnlinedText
errs) = [UnlinedText] -> Stderr
MkStderr (NonEmpty UnlinedText -> [UnlinedText]
forall a. NonEmpty a -> [a]
neToList NonEmpty UnlinedText
errs)
readHandleResultToStderr (ReadSuccess NonEmpty UnlinedText
errs) = [UnlinedText] -> Stderr
MkStderr (NonEmpty UnlinedText -> [UnlinedText]
forall a. NonEmpty a -> [a]
neToList NonEmpty UnlinedText
errs)
readHandleResultToStderr (ReadErrSuccess NonEmpty UnlinedText
e1 NonEmpty UnlinedText
e2) = [UnlinedText] -> Stderr
MkStderr (NonEmpty UnlinedText -> [UnlinedText]
forall a. NonEmpty a -> [a]
neToList (NonEmpty UnlinedText -> [UnlinedText])
-> NonEmpty UnlinedText -> [UnlinedText]
forall a b. (a -> b) -> a -> b
$ NonEmpty UnlinedText
e1 NonEmpty UnlinedText
-> NonEmpty UnlinedText -> NonEmpty UnlinedText
forall a. Semigroup a => a -> a -> a
<> NonEmpty UnlinedText
e2)

-- | Result of running a command.
data CommandResult
  = CommandResultSuccess RelativeTime
  | CommandResultFailure RelativeTime Stderr
  deriving stock (CommandResult -> CommandResult -> Bool
(CommandResult -> CommandResult -> Bool)
-> (CommandResult -> CommandResult -> Bool) -> Eq CommandResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CommandResult -> CommandResult -> Bool
== :: CommandResult -> CommandResult -> Bool
$c/= :: CommandResult -> CommandResult -> Bool
/= :: CommandResult -> CommandResult -> Bool
Eq, Int -> CommandResult -> ShowS
[CommandResult] -> ShowS
CommandResult -> String
(Int -> CommandResult -> ShowS)
-> (CommandResult -> String)
-> ([CommandResult] -> ShowS)
-> Show CommandResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CommandResult -> ShowS
showsPrec :: Int -> CommandResult -> ShowS
$cshow :: CommandResult -> String
show :: CommandResult -> String
$cshowList :: [CommandResult] -> ShowS
showList :: [CommandResult] -> ShowS
Show)

-- | Runs the command, returning the time elapsed along with a possible
-- error.
tryCommandLogging ::
  forall m 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
  ) =>
  -- | Command to run.
  CommandP1 ->
  -- | Result.
  m CommandResult
tryCommandLogging :: 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
command = do
  -- NOTE: We do not want tryCommandLogging to throw sync exceptions, as that
  -- will take down the whole app. tryCommandStream and tryShExitCode should be
  -- total, but there are still a few functions here that can throw. To wit:
  --
  -- - atomically: Used in updateCommandStatus, setAnyErrorTrue,
  --               writeTBQueueA'.
  -- - getSystemTimeString: Used in formatFileLog.
  --
  -- We could catch these exceptions and simply print an error. However, both
  -- of these errors have nothing to do with the actual command that is being
  -- run and point to something wrong with shrun itself. Morever, "recovery"
  -- in these instances is unclear, as we are either dropping logs (how do we
  -- report these errors?) or failing to get the time (how should we log?).
  --
  -- Thus the most reasonable course of action is to let shrun die and print
  -- the actual error so it can be fixed.

  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))
consoleLogQueue, IORef (Maybe (Region m))
timerRegion) <- (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
  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

  -- NOTE: [Restore Timer Region]
  --
  -- Generally, we want the timer region to be the last console region, but
  -- sequential commands can screw with that. That is, if a sequential command
  -- spawns --command-logs, those seem to be placed in a new region _after_
  -- the timer log. That is not what we want.
  --
  -- To handle this, we call 'restoreTimerRegion' immediately after creating
  -- the new region (two places below). This seems to work, though it feels
  -- a bit shaky. We _could_ move this logic to the timer itself, which would
  -- potentially restore it every second. That should be quite robust
  -- (assuming the restore logic does what we want), but it's possibly
  -- wasteful, since experience seems to show it's only these single command
  -- logs that screw it up.
  --
  -- Hence for now, let's just do it the one time after commands are created.
  -- If we have problems, consider moving it to the timer.

  let 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
      consoleLogSwitch :: Bool
consoleLogSwitch = ConsoleLoggingEnv
consoleLogging ConsoleLoggingEnv
-> Optic' A_Lens NoIx ConsoleLoggingEnv Bool -> Bool
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic
  A_Lens
  NoIx
  ConsoleLoggingEnv
  ConsoleLoggingEnv
  ConsoleLogCmdSwitch
  ConsoleLogCmdSwitch
#commandLogging Optic
  A_Lens
  NoIx
  ConsoleLoggingEnv
  ConsoleLoggingEnv
  ConsoleLogCmdSwitch
  ConsoleLogCmdSwitch
-> Optic
     An_Iso NoIx ConsoleLogCmdSwitch ConsoleLogCmdSwitch Bool Bool
-> Optic' A_Lens NoIx ConsoleLoggingEnv Bool
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_Iso NoIx ConsoleLogCmdSwitch ConsoleLogCmdSwitch Bool Bool
#unConsoleLogCmdSwitch
      -- In general, our loggers take an optional region (for debugging) and
      -- a log, and send it off to the console / file queues, depending on
      -- the queue. Debugging gets its own queue because we do not want it
      -- to be overridden by command logs.
      cmdFn :: CommandP1 -> m (Maybe Stderr)
cmdFn = case (Bool
consoleLogSwitch, Maybe FileLoggingEnv
mFileLogging) of
        -- 1. No CommandLogging and no FileLogging: No logging at all.
        (Bool
False, Maybe FileLoggingEnv
Nothing) -> (Maybe (Region m) -> Log -> m ()) -> CommandP1 -> m (Maybe Stderr)
forall env (m :: Type -> Type).
(HasInit env, HasCallStack, HasCommands env, HasLogging env m,
 MonadAtomic m, MonadHandleReader m, MonadHandleWriter m,
 MonadIORef m, MonadMask m, MonadProcess m, MonadReader env m,
 MonadRegionLogger m, MonadThread m, MonadTime m) =>
(Maybe (Region m) -> Log -> m ()) -> CommandP1 -> m (Maybe Stderr)
tryCommandStream (\Maybe (Region m)
_ Log
_ -> () -> m ()
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ())
        -- 2. CommandLogging but no FileLogging. Stream.
        (Bool
True, Maybe FileLoggingEnv
Nothing) -> \CommandP1
cmd ->
          RegionLayout -> (Region m -> m (Maybe Stderr)) -> m (Maybe Stderr)
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 (Maybe Stderr)) -> m (Maybe Stderr))
-> (Region m -> m (Maybe Stderr)) -> m (Maybe Stderr)
forall a b. (a -> b) -> a -> b
$ \Region m
cmdRegion -> do
            IORef (Maybe (Region m)) -> m ()
forall (m :: Type -> Type).
(MonadAtomic m, MonadIORef m, MonadRegionLogger m) =>
IORef (Maybe (Region m)) -> m ()
restoreTimerRegion IORef (Maybe (Region m))
timerRegion
            let logFn :: Maybe (Region m) -> Log -> m ()
logFn Maybe (Region m)
mRegion Log
log =
                  let region :: Region m
region = Region m -> Maybe (Region m) -> Region m
forall a. a -> Maybe a -> a
fromMaybe Region m
cmdRegion Maybe (Region m)
mRegion
                   in KeyHideSwitch
-> TBQueue (LogRegion (Region m))
-> Region m
-> ConsoleLoggingEnv
-> Log
-> m ()
forall {m :: Type -> Type} {env} {r}.
(HasCommands env, MonadAtomic m, MonadReader env m) =>
KeyHideSwitch
-> TBQueue (LogRegion r) -> r -> ConsoleLoggingEnv -> Log -> m ()
logConsole KeyHideSwitch
keyHide TBQueue (LogRegion (Region m))
consoleLogQueue Region m
region ConsoleLoggingEnv
consoleLogging Log
log

            Maybe (Region m) -> Log -> m ()
logFn Maybe (Region m)
forall a. Maybe a
Nothing Log
hello

            (Maybe (Region m) -> Log -> m ()) -> CommandP1 -> m (Maybe Stderr)
forall env (m :: Type -> Type).
(HasInit env, HasCallStack, HasCommands env, HasLogging env m,
 MonadAtomic m, MonadHandleReader m, MonadHandleWriter m,
 MonadIORef m, MonadMask m, MonadProcess m, MonadReader env m,
 MonadRegionLogger m, MonadThread m, MonadTime m) =>
(Maybe (Region m) -> Log -> m ()) -> CommandP1 -> m (Maybe Stderr)
tryCommandStream Maybe (Region m) -> Log -> m ()
logFn CommandP1
cmd
        -- 3. No CommandLogging but FileLogging: Stream (to file) but no console
        --    region.
        (Bool
False, Just FileLoggingEnv
fileLogging) -> \CommandP1
cmd -> do
          let logConsoleRegion :: Maybe (Region m) -> Log -> m ()
logConsoleRegion Maybe (Region m)
mRegion Log
log = do
                -- Even if cmdLogging is off, we still want to send debug
                -- logs, if enabled.
                Maybe (Region m) -> (Region m -> m ()) -> m ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (Region m)
mRegion ((Region m -> m ()) -> m ()) -> (Region m -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Region m
region ->
                  KeyHideSwitch
-> TBQueue (LogRegion (Region m))
-> Region m
-> ConsoleLoggingEnv
-> Log
-> m ()
forall {m :: Type -> Type} {env} {r}.
(HasCommands env, MonadAtomic m, MonadReader env m) =>
KeyHideSwitch
-> TBQueue (LogRegion r) -> r -> ConsoleLoggingEnv -> Log -> m ()
logConsole KeyHideSwitch
keyHide TBQueue (LogRegion (Region m))
consoleLogQueue Region m
region ConsoleLoggingEnv
consoleLogging Log
log

          KeyHideSwitch
-> FileLoggingEnv
-> (Maybe (Region m) -> Log -> m ())
-> ((Maybe (Region m) -> Log -> m ()) -> m (Maybe Stderr))
-> m (Maybe Stderr)
withFileLogging KeyHideSwitch
keyHide FileLoggingEnv
fileLogging Maybe (Region m) -> Log -> m ()
logConsoleRegion (((Maybe (Region m) -> Log -> m ()) -> m (Maybe Stderr))
 -> m (Maybe Stderr))
-> ((Maybe (Region m) -> Log -> m ()) -> m (Maybe Stderr))
-> m (Maybe Stderr)
forall a b. (a -> b) -> a -> b
$ \Maybe (Region m) -> Log -> m ()
logFn -> do
            Maybe (Region m) -> Log -> m ()
logFn Maybe (Region m)
forall a. Maybe a
Nothing Log
hello
            (Maybe (Region m) -> Log -> m ()) -> CommandP1 -> m (Maybe Stderr)
forall env (m :: Type -> Type).
(HasInit env, HasCallStack, HasCommands env, HasLogging env m,
 MonadAtomic m, MonadHandleReader m, MonadHandleWriter m,
 MonadIORef m, MonadMask m, MonadProcess m, MonadReader env m,
 MonadRegionLogger m, MonadThread m, MonadTime m) =>
(Maybe (Region m) -> Log -> m ()) -> CommandP1 -> m (Maybe Stderr)
tryCommandStream Maybe (Region m) -> Log -> m ()
logFn CommandP1
cmd

        -- 4. CommandLogging and FileLogging: Stream (to both) and create console
        --    region.
        (Bool
True, Just FileLoggingEnv
fileLogging) -> \CommandP1
cmd ->
          RegionLayout -> (Region m -> m (Maybe Stderr)) -> m (Maybe Stderr)
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 (Maybe Stderr)) -> m (Maybe Stderr))
-> (Region m -> m (Maybe Stderr)) -> m (Maybe Stderr)
forall a b. (a -> b) -> a -> b
$ \Region m
cmdRegion -> do
            IORef (Maybe (Region m)) -> m ()
forall (m :: Type -> Type).
(MonadAtomic m, MonadIORef m, MonadRegionLogger m) =>
IORef (Maybe (Region m)) -> m ()
restoreTimerRegion IORef (Maybe (Region m))
timerRegion

            let logConsoleRegion :: Maybe (Region m) -> Log -> m ()
logConsoleRegion Maybe (Region m)
mRegion Log
log = do
                  let region :: Region m
region = Region m -> Maybe (Region m) -> Region m
forall a. a -> Maybe a -> a
fromMaybe Region m
cmdRegion Maybe (Region m)
mRegion
                  KeyHideSwitch
-> TBQueue (LogRegion (Region m))
-> Region m
-> ConsoleLoggingEnv
-> Log
-> m ()
forall {m :: Type -> Type} {env} {r}.
(HasCommands env, MonadAtomic m, MonadReader env m) =>
KeyHideSwitch
-> TBQueue (LogRegion r) -> r -> ConsoleLoggingEnv -> Log -> m ()
logConsole KeyHideSwitch
keyHide TBQueue (LogRegion (Region m))
consoleLogQueue Region m
region ConsoleLoggingEnv
consoleLogging Log
log

            KeyHideSwitch
-> FileLoggingEnv
-> (Maybe (Region m) -> Log -> m ())
-> ((Maybe (Region m) -> Log -> m ()) -> m (Maybe Stderr))
-> m (Maybe Stderr)
withFileLogging KeyHideSwitch
keyHide FileLoggingEnv
fileLogging Maybe (Region m) -> Log -> m ()
logConsoleRegion (((Maybe (Region m) -> Log -> m ()) -> m (Maybe Stderr))
 -> m (Maybe Stderr))
-> ((Maybe (Region m) -> Log -> m ()) -> m (Maybe Stderr))
-> m (Maybe Stderr)
forall a b. (a -> b) -> a -> b
$ \Maybe (Region m) -> Log -> m ()
logFn -> do
              Maybe (Region m) -> Log -> m ()
logFn Maybe (Region m)
forall a. Maybe a
Nothing Log
hello
              (Maybe (Region m) -> Log -> m ()) -> CommandP1 -> m (Maybe Stderr)
forall env (m :: Type -> Type).
(HasInit env, HasCallStack, HasCommands env, HasLogging env m,
 MonadAtomic m, MonadHandleReader m, MonadHandleWriter m,
 MonadIORef m, MonadMask m, MonadProcess m, MonadReader env m,
 MonadRegionLogger m, MonadThread m, MonadTime m) =>
(Maybe (Region m) -> Log -> m ()) -> CommandP1 -> m (Maybe Stderr)
tryCommandStream Maybe (Region m) -> Log -> m ()
logFn CommandP1
cmd

  m (Maybe Stderr) -> m (TimeSpec, Maybe Stderr)
forall (m :: Type -> Type) a.
(HasCallStack, MonadTime m) =>
m a -> m (TimeSpec, a)
withTiming (CommandP1 -> m (Maybe Stderr)
cmdFn CommandP1
command) m (TimeSpec, Maybe Stderr)
-> ((TimeSpec, Maybe Stderr) -> m CommandResult) -> m CommandResult
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
>>= \case
    (TimeSpec
rt, Maybe Stderr
Nothing) -> do
      -- update completed commands
      CommandP1 -> CommandStatus -> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadAtomic m, MonadReader env m,
 MonadThrow m) =>
CommandP1 -> CommandStatus -> m ()
updateCommandStatus CommandP1
command CommandStatus
CommandSuccess

      pure $ RelativeTime -> CommandResult
CommandResultSuccess (RelativeTime -> CommandResult) -> RelativeTime -> CommandResult
forall a b. (a -> b) -> a -> b
$ TimeSpec -> RelativeTime
U.timeSpecToRelTime TimeSpec
rt
    (TimeSpec
rt, Just Stderr
err) -> do
      -- update completed commands
      CommandP1 -> CommandStatus -> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadAtomic m, MonadReader env m,
 MonadThrow m) =>
CommandP1 -> CommandStatus -> m ()
updateCommandStatus CommandP1
command CommandStatus
CommandFailure

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

      pure $ RelativeTime -> Stderr -> CommandResult
CommandResultFailure (TimeSpec -> RelativeTime
U.timeSpecToRelTime TimeSpec
rt) Stderr
err
  where
    logConsole :: KeyHideSwitch
-> TBQueue (LogRegion r) -> r -> ConsoleLoggingEnv -> Log -> m ()
logConsole KeyHideSwitch
keyHide TBQueue (LogRegion r)
consoleQueue r
region ConsoleLoggingEnv
consoleLogging Log
log = do
      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
formatConsoleLog KeyHideSwitch
keyHide ConsoleLoggingEnv
consoleLogging Log
log
      TBQueue (LogRegion r) -> LogRegion r -> m ()
forall (m :: Type -> Type) a.
(HasCallStack, MonadAtomic m) =>
TBQueue a -> a -> m ()
writeTBQueueA' TBQueue (LogRegion r)
consoleQueue (LogMode -> r -> ConsoleLog -> LogRegion r
forall r. LogMode -> r -> ConsoleLog -> LogRegion r
LogRegion (Log
log Log -> Optic' A_Lens NoIx Log LogMode -> LogMode
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx Log LogMode
#mode) r
region ConsoleLog
formatted)

    logMainFile :: KeyHideSwitch -> FileLoggingEnv -> Log -> m ()
logMainFile KeyHideSwitch
keyHide FileLoggingEnv
fileLogging Log
log = do
      FileLog
formatted <- 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
formatFileLog KeyHideSwitch
keyHide FileLoggingEnv
fileLogging Log
log
      TBQueue FileLog -> FileLog -> m ()
forall (m :: Type -> Type) a.
(HasCallStack, MonadAtomic m) =>
TBQueue a -> a -> m ()
writeTBQueueA' (FileLoggingEnv
fileLogging FileLoggingEnv
-> Optic' A_Lens NoIx FileLoggingEnv (TBQueue FileLog)
-> TBQueue FileLog
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic
  A_Lens
  NoIx
  FileLoggingEnv
  FileLoggingEnv
  FileLogOpened
  FileLogOpened
#file Optic
  A_Lens
  NoIx
  FileLoggingEnv
  FileLoggingEnv
  FileLogOpened
  FileLogOpened
-> Optic
     A_Lens
     NoIx
     FileLogOpened
     FileLogOpened
     (TBQueue FileLog)
     (TBQueue FileLog)
-> Optic' A_Lens NoIx FileLoggingEnv (TBQueue FileLog)
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
  FileLogOpened
  FileLogOpened
  (TBQueue FileLog)
  (TBQueue FileLog)
#queue) FileLog
formatted

    logMultiFile :: LockedHandle p -> KeyHideSwitch -> FileLoggingEnv -> Log -> m ()
logMultiFile LockedHandle p
fileHandle KeyHideSwitch
keyHide FileLoggingEnv
fileLogging Log
log = do
      FileLog
formatted <- 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
formatFileLog KeyHideSwitch
keyHide FileLoggingEnv
fileLogging Log
log
      LockedHandle p -> FileLog -> m ()
forall (p :: HandleMode) (m :: Type -> Type).
(CanWrite p, HasCallStack, MonadHandleWriter m) =>
LockedHandle p -> FileLog -> m ()
Logging.logFile LockedHandle p
fileHandle FileLog
formatted

    -- Augments an existing logger with a file logging.
    withFileLogging ::
      -- key hide
      KeyHideSwitch ->
      -- file logging env
      FL.FileLoggingEnv ->
      -- console logger
      (Maybe (Region m) -> Log -> m ()) ->
      -- continuation on combined logger
      ((Maybe (Region m) -> Log -> m ()) -> m (Maybe Stderr)) ->
      m (Maybe Stderr)
    withFileLogging :: KeyHideSwitch
-> FileLoggingEnv
-> (Maybe (Region m) -> Log -> m ())
-> ((Maybe (Region m) -> Log -> m ()) -> m (Maybe Stderr))
-> m (Maybe Stderr)
withFileLogging KeyHideSwitch
keyHide FileLoggingEnv
fileLogging Maybe (Region m) -> Log -> m ()
consoleLog (Maybe (Region m) -> Log -> m ()) -> m (Maybe Stderr)
m = do
      -- 1. Multi log is on. Need to do extra steps.
      case FileLoggingEnv
fileLogging FileLoggingEnv
-> Optic' A_Lens NoIx FileLoggingEnv (Maybe (TVar Word16))
-> Maybe (TVar Word16)
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx FileLoggingEnv (Maybe (TVar Word16))
#multi of
        Just TVar Word16
multiCounter -> do
          let fileMode :: FileMode
fileMode = FileLoggingEnv
fileLogging FileLoggingEnv
-> Optic' A_Lens NoIx FileLoggingEnv FileMode -> FileMode
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx FileLoggingEnv FileMode
#mode
              ioMode :: Bool
ioMode = FileMode -> Bool
FileMode.toIOMode FileMode
fileMode
          OsPath
multiPath <-
            TVar Word16 -> FileMode -> OsPath -> m OsPath
forall (m :: Type -> Type).
(HasCallStack, MonadAtomic m, MonadHandleWriter m,
 MonadPathReader m, MonadPosixFiles m, MonadThrow m) =>
TVar Word16 -> FileMode -> OsPath -> m OsPath
FL.createMultiLogFile
              TVar Word16
multiCounter
              FileMode
fileMode
              (FileLoggingEnv
fileLogging FileLoggingEnv
-> Optic' A_Lens NoIx FileLoggingEnv OsPath -> OsPath
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic
  A_Lens
  NoIx
  FileLoggingEnv
  FileLoggingEnv
  FileLogOpened
  FileLogOpened
#file Optic
  A_Lens
  NoIx
  FileLoggingEnv
  FileLoggingEnv
  FileLogOpened
  FileLogOpened
-> Optic A_Lens NoIx FileLogOpened FileLogOpened OsPath OsPath
-> Optic' A_Lens NoIx FileLoggingEnv OsPath
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 FileLogOpened FileLogOpened OsPath OsPath
#path)

          -- 1.2. Open file, run command.
          Maybe Stderr
r <- OsPath
-> Bool
-> (Handle 'HandleModeWrite -> m (Maybe Stderr))
-> m (Maybe Stderr)
forall a.
HasCallStack =>
OsPath -> Bool -> (Handle 'HandleModeWrite -> m a) -> m a
forall (m :: Type -> Type) a.
(MonadHandleWriter m, HasCallStack) =>
OsPath -> Bool -> (Handle 'HandleModeWrite -> m a) -> m a
HW.withBinaryFile OsPath
multiPath Bool
ioMode ((Handle 'HandleModeWrite -> m (Maybe Stderr)) -> m (Maybe Stderr))
-> (Handle 'HandleModeWrite -> m (Maybe Stderr))
-> m (Maybe Stderr)
forall a b. (a -> b) -> a -> b
$ \Handle 'HandleModeWrite
handle -> do
            Handle 'HandleModeWrite
-> (LockedHandle 'HandleModeWrite -> m (Maybe Stderr))
-> m (Maybe Stderr)
forall (p :: HandleMode) (m :: Type -> Type) a.
(CanWrite p, HasCallStack, MonadHandleWriter m, MonadMask m) =>
Handle p -> (LockedHandle p -> m a) -> m a
withLockedFile Handle 'HandleModeWrite
handle ((LockedHandle 'HandleModeWrite -> m (Maybe Stderr))
 -> m (Maybe Stderr))
-> (LockedHandle 'HandleModeWrite -> m (Maybe Stderr))
-> m (Maybe Stderr)
forall a b. (a -> b) -> a -> b
$ \LockedHandle 'HandleModeWrite
lockedHandle -> do
              let logFn :: Maybe (Region m) -> Log -> m ()
logFn Maybe (Region m)
mRegion Log
log = do
                    Maybe (Region m) -> Log -> m ()
consoleLog Maybe (Region m)
mRegion Log
log
                    LockedHandle 'HandleModeWrite
-> KeyHideSwitch -> FileLoggingEnv -> Log -> m ()
forall {p :: HandleMode} {m :: Type -> Type} {env}.
(CanWrite p, HasCommands env, MonadAtomic m, MonadReader env m,
 MonadTime m, MonadHandleWriter m) =>
LockedHandle p -> KeyHideSwitch -> FileLoggingEnv -> Log -> m ()
logMultiFile LockedHandle 'HandleModeWrite
lockedHandle KeyHideSwitch
keyHide FileLoggingEnv
fileLogging Log
log

              (Maybe (Region m) -> Log -> m ()) -> m (Maybe Stderr)
m Maybe (Region m) -> Log -> m ()
logFn

          -- Delete file if deleteOnSuccess is true and the return value
          -- is Nothing (no error).
          let deleteFile :: Bool
deleteFile =
                FileLoggingEnv
fileLogging
                  FileLoggingEnv -> Optic' A_Lens NoIx FileLoggingEnv Bool -> Bool
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. (Optic
  A_Lens
  NoIx
  FileLoggingEnv
  FileLoggingEnv
  DeleteOnSuccessSwitch
  DeleteOnSuccessSwitch
#deleteOnSuccess Optic
  A_Lens
  NoIx
  FileLoggingEnv
  FileLoggingEnv
  DeleteOnSuccessSwitch
  DeleteOnSuccessSwitch
-> Optic
     An_Iso NoIx DeleteOnSuccessSwitch DeleteOnSuccessSwitch Bool Bool
-> Optic' A_Lens NoIx FileLoggingEnv Bool
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_Iso NoIx DeleteOnSuccessSwitch DeleteOnSuccessSwitch Bool Bool
#unDeleteOnSuccessSwitch)
                  Bool -> Bool -> Bool
&& Optic' A_Prism NoIx (Maybe Stderr) () -> Maybe Stderr -> Bool
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Bool
is Optic' A_Prism NoIx (Maybe Stderr) ()
forall a. Prism' (Maybe a) ()
_Nothing Maybe Stderr
r

          Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when Bool
deleteFile (OsPath -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadPathReader m, MonadPathWriter m) =>
OsPath -> m ()
removeFileIfExists_ OsPath
multiPath)

          pure Maybe Stderr
r
        -- 2. Multi log is not on: Easy, just invoke the given logger and
        -- also send to main file queue.
        Maybe (TVar Word16)
Nothing -> do
          let logFn :: Maybe (Region m) -> Log -> m ()
logFn Maybe (Region m)
mRegion Log
log = do
                Maybe (Region m) -> Log -> m ()
consoleLog Maybe (Region m)
mRegion Log
log
                KeyHideSwitch -> FileLoggingEnv -> Log -> m ()
forall {m :: Type -> Type} {env}.
(HasCommands env, MonadAtomic m, MonadReader env m, MonadTime m) =>
KeyHideSwitch -> FileLoggingEnv -> Log -> m ()
logMainFile KeyHideSwitch
keyHide FileLoggingEnv
fileLogging Log
log

          (Maybe (Region m) -> Log -> m ()) -> m (Maybe Stderr)
m Maybe (Region m) -> Log -> m ()
logFn

    hello :: Log
hello =
      MkLog
        { cmd :: Maybe CommandP1
cmd = CommandP1 -> Maybe CommandP1
forall a. a -> Maybe a
Just CommandP1
command,
          msg :: LogMessage
msg = LogMessage
"Starting...",
          lvl :: LogLevel
lvl = LogLevel
LevelCommand,
          mode :: LogMode
mode = LogMode
LogModeSet
        }
{-# INLINEABLE tryCommandLogging #-}

-- | Similar to 'tryCommand' except we attempt to stream the commands' output
-- instead of the usual swallowing.
tryCommandStream ::
  ( HasInit env,
    HasCallStack,
    HasCommands env,
    HasLogging env m,
    MonadAtomic m,
    MonadHandleReader m,
    MonadHandleWriter m,
    MonadIORef m,
    MonadMask m,
    MonadProcess m,
    MonadReader env m,
    MonadRegionLogger m,
    MonadThread m,
    MonadTime m
  ) =>
  -- | Function to apply to streamed logs.
  (Maybe (Region m) -> Log -> m ()) ->
  -- | Command to run.
  CommandP1 ->
  -- | Error, if any. Note that this will be 'Just' iff the command exited
  -- with an error, even if the error message itself is blank.
  m (Maybe Stderr)
tryCommandStream :: forall env (m :: Type -> Type).
(HasInit env, HasCallStack, HasCommands env, HasLogging env m,
 MonadAtomic m, MonadHandleReader m, MonadHandleWriter m,
 MonadIORef m, MonadMask m, MonadProcess m, MonadReader env m,
 MonadRegionLogger m, MonadThread m, MonadTime m) =>
(Maybe (Region m) -> Log -> m ()) -> CommandP1 -> m (Maybe Stderr)
tryCommandStream Maybe (Region m) -> Log -> m ()
logFn CommandP1
cmd = do
  let liftHandle ::
        Tuple2 IO.Handle IO.Handle ->
        Tuple2 HandleRW HandleRW
      liftHandle :: (Handle, Handle) -> (HandleRW, HandleRW)
liftHandle = (Handle -> HandleRW)
-> (Handle -> HandleRW) -> (Handle, Handle) -> (HandleRW, HandleRW)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: Type -> Type -> Type) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Handle -> HandleRW
forall (p :: HandleMode). Handle -> Handle p
H.unsafeHandle Handle -> HandleRW
forall (p :: HandleMode). Handle -> Handle p
H.unsafeHandle

  (HandleRW
recvOutH, HandleRW
sendOutH) <- (Handle, Handle) -> (HandleRW, HandleRW)
liftHandle ((Handle, Handle) -> (HandleRW, HandleRW))
-> m (Handle, Handle) -> m (HandleRW, HandleRW)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Handle, Handle)
forall (m :: Type -> Type).
(MonadProcess m, HasCallStack) =>
m (Handle, Handle)
P.createPipe
  HandleRW -> BufferMode -> m ()
forall (p :: HandleMode).
(CanWrite p, HasCallStack) =>
Handle p -> BufferMode -> m ()
forall (m :: Type -> Type) (p :: HandleMode).
(MonadHandleWriter m, CanWrite p, HasCallStack) =>
Handle p -> BufferMode -> m ()
HW.hSetBuffering HandleRW
recvOutH BufferMode
HW.NoBuffering
  HandleRW -> BufferMode -> m ()
forall (p :: HandleMode).
(CanWrite p, HasCallStack) =>
Handle p -> BufferMode -> m ()
forall (m :: Type -> Type) (p :: HandleMode).
(MonadHandleWriter m, CanWrite p, HasCallStack) =>
Handle p -> BufferMode -> m ()
HW.hSetBuffering HandleRW
sendOutH BufferMode
HW.NoBuffering

  (HandleRW
recvErrH, HandleRW
sendErrH) <- (Handle, Handle) -> (HandleRW, HandleRW)
liftHandle ((Handle, Handle) -> (HandleRW, HandleRW))
-> m (Handle, Handle) -> m (HandleRW, HandleRW)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Handle, Handle)
forall (m :: Type -> Type).
(MonadProcess m, HasCallStack) =>
m (Handle, Handle)
P.createPipe
  HandleRW -> BufferMode -> m ()
forall (p :: HandleMode).
(CanWrite p, HasCallStack) =>
Handle p -> BufferMode -> m ()
forall (m :: Type -> Type) (p :: HandleMode).
(MonadHandleWriter m, CanWrite p, HasCallStack) =>
Handle p -> BufferMode -> m ()
HW.hSetBuffering HandleRW
recvErrH BufferMode
HW.NoBuffering
  HandleRW -> BufferMode -> m ()
forall (p :: HandleMode).
(CanWrite p, HasCallStack) =>
Handle p -> BufferMode -> m ()
forall (m :: Type -> Type) (p :: HandleMode).
(MonadHandleWriter m, CanWrite p, HasCallStack) =>
Handle p -> BufferMode -> m ()
HW.hSetBuffering HandleRW
sendErrH BufferMode
HW.NoBuffering

  -- NOTE: [process vs. typed-process]
  --
  -- We previously switched from process to typed-process. This came with
  -- some improvements (ByteString output rather than String, more robust
  -- wrt handle output). We now switch back to process. Why?
  --
  -- We encountered a bug where SIGINT only promptly killed shrun + subcommands
  -- when command logging was active. That is, consider the following steps:
  --
  -- 1. Run 'shrun "sleep 15"
  -- 3. Run 'ps aux | grep sleep' to get shrun's pid.
  -- 2. In a separate terminal, run 'kill -2 <shrun_pid>
  --
  -- We should see shrun exit immediately with a cancellation message,
  -- and a subsequent 'ps aux | grep sleep' should show no running processes.
  --
  -- Unfortunately, this only worked when command logging was active.
  -- In particular, the exception was blocked until the sleep subcommand
  -- finished (15 seconds), so nothing was actually cancelled. The reason
  -- has something to do with typed-process's readProcess not respecting
  -- async exceptions. There are a few suspicious bug reports:
  --
  -- - https://github.com/fpco/typed-process/issues/32
  -- - https://github.com/fpco/typed-process/issues/38
  -- - https://github.com/fpco/typed-process/issues/69
  --
  -- More generally, investigation revealed that typed-process uses
  -- unliftio's bracket and friends i.e uninterruptibleMask is involved.
  -- While I am unsure of the exact nature of the bug, I am not surprised
  -- async exceptions are going wrong in the presence of uninterruptibleMask.
  --
  -- Happily, process does _not_ appear to have this bug, and I believe
  -- unliftio's / safe-exception's choice of uninterruptibleMask is the
  -- wrong one regardless, thus I generally try to avoid them on principle.
  -- Hence this is an easy switch.
  --
  -- The switch from ByteString to String is sad, but perhaps this can be
  -- improved when process receives OsString support.
  let initToConfig :: Maybe Text -> CreateProcess
      initToConfig :: Maybe Text -> CreateProcess
initToConfig Maybe Text
mInit =
        (CommandP1 -> Maybe Text -> CreateProcess
commandToProcess CommandP1
cmd Maybe Text
mInit)
          { P.std_out = P.UseHandle $ H.unHandle sendOutH,
            P.std_in = P.Inherit,
            P.std_err = P.UseHandle $ H.unHandle sendErrH,
            P.cwd = Nothing,
            -- We are possibly trying to read from these after the process
            -- closes (e.g. an error), so it is important they are not
            -- closed automatically!
            P.close_fds = False
          }

  CreateProcess
procConfig <- Maybe Text -> CreateProcess
initToConfig (Maybe Text -> CreateProcess) -> m (Maybe Text) -> m CreateProcess
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (env -> Maybe Text) -> m (Maybe Text)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> Maybe Text
forall env. HasInit env => env -> Maybe Text
getInit
  CommandP1 -> CreateProcess -> (Region m -> Log -> m ()) -> m ()
forall r (m :: Type -> Type).
(HasCommonLogging r, MonadReader r m, MonadRegionLogger m) =>
CommandP1 -> CreateProcess -> (Region m -> Log -> m ()) -> m ()
logDebugCmd CommandP1
cmd CreateProcess
procConfig (Maybe (Region m) -> Log -> m ()
logFn (Maybe (Region m) -> Log -> m ())
-> (Region m -> Maybe (Region m)) -> Region m -> Log -> 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
. Region m -> Maybe (Region m)
forall a. a -> Maybe a
Just)

  (ExitCode
exitCode, ReadHandleResult
finalData) <- CreateProcess
-> (Maybe Handle
    -> Maybe Handle
    -> Maybe Handle
    -> ProcessHandle
    -> m (ExitCode, ReadHandleResult))
-> m (ExitCode, ReadHandleResult)
forall a.
HasCallStack =>
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> m a)
-> m a
forall (m :: Type -> Type) a.
(MonadProcess m, HasCallStack) =>
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> m a)
-> m a
P.withCreateProcess CreateProcess
procConfig ((Maybe Handle
  -> Maybe Handle
  -> Maybe Handle
  -> ProcessHandle
  -> m (ExitCode, ReadHandleResult))
 -> m (ExitCode, ReadHandleResult))
-> (Maybe Handle
    -> Maybe Handle
    -> Maybe Handle
    -> ProcessHandle
    -> m (ExitCode, ReadHandleResult))
-> m (ExitCode, ReadHandleResult)
forall a b. (a -> b) -> a -> b
$ \Maybe Handle
_ Maybe Handle
_ Maybe Handle
_ ProcessHandle
ph -> do
    -- Store the process PID and potential child PIDs. This is potentially
    -- needed for later cleanup, as the /bin/sh command may start children
    -- whose parents are later reassigned to PID 1.
    --
    -- See NOTE: [Command cleanup]
    Maybe Pid
mPid <- ProcessHandle -> m (Maybe Pid)
forall (m :: Type -> Type).
(MonadProcess m, HasCallStack) =>
ProcessHandle -> m (Maybe Pid)
P.getPid ProcessHandle
ph
    [Pid]
childPids <- Bool -> Maybe Pid -> m [Pid]
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) =>
Bool -> Maybe Pid -> m [Pid]
getChildPids Bool
True Maybe Pid
mPid
    CommandP1 -> CommandStatus -> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadAtomic m, MonadReader env m,
 MonadThrow m) =>
CommandP1 -> CommandStatus -> m ()
updateCommandStatus CommandP1
cmd ((Maybe Pid, [Pid]) -> CommandStatus
CommandRunning (Maybe Pid
mPid, [Pid]
childPids))
    (Log -> m ())
-> CommandP1
-> ProcessParams 'HandleModeReadWrite
-> m (ExitCode, ReadHandleResult)
forall (p :: HandleMode) (m :: Type -> Type) env.
(CanRead p, HasCallStack, HasCommandLogging env, MonadCatch m,
 MonadHandleReader m, MonadIORef m, MonadProcess m,
 MonadReader env m, MonadThread m, MonadTime m) =>
(Log -> m ())
-> CommandP1 -> ProcessParams p -> m (ExitCode, ReadHandleResult)
streamOutput (Maybe (Region m) -> Log -> m ()
logFn Maybe (Region m)
forall a. Maybe a
Nothing) CommandP1
cmd (HandleRW
recvOutH, HandleRW
recvErrH, ProcessHandle
ph)

  pure $ case ExitCode
exitCode of
    ExitCode
ExitSuccess -> Maybe Stderr
forall a. Maybe a
Nothing
    ExitFailure Int
_ -> Stderr -> Maybe Stderr
forall a. a -> Maybe a
Just (Stderr -> Maybe Stderr) -> Stderr -> Maybe Stderr
forall a b. (a -> b) -> a -> b
$ ReadHandleResult -> Stderr
readHandleResultToStderr ReadHandleResult
finalData
{-# INLINEABLE tryCommandStream #-}

type ProcessParams p = Tuple3 (Handle p) (Handle p) ProcessHandle

streamOutput ::
  forall p m env.
  ( CanRead p,
    HasCallStack,
    HasCommandLogging env,
    MonadCatch m,
    MonadHandleReader m,
    MonadIORef m,
    MonadProcess m,
    MonadReader env m,
    MonadThread m,
    MonadTime m
  ) =>
  -- | Function to apply to streamed logs.
  (Log -> m ()) ->
  -- | Command that was run.
  CommandP1 ->
  -- | Running process params.
  ProcessParams p ->
  -- | Exit code along w/ any leftover data.
  m (ExitCode, ReadHandleResult)
streamOutput :: forall (p :: HandleMode) (m :: Type -> Type) env.
(CanRead p, HasCallStack, HasCommandLogging env, MonadCatch m,
 MonadHandleReader m, MonadIORef m, MonadProcess m,
 MonadReader env m, MonadThread m, MonadTime m) =>
(Log -> m ())
-> CommandP1 -> ProcessParams p -> m (ExitCode, ReadHandleResult)
streamOutput Log -> m ()
logFn CommandP1
cmd ProcessParams p
processParams = do
  -- NOTE: [Saving final error message]
  --
  -- We want to save the final error message if it exists, so that we can
  -- report it to the user. Programs can be inconsistent where they report
  -- errors, so we read both stdout and stderr, prioritizing the latter when
  -- both exist.
  CommandLoggingEnv
commandLogging <- (env -> CommandLoggingEnv) -> m CommandLoggingEnv
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> CommandLoggingEnv
forall env. HasCommandLogging env => env -> CommandLoggingEnv
getCommandLogging

  let bufferLength :: BufferLength
bufferLength = CommandLoggingEnv
commandLogging CommandLoggingEnv
-> Optic' A_Lens NoIx CommandLoggingEnv BufferLength
-> BufferLength
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CommandLoggingEnv BufferLength
#bufferLength
      bufferTimeout :: BufferTimeout
bufferTimeout = CommandLoggingEnv
commandLogging CommandLoggingEnv
-> Optic' A_Lens NoIx CommandLoggingEnv BufferTimeout
-> BufferTimeout
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CommandLoggingEnv BufferTimeout
#bufferTimeout
      reportReadErrors :: ReportReadErrorsSwitch
reportReadErrors = CommandLoggingEnv
commandLogging CommandLoggingEnv
-> Optic' A_Lens NoIx CommandLoggingEnv ReportReadErrorsSwitch
-> ReportReadErrorsSwitch
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CommandLoggingEnv ReportReadErrorsSwitch
#reportReadErrors

      pollInterval :: Natural
      pollInterval :: Natural
pollInterval = CommandLoggingEnv
commandLogging CommandLoggingEnv
-> Optic' A_Lens NoIx CommandLoggingEnv Natural -> Natural
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. (Optic
  A_Lens
  NoIx
  CommandLoggingEnv
  CommandLoggingEnv
  PollInterval
  PollInterval
#pollInterval Optic
  A_Lens
  NoIx
  CommandLoggingEnv
  CommandLoggingEnv
  PollInterval
  PollInterval
-> Optic An_Iso NoIx PollInterval PollInterval Natural Natural
-> Optic' A_Lens NoIx CommandLoggingEnv Natural
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_Iso NoIx PollInterval PollInterval Natural Natural
#unPollInterval)

      sleepFn :: m ()
      sleepFn :: m ()
sleepFn = Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Natural
pollInterval Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
/= Natural
0) (Natural -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadThread m) =>
Natural -> m ()
microsleep Natural
pollInterval)

      blockSize :: Int
      blockSize :: Int
blockSize = CommandLoggingEnv
commandLogging CommandLoggingEnv
-> Optic' A_Lens NoIx CommandLoggingEnv Int -> Int
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. (Optic
  A_Lens NoIx CommandLoggingEnv CommandLoggingEnv ReadSize ReadSize
#readSize Optic
  A_Lens NoIx CommandLoggingEnv CommandLoggingEnv ReadSize ReadSize
-> Optic
     An_Iso NoIx ReadSize ReadSize (Bytes 'B Int) (Bytes 'B Int)
-> Optic
     A_Lens
     NoIx
     CommandLoggingEnv
     CommandLoggingEnv
     (Bytes 'B Int)
     (Bytes 'B Int)
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_Iso NoIx ReadSize ReadSize (Bytes 'B Int) (Bytes 'B Int)
#unReadSize Optic
  A_Lens
  NoIx
  CommandLoggingEnv
  CommandLoggingEnv
  (Bytes 'B Int)
  (Bytes 'B Int)
-> Optic An_Iso NoIx (Bytes 'B Int) (Bytes 'B Int) Int Int
-> Optic' A_Lens NoIx CommandLoggingEnv Int
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_Iso NoIx (Bytes 'B Int) (Bytes 'B Int) Int Int
forall (s :: Size) n. Iso' (Bytes s n) n
_MkBytes)

      readStrategy :: ReadStrategy
readStrategy = CommandLoggingEnv
commandLogging CommandLoggingEnv
-> Optic' A_Lens NoIx CommandLoggingEnv ReadStrategy
-> ReadStrategy
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CommandLoggingEnv ReadStrategy
#readStrategy

      handleToParams ::
        Handle p ->
        m
          ( Tuple3
              (IORef HandleResult)
              (IORef (Maybe UnlinedText))
              (m HandleResult)
          )
      handleToParams :: Handle p
-> m (IORef HandleResult, IORef (Maybe UnlinedText),
      m HandleResult)
handleToParams =
        Int
-> ReadStrategy
-> BufferLength
-> BufferTimeout
-> Handle p
-> m (IORef HandleResult, IORef (Maybe UnlinedText),
      m HandleResult)
forall (p :: HandleMode) (m :: Type -> Type).
(CanRead p, HasCallStack, MonadCatch m, MonadHandleReader m,
 MonadIORef m, MonadTime m) =>
Int
-> ReadStrategy
-> BufferLength
-> BufferTimeout
-> Handle p
-> m (IORef HandleResult, IORef (Maybe UnlinedText),
      m HandleResult)
mkHandleParams
          Int
blockSize
          ReadStrategy
readStrategy
          BufferLength
bufferLength
          BufferTimeout
bufferTimeout

  -- - lastReadXRef: The result of the last read for handle X.
  --
  -- - prevReadXRef: Whatever was leftover from the last read for handle X.
  --   This is part of the "read block line buffer" strategy i.e. only
  --   contains "partial data" from the previous read when it exists
  --   and we are using that strategy. Compare to lastReadXRef, which
  --   __always__ contains the results for the last read, for the purposes
  --   of error reporting.
  --
  -- - readBlockX: Function for reading from handle X.

  (IORef HandleResult
lastReadOutRef, IORef (Maybe UnlinedText)
prevReadOutRef, m HandleResult
readBlockOut) <- Handle p
-> m (IORef HandleResult, IORef (Maybe UnlinedText),
      m HandleResult)
handleToParams Handle p
outHandle
  (IORef HandleResult
lastReadErrRef, IORef (Maybe UnlinedText)
prevReadErrRef, m HandleResult
readBlockErr) <- Handle p
-> m (IORef HandleResult, IORef (Maybe UnlinedText),
      m HandleResult)
handleToParams Handle p
errHandle

  ExitCode
exitCode <- m (Maybe ExitCode) -> m ExitCode
forall (m :: Type -> Type) b. Monad m => m (Maybe b) -> m b
U.untilJust (m (Maybe ExitCode) -> m ExitCode)
-> m (Maybe ExitCode) -> m ExitCode
forall a b. (a -> b) -> a -> b
$ do
    -- We need to read from both stdout and stderr -- regardless of if we
    -- created a single pipe in tryCommandStream -- or else we will miss
    -- messages
    HandleResult
outResult <- m HandleResult
readBlockOut
    HandleResult
errResult <- m HandleResult
readBlockErr

    (Log -> m ())
-> ReportReadErrorsSwitch
-> CommandP1
-> IORef HandleResult
-> HandleResult
-> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadIORef m) =>
(Log -> m ())
-> ReportReadErrorsSwitch
-> CommandP1
-> IORef HandleResult
-> HandleResult
-> m ()
writeLog Log -> m ()
logFn ReportReadErrorsSwitch
reportReadErrors CommandP1
cmd IORef HandleResult
lastReadOutRef HandleResult
outResult
    (Log -> m ())
-> ReportReadErrorsSwitch
-> CommandP1
-> IORef HandleResult
-> HandleResult
-> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadIORef m) =>
(Log -> m ())
-> ReportReadErrorsSwitch
-> CommandP1
-> IORef HandleResult
-> HandleResult
-> m ()
writeLog Log -> m ()
logFn ReportReadErrorsSwitch
reportReadErrors CommandP1
cmd IORef HandleResult
lastReadErrRef HandleResult
errResult

    -- NOTE: IF we do not have a sleep here then the CPU blows up. Adding
    -- a delay helps keep the CPU reasonable.
    m ()
sleepFn

    ProcessHandle -> m (Maybe ExitCode)
forall (m :: Type -> Type).
(MonadProcess m, HasCallStack) =>
ProcessHandle -> m (Maybe ExitCode)
P.getProcessExitCode ProcessHandle
processHandle

  -- These are the final reads while the process was running.
  HandleResult
lastReadOut <- IORef HandleResult -> m HandleResult
forall a. HasCallStack => IORef a -> m a
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
IORef a -> m a
readIORef' IORef HandleResult
lastReadOutRef
  HandleResult
lastReadErr <- IORef HandleResult -> m HandleResult
forall a. HasCallStack => IORef a -> m a
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
IORef a -> m a
readIORef' IORef HandleResult
lastReadErrRef

  -- Leftover data. We need this as the process can exit before everything
  -- is read.
  (HandleResult
remainingOut, HandleResult
remainingErr) <- do
    -- This branch is really a paranoid "ensure we didn't change anything" if
    -- using the ReadBlock strategy. It is possible ReadBlockLineBuffer behaves
    -- the same most of the time; indeed, all of the tests pass with the
    -- normal ReadBlock strategy above even if we use ReadBlockLineBuffer
    -- below.
    case CommandLoggingEnv
commandLogging CommandLoggingEnv
-> Optic' A_Lens NoIx CommandLoggingEnv ReadStrategy
-> ReadStrategy
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CommandLoggingEnv ReadStrategy
#readStrategy of
      ReadStrategy
ReadBlock -> (,) (HandleResult -> HandleResult -> (HandleResult, HandleResult))
-> m HandleResult
-> m (HandleResult -> (HandleResult, HandleResult))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m HandleResult
readBlockOut m (HandleResult -> (HandleResult, HandleResult))
-> m HandleResult -> m (HandleResult, HandleResult)
forall a b. m (a -> b) -> m a -> m b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> m HandleResult
readBlockErr
      ReadStrategy
ReadBlockLineBuffer -> do
        (,)
          (HandleResult -> HandleResult -> (HandleResult, HandleResult))
-> m HandleResult
-> m (HandleResult -> (HandleResult, HandleResult))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Handle p -> IORef (Maybe UnlinedText) -> m HandleResult
forall (p :: HandleMode) (m :: Type -> Type).
(CanRead p, HasCallStack, MonadCatch m, MonadHandleReader m,
 MonadIORef m, MonadTime m) =>
Int -> Handle p -> IORef (Maybe UnlinedText) -> m HandleResult
readFinalWithPrev Int
blockSize Handle p
outHandle IORef (Maybe UnlinedText)
prevReadOutRef
          m (HandleResult -> (HandleResult, HandleResult))
-> m HandleResult -> m (HandleResult, HandleResult)
forall a b. m (a -> b) -> m a -> m b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Int -> Handle p -> IORef (Maybe UnlinedText) -> m HandleResult
forall (p :: HandleMode) (m :: Type -> Type).
(CanRead p, HasCallStack, MonadCatch m, MonadHandleReader m,
 MonadIORef m, MonadTime m) =>
Int -> Handle p -> IORef (Maybe UnlinedText) -> m HandleResult
readFinalWithPrev Int
blockSize Handle p
errHandle IORef (Maybe UnlinedText)
prevReadErrRef

  (Log -> m ())
-> ReportReadErrorsSwitch
-> CommandP1
-> IORef HandleResult
-> HandleResult
-> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadIORef m) =>
(Log -> m ())
-> ReportReadErrorsSwitch
-> CommandP1
-> IORef HandleResult
-> HandleResult
-> m ()
writeLog Log -> m ()
logFn ReportReadErrorsSwitch
reportReadErrors CommandP1
cmd IORef HandleResult
lastReadOutRef HandleResult
remainingOut
  (Log -> m ())
-> ReportReadErrorsSwitch
-> CommandP1
-> IORef HandleResult
-> HandleResult
-> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadIORef m) =>
(Log -> m ())
-> ReportReadErrorsSwitch
-> CommandP1
-> IORef HandleResult
-> HandleResult
-> m ()
writeLog Log -> m ()
logFn ReportReadErrorsSwitch
reportReadErrors CommandP1
cmd IORef HandleResult
lastReadErrRef HandleResult
remainingErr

  -- NOTE: [Stderr reporting]
  --
  -- In the event of a process failure (exitCode == ExitFailure), we want to
  -- return the last output to give a good error message. We have two
  -- possible reads here:
  --
  -- 1. The last read while the process was running (lastReadErr)
  -- 2. A final read after the process exited (remainingErr)
  --
  -- We return everything, as timing issues means it is not always reliable
  -- which handle has which data. We sort the output according to the time
  -- they were read.
  --
  -- NB. It is not necessarily true that Err has the actual error, or that
  -- timing is respected. For instance, the command "nix run .#format"
  -- may first print a message about a dirty tree to stderr, then print
  -- the actual lint errors to stdout. Hence we actually want to show stdout,
  -- and this should be displayed /after/ stderr.
  --
  -- We therefore sort according to the timestamps in which each message
  -- was read, and display everything.
  --
  -- Do note that the ordering is not necessarily perfect, as it is based
  -- on when we read the handles, /not/ necessarily when the underlying
  -- command output that message. For instance, if the underlying command
  -- prints to stderr then stdout very quickly, we may read them in the same
  -- loop, in which case stdout will be given the earlier timestamp, as we
  -- arbitrarily choose to read it first above.
  let finalData :: ReadHandleResult
finalData =
        (HandleResult -> ReadHandleResult)
-> [HandleResult] -> ReadHandleResult
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: Type -> Type) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap HandleResult -> ReadHandleResult
forall a b. (a, b) -> b
snd
          ([HandleResult] -> ReadHandleResult)
-> ([HandleResult] -> [HandleResult])
-> [HandleResult]
-> ReadHandleResult
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
. (HandleResult -> Double) -> [HandleResult] -> [HandleResult]
forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn HandleResult -> Double
forall a b. (a, b) -> a
fst
          ([HandleResult] -> ReadHandleResult)
-> [HandleResult] -> ReadHandleResult
forall a b. (a -> b) -> a -> b
$ [ HandleResult
lastReadOut,
              HandleResult
lastReadErr,
              HandleResult
remainingOut,
              HandleResult
remainingErr
            ]

  pure (ExitCode
exitCode, ReadHandleResult
finalData)
  where
    (Handle p
outHandle, Handle p
errHandle, ProcessHandle
processHandle) = ProcessParams p
processParams
{-# INLINEABLE streamOutput #-}

-- | Create params for reading from the handle.
mkHandleParams ::
  ( CanRead p,
    HasCallStack,
    MonadCatch m,
    MonadHandleReader m,
    MonadIORef m,
    MonadTime m
  ) =>
  -- | Read block size.
  Int ->
  -- | Read strategy.
  ReadStrategy ->
  -- | Max buffer length, for read-block-line-buffer strategy.
  BufferLength ->
  -- | Max buffer time, for read-block-line-buffer strategy.
  BufferTimeout ->
  -- | Handle from which to read.
  Handle p ->
  -- | Returns:
  --
  --  1. Ref for the last read (always active).
  --  2. Ref for previous partial read (only for read-block-line-buffer
  --     strategy).
  --  3. Read function.
  m
    ( Tuple3
        (IORef HandleResult)
        (IORef (Maybe UnlinedText))
        (m HandleResult)
    )
mkHandleParams :: forall (p :: HandleMode) (m :: Type -> Type).
(CanRead p, HasCallStack, MonadCatch m, MonadHandleReader m,
 MonadIORef m, MonadTime m) =>
Int
-> ReadStrategy
-> BufferLength
-> BufferTimeout
-> Handle p
-> m (IORef HandleResult, IORef (Maybe UnlinedText),
      m HandleResult)
mkHandleParams Int
blockSize ReadStrategy
readStrategy BufferLength
bufLength BufferTimeout
bufTimeout Handle p
handle = do
  IORef HandleResult
lastReadRef <- HandleResult -> m (IORef HandleResult)
forall a. HasCallStack => a -> m (IORef a)
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
a -> m (IORef a)
newIORef' (Double
0, ReadHandleResult
ReadNoData)
  IORef (Maybe UnlinedText)
prevReadRef <- Maybe UnlinedText -> m (IORef (Maybe UnlinedText))
forall a. HasCallStack => a -> m (IORef a)
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
a -> m (IORef a)
newIORef' Maybe UnlinedText
forall a. Maybe a
Nothing

  Double
currTime <- m Double
forall (m :: Type -> Type). (MonadTime m, HasCallStack) => m Double
getMonotonicTime
  IORef Double
bufFlushTimeRef <- Double -> m (IORef Double)
forall a. HasCallStack => a -> m (IORef a)
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
a -> m (IORef a)
newIORef' Double
currTime

  let readFn :: m HandleResult
readFn = case ReadStrategy
readStrategy of
        ReadStrategy
ReadBlock -> Maybe BufferParams -> Int -> Handle p -> m HandleResult
forall (p :: HandleMode) (m :: Type -> Type).
(CanRead p, HasCallStack, MonadCatch m, MonadHandleReader m,
 MonadIORef m, MonadTime m) =>
Maybe BufferParams -> Int -> Handle p -> m HandleResult
Handle.readHandle Maybe BufferParams
forall a. Maybe a
Nothing Int
blockSize Handle p
handle
        ReadStrategy
ReadBlockLineBuffer ->
          let outBufferParams :: BufferParams
outBufferParams = (IORef (Maybe UnlinedText)
prevReadRef, BufferLength
bufLength, BufferTimeout
bufTimeout, IORef Double
bufFlushTimeRef)
           in Maybe BufferParams -> Int -> Handle p -> m HandleResult
forall (p :: HandleMode) (m :: Type -> Type).
(CanRead p, HasCallStack, MonadCatch m, MonadHandleReader m,
 MonadIORef m, MonadTime m) =>
Maybe BufferParams -> Int -> Handle p -> m HandleResult
Handle.readHandle (BufferParams -> Maybe BufferParams
forall a. a -> Maybe a
Just BufferParams
outBufferParams) Int
blockSize Handle p
handle

  pure (IORef HandleResult
lastReadRef, IORef (Maybe UnlinedText)
prevReadRef, m HandleResult
readFn)
{-# INLINEABLE mkHandleParams #-}

-- | Final read after the process has exited, to retrieve leftover data.
-- Only used with the read-block-line-buffer strategy.
readFinalWithPrev ::
  ( CanRead p,
    HasCallStack,
    MonadCatch m,
    MonadHandleReader m,
    MonadIORef m,
    MonadTime m
  ) =>
  -- | Block size.
  Int ->
  -- | Handle from which to read.
  Handle p ->
  -- | Previous partial read.
  IORef (Maybe UnlinedText) ->
  -- | Result.
  m HandleResult
readFinalWithPrev :: forall (p :: HandleMode) (m :: Type -> Type).
(CanRead p, HasCallStack, MonadCatch m, MonadHandleReader m,
 MonadIORef m, MonadTime m) =>
Int -> Handle p -> IORef (Maybe UnlinedText) -> m HandleResult
readFinalWithPrev Int
blockSize Handle p
handle IORef (Maybe UnlinedText)
prevReadRef = do
  Double
readTime <- m Double
forall (m :: Type -> Type). (MonadTime m, HasCallStack) => m Double
getMonotonicTime
  (ReadHandleResult -> HandleResult)
-> m ReadHandleResult -> m HandleResult
forall a b. (a -> b) -> m a -> m b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double
readTime,) (m ReadHandleResult -> m HandleResult)
-> m ReadHandleResult -> m HandleResult
forall a b. (a -> b) -> a -> b
$ Int -> Handle p -> m (Either (NonEmpty UnlinedText) ByteString)
forall (p :: HandleMode) (m :: Type -> Type).
(CanRead p, HasCallStack, MonadCatch m, MonadHandleReader m) =>
Int -> Handle p -> m (Either (NonEmpty UnlinedText) ByteString)
Handle.readHandleRaw Int
blockSize Handle p
handle m (Either (NonEmpty UnlinedText) ByteString)
-> (Either (NonEmpty UnlinedText) ByteString -> m ReadHandleResult)
-> m ReadHandleResult
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
>>= \case
    -- Do not care about errors here, since we may still have leftover
    -- data that we need to get. If we cared, we could log the errors
    -- here, but it seems minor.
    Left NonEmpty UnlinedText
_ -> IORef (Maybe UnlinedText) -> ByteString -> m ReadHandleResult
forall (m :: Type -> Type).
(HasCallStack, MonadIORef m) =>
IORef (Maybe UnlinedText) -> ByteString -> m ReadHandleResult
Handle.readAndUpdateRefFinal IORef (Maybe UnlinedText)
prevReadRef ByteString
""
    Right ByteString
bs -> IORef (Maybe UnlinedText) -> ByteString -> m ReadHandleResult
forall (m :: Type -> Type).
(HasCallStack, MonadIORef m) =>
IORef (Maybe UnlinedText) -> ByteString -> m ReadHandleResult
Handle.readAndUpdateRefFinal IORef (Maybe UnlinedText)
prevReadRef ByteString
bs
{-# INLINEABLE readFinalWithPrev #-}

-- We occasionally get invalid reads here -- usually when the command
-- exits -- likely due to a race condition. It would be nice to
-- prevent these entirely, but for now ignore them, as it does not
-- appear that we ever lose important messages.
--
-- EDIT: Possibly fixed by switch to typed-process and
-- https://github.com/fpco/typed-process/issues/25?
--
-- See Note [EOF / blocking error]
writeLog ::
  ( HasCallStack,
    MonadIORef m
  ) =>
  (Log -> m ()) ->
  ReportReadErrorsSwitch ->
  CommandP1 ->
  IORef HandleResult ->
  HandleResult ->
  m ()
writeLog :: forall (m :: Type -> Type).
(HasCallStack, MonadIORef m) =>
(Log -> m ())
-> ReportReadErrorsSwitch
-> CommandP1
-> IORef HandleResult
-> HandleResult
-> m ()
writeLog = \cases
  -- 1. No data: Do nothing.
  Log -> m ()
_ ReportReadErrorsSwitch
_ CommandP1
_ IORef HandleResult
_ (Double
_, ReadHandleResult
ReadNoData) -> () -> m ()
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
  -- 2. ReadErr but ReadErrors is off: Do nothing.
  Log -> m ()
_ (ReportReadErrorsSwitch -> Bool
getReadErrors -> Bool
False) CommandP1
_ IORef HandleResult
_ (Double
_, ReadErr NonEmpty UnlinedText
_) -> () -> m ()
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
  -- 3. ReadErr and ReadErrors is on: Log it.
  Log -> m ()
logFn (ReportReadErrorsSwitch -> Bool
getReadErrors -> Bool
True) CommandP1
cmd IORef HandleResult
lastReadRef r :: HandleResult
r@(Double
_, ReadErr NonEmpty UnlinedText
messages) ->
    (Log -> m ())
-> CommandP1
-> IORef HandleResult
-> HandleResult
-> NonEmpty UnlinedText
-> m ()
forall (m :: Type -> Type) b.
(HasCallStack, MonadIORef m) =>
(Log -> m b)
-> CommandP1
-> IORef HandleResult
-> HandleResult
-> NonEmpty UnlinedText
-> m ()
writeLogHelper Log -> m ()
logFn CommandP1
cmd IORef HandleResult
lastReadRef HandleResult
r NonEmpty UnlinedText
messages
  -- 4. Log success and potentially errors.
  Log -> m ()
logFn ReportReadErrorsSwitch
reportReadErrors CommandP1
cmd IORef HandleResult
lastReadRef r :: HandleResult
r@(Double
_, ReadErrSuccess NonEmpty UnlinedText
errs NonEmpty UnlinedText
successes) -> do
    Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (ReportReadErrorsSwitch -> Bool
getReadErrors ReportReadErrorsSwitch
reportReadErrors) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ (Log -> m ())
-> CommandP1
-> IORef HandleResult
-> HandleResult
-> NonEmpty UnlinedText
-> m ()
forall (m :: Type -> Type) b.
(HasCallStack, MonadIORef m) =>
(Log -> m b)
-> CommandP1
-> IORef HandleResult
-> HandleResult
-> NonEmpty UnlinedText
-> m ()
writeLogHelper Log -> m ()
logFn CommandP1
cmd IORef HandleResult
lastReadRef HandleResult
r NonEmpty UnlinedText
errs
    (Log -> m ())
-> CommandP1
-> IORef HandleResult
-> HandleResult
-> NonEmpty UnlinedText
-> m ()
forall (m :: Type -> Type) b.
(HasCallStack, MonadIORef m) =>
(Log -> m b)
-> CommandP1
-> IORef HandleResult
-> HandleResult
-> NonEmpty UnlinedText
-> m ()
writeLogHelper Log -> m ()
logFn CommandP1
cmd IORef HandleResult
lastReadRef HandleResult
r NonEmpty UnlinedText
successes
  -- 5. Log successes.
  Log -> m ()
logFn ReportReadErrorsSwitch
_ CommandP1
cmd IORef HandleResult
lastReadRef r :: HandleResult
r@(Double
_, ReadSuccess NonEmpty UnlinedText
messages) ->
    (Log -> m ())
-> CommandP1
-> IORef HandleResult
-> HandleResult
-> NonEmpty UnlinedText
-> m ()
forall (m :: Type -> Type) b.
(HasCallStack, MonadIORef m) =>
(Log -> m b)
-> CommandP1
-> IORef HandleResult
-> HandleResult
-> NonEmpty UnlinedText
-> m ()
writeLogHelper Log -> m ()
logFn CommandP1
cmd IORef HandleResult
lastReadRef HandleResult
r NonEmpty UnlinedText
messages
  where
    getReadErrors :: ReportReadErrorsSwitch -> Bool
getReadErrors = Optic' An_Iso NoIx ReportReadErrorsSwitch Bool
-> ReportReadErrorsSwitch -> Bool
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' An_Iso NoIx ReportReadErrorsSwitch Bool
#unReportReadErrorsSwitch
{-# INLINEABLE writeLog #-}

writeLogHelper ::
  ( HasCallStack,
    MonadIORef m
  ) =>
  (Log -> m b) ->
  CommandP1 ->
  IORef HandleResult ->
  HandleResult ->
  NonEmpty UnlinedText ->
  m ()
writeLogHelper :: forall (m :: Type -> Type) b.
(HasCallStack, MonadIORef m) =>
(Log -> m b)
-> CommandP1
-> IORef HandleResult
-> HandleResult
-> NonEmpty UnlinedText
-> m ()
writeLogHelper Log -> m b
logFn CommandP1
cmd IORef HandleResult
lastReadRef HandleResult
handleResult NonEmpty UnlinedText
messages = do
  IORef HandleResult -> HandleResult -> m ()
forall a. HasCallStack => IORef a -> a -> m ()
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
IORef a -> a -> m ()
writeIORef' IORef HandleResult
lastReadRef HandleResult
handleResult
  NonEmpty UnlinedText -> (UnlinedText -> m b) -> m ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ NonEmpty UnlinedText
messages ((UnlinedText -> m b) -> m ()) -> (UnlinedText -> m b) -> m ()
forall a b. (a -> b) -> a -> b
$ \UnlinedText
msg ->
    Log -> m b
logFn
      (Log -> m b) -> Log -> m b
forall a b. (a -> b) -> a -> b
$ 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,
          lvl :: LogLevel
lvl = LogLevel
LevelCommand,
          mode :: LogMode
mode = LogMode
LogModeSet
        }
{-# INLINEABLE writeLogHelper #-}

logDebugCmd ::
  ( HasCommonLogging r,
    MonadReader r m,
    MonadRegionLogger m
  ) =>
  CommandP1 ->
  CreateProcess ->
  (Region m -> Log -> m ()) ->
  m ()
logDebugCmd :: forall r (m :: Type -> Type).
(HasCommonLogging r, MonadReader r m, MonadRegionLogger m) =>
CommandP1 -> CreateProcess -> (Region m -> Log -> m ()) -> m ()
logDebugCmd CommandP1
cmd CreateProcess
procConfig Region m -> Log -> m ()
logFn = do
  (LogLevel -> m ()) -> m ()
forall env (m :: Type -> Type).
(HasCommonLogging env, MonadReader env m) =>
(LogLevel -> m ()) -> m ()
Logging.logDebug ((LogLevel -> m ()) -> m ()) -> (LogLevel -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \LogLevel
lvl -> do
    let cs :: String
cs = CmdSpec -> String
forall a. Show a => a -> String
show (CmdSpec -> String) -> CmdSpec -> String
forall a b. (a -> b) -> a -> b
$ CreateProcess -> CmdSpec
P.cmdspec CreateProcess
procConfig
        lg :: Log
lg =
          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
"Command: '"
                  UnlinedText -> UnlinedText -> UnlinedText
forall a. Semigroup a => a -> a -> a
<> Text -> UnlinedText
ShrunText.fromTextReplace (String -> Text
pack String
cs)
                  UnlinedText -> UnlinedText -> UnlinedText
forall a. Semigroup a => a -> a -> a
<> UnlinedText
"'",
              LogLevel
lvl :: LogLevel
lvl :: LogLevel
lvl,
              mode :: LogMode
mode = LogMode
Types.LogModeFinish
            }
    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 -> Region m -> Log -> m ()
logFn Region m
r Log
lg

killChildPids ::
  forall env m.
  ( HasCallStack,
    HasCommands env,
    HasLogging env m,
    MonadAtomic m,
    MonadCatch m,
    MonadHandleWriter m,
    MonadProcess m,
    MonadReader env m,
    MonadRegionLogger m,
    MonadTime m
  ) =>
  Maybe Pid ->
  m ()
killChildPids :: 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 ()
killChildPids Maybe Pid
Nothing = LogMessage -> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadHandleWriter m, MonadReader env m, MonadRegionLogger m,
 MonadTime m) =>
LogMessage -> m ()
Logging.putDebugLogDirect LogMessage
"killChildPids: No pid given"
killChildPids (Just Pid
pid) = do
  [Pid]
pidsStr <- Bool -> Maybe Pid -> m [Pid]
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) =>
Bool -> Maybe Pid -> m [Pid]
getChildPids Bool
False (Pid -> Maybe Pid
forall a. a -> Maybe a
Just Pid
pid)
  [Pid]
pidsToKill <- (Pid -> m Bool) -> [Pid] -> m [Pid]
forall (m :: Type -> Type) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM Pid -> m Bool
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 Bool
canKillPid [Pid]
pidsStr
  [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 ()
killPids [Pid]
pidsToKill

getChildPids ::
  ( HasCallStack,
    HasCommands env,
    HasLogging env m,
    MonadAtomic m,
    MonadCatch m,
    MonadHandleWriter m,
    MonadProcess m,
    MonadReader env m,
    MonadRegionLogger m,
    MonadTime m
  ) =>
  -- | Is multithreaded. Used for logging.
  Bool ->
  Maybe Pid ->
  m (List Pid)
getChildPids :: 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) =>
Bool -> Maybe Pid -> m [Pid]
getChildPids Bool
_ Maybe Pid
Nothing = [Pid] -> m [Pid]
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []
getChildPids Bool
multiThreads (Just Pid
pid) = do
  (env -> Maybe CommandCleanup) -> m (Maybe CommandCleanup)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> Maybe CommandCleanup
forall env. HasCommands env => env -> Maybe CommandCleanup
getCleanup m (Maybe CommandCleanup)
-> (Maybe CommandCleanup -> m [Pid]) -> m [Pid]
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
>>= \case
    Maybe CommandCleanup
Nothing -> [Pid] -> m [Pid]
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []
    Just CommandCleanup
cleanup -> do
      (ExitCode
ec, String
stdout, String
stderr) <-
        String -> [String] -> String -> m (ExitCode, String, String)
forall (m :: Type -> Type).
(HasCallStack, MonadCatch m, MonadProcess m) =>
String -> [String] -> String -> m (ExitCode, String, String)
readProcessTotal
          (CommandCleanup
cleanup CommandCleanup
-> Optic' A_Lens NoIx CommandCleanup String -> String
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CommandCleanup String
#findPidsExe)
          [String]
args
          String
"getChildPids"

      let ([Pid]
result, LogMessage
msg) = case ExitCode
ec of
            ExitFailure Int
_ ->
              let m :: LogMessage
m =
                    String -> LogMessage
forall a. IsString a => String -> a
fromString
                      (String -> LogMessage) -> String -> LogMessage
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat
                        [ String
"Failed finding child pids of '",
                          Pid -> String
forall a. Show a => a -> String
show Pid
pid,
                          String
"': out: '",
                          String
stdout,
                          String
"', err: '",
                          String
stderr,
                          String
"'"
                        ]
               in ([], LogMessage
m)
            ExitCode
ExitSuccess ->
              let pidsTxt :: [Text]
pidsTxt =
                    Text -> [Text]
T.lines
                      (Text -> [Text]) -> (String -> Text) -> String -> [Text]
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
. Text -> Text
T.strip
                      (Text -> Text) -> (String -> Text) -> String -> Text
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
. String -> Text
pack
                      (String -> [Text]) -> String -> [Text]
forall a b. (a -> b) -> a -> b
$ String
stdout
                  m :: LogMessage
m =
                    String -> LogMessage
forall a. IsString a => String -> a
fromString
                      (String -> LogMessage) -> String -> LogMessage
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat
                        [ String
"Child pids of '",
                          Pid -> String
forall a. Show a => a -> String
show Pid
pid,
                          String
"': ",
                          Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"," [Text]
pidsTxt
                        ]
               in case (Text -> Maybe Pid) -> [Text] -> Maybe [Pid]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (String -> Maybe Pid
forall a. Read a => String -> Maybe a
TR.readMaybe (String -> Maybe Pid) -> (Text -> String) -> Text -> Maybe Pid
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
. Text -> String
unpack) [Text]
pidsTxt of
                    Maybe [Pid]
Nothing -> ([], String -> LogMessage
forall a. IsString a => String -> a
fromString (String -> LogMessage) -> String -> LogMessage
forall a b. (a -> b) -> a -> b
$ String
"Failed reading pid strings: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Text] -> String
forall a. Show a => a -> String
show [Text]
pidsTxt)
                    Just [Pid]
pids -> ([Pid]
pids, LogMessage
m)
      LogMessage -> m ()
logFn LogMessage
msg
      pure [Pid]
result
  where
    args :: [String]
args = [String
"-P", Pid -> String
forall a. Show a => a -> String
show Pid
pid]

    logFn :: LogMessage -> m ()
logFn =
      -- If multiThreads is active then this function is possibly called from
      -- multiple threads i.e. the logs should be sent to the queue, as usual.
      --
      -- OTOH, this must have been called during termination when the queues
      -- are already shutdown, hence we should log directly.
      if Bool
multiThreads
        then LogMessage -> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadReader env m, MonadRegionLogger m, MonadTime m) =>
LogMessage -> m ()
Logging.putDebugLog
        else LogMessage -> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadHandleWriter m, MonadReader env m, MonadRegionLogger m,
 MonadTime m) =>
LogMessage -> m ()
Logging.putDebugLogDirect

killPids ::
  ( HasCallStack,
    HasCommands env,
    HasLogging env m,
    MonadAtomic m,
    MonadCatch m,
    MonadHandleWriter m,
    MonadProcess m,
    MonadReader env m,
    MonadRegionLogger m,
    MonadTime m
  ) =>
  List Pid ->
  m ()
killPids :: 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 ()
killPids [] = () -> m ()
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
killPids [Pid]
pids =
  m Bool -> m ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void
    (m Bool -> m ()) -> ([Pid] -> m Bool) -> [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
. String -> [Pid] -> m Bool
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) =>
String -> [Pid] -> m Bool
runKill String
"-15"
    ([Pid] -> m ()) -> [Pid] -> m ()
forall a b. (a -> b) -> a -> b
$ [Pid]
pids

canKillPid ::
  forall env m.
  ( HasCallStack,
    HasCommands env,
    HasLogging env m,
    MonadAtomic m,
    MonadCatch m,
    MonadHandleWriter m,
    MonadProcess m,
    MonadReader env m,
    MonadRegionLogger m,
    MonadTime m
  ) =>
  Pid ->
  m Bool
canKillPid :: 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 Bool
canKillPid = String -> [Pid] -> m Bool
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) =>
String -> [Pid] -> m Bool
runKill String
"-0" ([Pid] -> m Bool) -> (Pid -> [Pid]) -> Pid -> m Bool
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 -> [Pid] -> [Pid]
forall a. a -> [a] -> [a]
: [])

runKill ::
  forall env m.
  ( HasCallStack,
    HasCommands env,
    HasLogging env m,
    MonadAtomic m,
    MonadCatch m,
    MonadHandleWriter m,
    MonadProcess m,
    MonadReader env m,
    MonadRegionLogger m,
    MonadTime m
  ) =>
  String ->
  List Pid ->
  m Bool
runKill :: 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) =>
String -> [Pid] -> m Bool
runKill String
signal [Pid]
pids = do
  (env -> Maybe CommandCleanup) -> m (Maybe CommandCleanup)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> Maybe CommandCleanup
forall env. HasCommands env => env -> Maybe CommandCleanup
getCleanup m (Maybe CommandCleanup)
-> (Maybe CommandCleanup -> m Bool) -> m Bool
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
>>= \case
    Maybe CommandCleanup
Nothing -> Bool -> m Bool
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Bool
False
    Just CommandCleanup
cleanup -> do
      (ExitCode
ec, String
stdout, String
stderr) <-
        String -> [String] -> String -> m (ExitCode, String, String)
forall (m :: Type -> Type).
(HasCallStack, MonadCatch m, MonadProcess m) =>
String -> [String] -> String -> m (ExitCode, String, String)
readProcessTotal
          (CommandCleanup
cleanup CommandCleanup
-> Optic' A_Lens NoIx CommandCleanup String -> String
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CommandCleanup String
#killPidsExe)
          (String
signal String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
pidArgs)
          (String
"runKill " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
signal)

      let msg :: LogMessage
msg = case ExitCode
ec of
            ExitCode
ExitSuccess ->
              String -> LogMessage
forall a. IsString a => String -> a
fromString
                (String -> LogMessage) -> String -> LogMessage
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat
                  [ String
"Successfully ran kill ",
                    String
signal,
                    String
" with: ",
                    String
pidDispStr
                  ]
            ExitFailure Int
_ ->
              String -> LogMessage
forall a. IsString a => String -> a
fromString
                (String -> LogMessage) -> String -> LogMessage
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat
                  [ String
"Kill ",
                    String
signal,
                    String
" with '",
                    String
pidDispStr,
                    String
"' failed: ",
                    String
"': out: '",
                    String
stdout,
                    String
"', err: '",
                    String
stderr,
                    String
"'"
                  ]
      LogMessage -> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadHandleWriter m, MonadReader env m, MonadRegionLogger m,
 MonadTime m) =>
LogMessage -> m ()
Logging.putDebugLogDirect LogMessage
msg

      case ExitCode
ec of
        ExitCode
ExitSuccess -> Bool -> m Bool
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Bool
True
        ExitFailure Int
_ -> Bool -> m Bool
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Bool
False
  where
    pidArgs :: [String]
pidArgs = Pid -> String
forall a. Show a => a -> String
show (Pid -> String) -> [Pid] -> [String]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pid]
pids
    pidDispStr :: String
pidDispStr = Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
", " (Pid -> Text
forall a. Show a => a -> Text
showt (Pid -> Text) -> [Pid] -> [Text]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pid]
pids)

readProcessTotal ::
  ( HasCallStack,
    MonadCatch m,
    MonadProcess m
  ) =>
  FilePath ->
  [String] ->
  String ->
  m (ExitCode, String, String)
readProcessTotal :: forall (m :: Type -> Type).
(HasCallStack, MonadCatch m, MonadProcess m) =>
String -> [String] -> String -> m (ExitCode, String, String)
readProcessTotal String
exe [String]
args String
str = do
  m (ExitCode, String, String)
-> m (Either SomeException (ExitCode, String, String))
forall (m :: Type -> Type) a.
(HasCallStack, MonadCatch m) =>
m a -> m (Either SomeException a)
tryMySync (String -> [String] -> String -> m (ExitCode, String, String)
forall (m :: Type -> Type).
(MonadProcess m, HasCallStack) =>
String -> [String] -> String -> m (ExitCode, String, String)
P.readProcessWithExitCode String
exe [String]
args String
str) m (Either SomeException (ExitCode, String, String))
-> (Either SomeException (ExitCode, String, String)
    -> m (ExitCode, String, String))
-> m (ExitCode, String, String)
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
>>= \case
    Left SomeException
ex -> (ExitCode, String, String) -> m (ExitCode, String, String)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Int -> ExitCode
ExitFailure Int
1, String
"", String -> [String] -> ShowS
mkExeErr String
exe [String]
args ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
ex)
    Right (ExitCode, String, String)
r -> (ExitCode, String, String) -> m (ExitCode, String, String)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ExitCode, String, String)
r

mkExeErr :: String -> [String] -> String -> String
mkExeErr :: String -> [String] -> ShowS
mkExeErr String
exeStr [String]
args String
err =
  [String] -> String
forall a. Monoid a => [a] -> a
mconcat
    [ String
"Failed running command '",
      String
exeStr,
      String
"' with args '",
      Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"," (String -> Text
pack (String -> Text) -> [String] -> [Text]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
args),
      String
"': ",
      String
err
    ]