-- | Provides the low-level `IO` functions for running shell commands.
module Shrun.IO
  ( -- * Stdout/stderr newtypes
    Stderr (..),

    -- * Running commands
    tryCommandLogging,
  )
where

import Data.ByteString.Lazy qualified as BSL
import Effects.Concurrent.Thread (microsleep)
import Effects.Process.Typed qualified as P
import Effects.Time (withTiming)
import Shrun.Configuration.Data.CommandLogging
  ( ReportReadErrorsSwitch
      ( ReportReadErrorsOff,
        ReportReadErrorsOn
      ),
  )
import Shrun.Configuration.Data.ConsoleLogging
  ( ConsoleLogCmdSwitch
      ( ConsoleLogCmdOff,
        ConsoleLogCmdOn
      ),
  )
import Shrun.Configuration.Env.Types
  ( HasAnyError,
    HasCommandLogging (getCommandLogging),
    HasCommands,
    HasCommonLogging (getCommonLogging),
    HasConsoleLogging (getConsoleLogging),
    HasFileLogging (getFileLogging),
    HasInit (getInit),
    prependCompletedCommand,
    setAnyErrorTrue,
  )
import Shrun.Data.Command (CommandP1, commandToProcess)
import Shrun.Data.Text (UnlinedText)
import Shrun.Data.Text qualified as ShrunText
import Shrun.IO.Types
  ( CommandResult (CommandFailure, CommandSuccess),
    ReadHandleResult (ReadErr, ReadNoData, ReadSuccess),
    Stderr (MkStderr),
    readHandle,
    readHandleResultToStderr,
  )
import Shrun.Logging.Formatting (formatConsoleLog, formatFileLog)
import Shrun.Logging.MonadRegionLogger (MonadRegionLogger (Region, withRegion))
import Shrun.Logging.Types
  ( Log (MkLog, cmd, lvl, mode, msg),
    LogLevel (LevelCommand),
    LogMode (LogModeSet),
    LogRegion (LogRegion),
  )
import Shrun.Prelude
import Shrun.Utils qualified as U

-- | Runs the command, returns ('ExitCode', 'Stderr')
shExitCode ::
  ( HasCallStack,
    HasInit env,
    MonadReader env m,
    MonadTypedProcess m
  ) =>
  CommandP1 ->
  m (ExitCode, Stderr)
shExitCode :: forall env (m :: Type -> Type).
(HasCallStack, HasInit env, MonadReader env m,
 MonadTypedProcess m) =>
CommandP1 -> m (ExitCode, Stderr)
shExitCode CommandP1
cmd = do
  ProcessConfig () () ()
process <- CommandP1 -> Maybe Text -> ProcessConfig () () ()
commandToProcess CommandP1
cmd (Maybe Text -> ProcessConfig () () ())
-> m (Maybe Text) -> m (ProcessConfig () () ())
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
  (ExitCode
exitCode, ByteString
_stdout, ByteString
stderr) <- ProcessConfig () () () -> m (ExitCode, ByteString, ByteString)
forall stdin stdoutIgnored stderrIgnored.
HasCallStack =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ExitCode, ByteString, ByteString)
forall (m :: Type -> Type) stdin stdoutIgnored stderrIgnored.
(MonadTypedProcess m, HasCallStack) =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ExitCode, ByteString, ByteString)
P.readProcess ProcessConfig () () ()
process
  (ExitCode, Stderr) -> m (ExitCode, Stderr)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ExitCode
exitCode, (Text -> Stderr) -> ByteString -> Stderr
forall {c}. (Text -> c) -> ByteString -> c
wrap (List UnlinedText -> Stderr
MkStderr (List UnlinedText -> Stderr)
-> (Text -> List UnlinedText) -> Text -> Stderr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> List UnlinedText
ShrunText.fromText) ByteString
stderr)
  where
    wrap :: (Text -> c) -> ByteString -> c
wrap Text -> c
f = Text -> c
f (Text -> c) -> (ByteString -> Text) -> ByteString -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8Lenient (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict

-- | Version of 'shExitCode' that returns 'Left' 'Stderr' if there is a failure,
-- 'Right' 'Stdout' otherwise.
tryShExitCode ::
  ( HasCallStack,
    HasInit env,
    MonadReader env m,
    MonadTypedProcess m
  ) =>
  CommandP1 ->
  m (Maybe Stderr)
tryShExitCode :: forall env (m :: Type -> Type).
(HasCallStack, HasInit env, MonadReader env m,
 MonadTypedProcess m) =>
CommandP1 -> m (Maybe Stderr)
tryShExitCode CommandP1
cmd =
  CommandP1 -> m (ExitCode, Stderr)
forall env (m :: Type -> Type).
(HasCallStack, HasInit env, MonadReader env m,
 MonadTypedProcess m) =>
CommandP1 -> m (ExitCode, Stderr)
shExitCode CommandP1
cmd m (ExitCode, Stderr)
-> ((ExitCode, Stderr) -> Maybe Stderr) -> m (Maybe Stderr)
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    (ExitCode
ExitSuccess, Stderr
_) -> Maybe Stderr
forall a. Maybe a
Nothing
    (ExitFailure Int
_, Stderr
stderr) -> Stderr -> Maybe Stderr
forall a. a -> Maybe a
Just Stderr
stderr

-- | Runs the command, returning the time elapsed along with a possible
-- error.
tryCommandLogging ::
  forall m env.
  ( HasAnyError env,
    HasCallStack,
    HasCommands env,
    HasInit env,
    HasCommandLogging env,
    HasCommonLogging env,
    HasConsoleLogging env (Region m),
    HasFileLogging env,
    MonadHandleReader m,
    MonadIORef m,
    MonadMask m,
    MonadReader env m,
    MonadRegionLogger m,
    MonadSTM m,
    MonadThread m,
    MonadTime m,
    MonadTypedProcess m
  ) =>
  -- | Command to run.
  CommandP1 ->
  -- | Result.
  m CommandResult
tryCommandLogging :: forall (m :: Type -> Type) env.
(HasAnyError env, HasCallStack, HasCommands env, HasInit env,
 HasCommandLogging env, HasCommonLogging env,
 HasConsoleLogging env (Region m), HasFileLogging env,
 MonadHandleReader m, MonadIORef m, MonadMask m, MonadReader env m,
 MonadRegionLogger m, MonadSTM m, MonadThread m, MonadTime m,
 MonadTypedProcess 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 prependCompletedCommand, 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) <- (env -> (ConsoleLoggingEnv, TBQueue (LogRegion (Region m))))
-> m (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)))
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)))
forall env r.
HasConsoleLogging env r =>
env -> Tuple2 ConsoleLoggingEnv (TBQueue (LogRegion 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
  let keyHide :: KeyHideSwitch
keyHide = CommonLoggingEnv
commonLogging CommonLoggingEnv
-> Optic' An_Iso NoIx CommonLoggingEnv KeyHideSwitch
-> KeyHideSwitch
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' An_Iso NoIx CommonLoggingEnv KeyHideSwitch
#keyHide

  let cmdFn :: CommandP1 -> m (Maybe Stderr)
cmdFn = case (ConsoleLoggingEnv
consoleLogging ConsoleLoggingEnv
-> Optic' A_Lens NoIx ConsoleLoggingEnv ConsoleLogCmdSwitch
-> ConsoleLogCmdSwitch
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ConsoleLoggingEnv ConsoleLogCmdSwitch
#commandLogging, Maybe FileLoggingEnv
mFileLogging) of
        -- 1. No CommandLogging and no FileLogging: No streaming at all.
        (ConsoleLogCmdSwitch
ConsoleLogCmdOff, Maybe FileLoggingEnv
Nothing) -> CommandP1 -> m (Maybe Stderr)
forall env (m :: Type -> Type).
(HasCallStack, HasInit env, MonadReader env m,
 MonadTypedProcess m) =>
CommandP1 -> m (Maybe Stderr)
tryShExitCode
        -- 3. CommandLogging but no FileLogging. Stream.
        (ConsoleLogCmdSwitch
ConsoleLogCmdOn, 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
region -> do
            let logFn :: Log -> m ()
logFn = KeyHideSwitch
-> TBQueue (LogRegion (Region m))
-> Region m
-> ConsoleLoggingEnv
-> Log
-> m ()
forall {m :: Type -> Type} {r}.
MonadSTM m =>
KeyHideSwitch
-> TBQueue (LogRegion r) -> r -> ConsoleLoggingEnv -> Log -> m ()
logConsole KeyHideSwitch
keyHide TBQueue (LogRegion (Region m))
consoleLogQueue Region m
region ConsoleLoggingEnv
consoleLogging

            Log -> m ()
logFn Log
hello

            (Log -> m ()) -> CommandP1 -> m (Maybe Stderr)
forall env (m :: Type -> Type).
(HasInit env, HasCallStack, HasCommandLogging env,
 MonadHandleReader m, MonadIORef m, MonadMask m, MonadReader env m,
 MonadThread m, MonadTypedProcess m) =>
(Log -> m ()) -> CommandP1 -> m (Maybe Stderr)
tryCommandStream Log -> m ()
logFn CommandP1
cmd
        -- 3. No CommandLogging but FileLogging: Stream (to file) but no console
        --    region.
        (ConsoleLogCmdSwitch
ConsoleLogCmdOff, Just FileLoggingEnv
fileLogging) -> \CommandP1
cmd -> do
          let logFn :: Log -> m ()
              logFn :: Log -> m ()
logFn = KeyHideSwitch -> FileLoggingEnv -> Log -> m ()
forall {m :: Type -> Type}.
(MonadTime m, MonadSTM m) =>
KeyHideSwitch -> FileLoggingEnv -> Log -> m ()
logFile KeyHideSwitch
keyHide FileLoggingEnv
fileLogging

          Log -> m ()
logFn Log
hello

          (Log -> m ()) -> CommandP1 -> m (Maybe Stderr)
forall env (m :: Type -> Type).
(HasInit env, HasCallStack, HasCommandLogging env,
 MonadHandleReader m, MonadIORef m, MonadMask m, MonadReader env m,
 MonadThread m, MonadTypedProcess m) =>
(Log -> m ()) -> CommandP1 -> m (Maybe Stderr)
tryCommandStream Log -> m ()
logFn CommandP1
cmd
        -- 4. CommandLogging and FileLogging: Stream (to both) and create console
        --    region.
        (ConsoleLogCmdSwitch
ConsoleLogCmdOn, 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
region -> do
            let logFn :: Log -> m ()
logFn Log
log = do
                  KeyHideSwitch
-> TBQueue (LogRegion (Region m))
-> Region m
-> ConsoleLoggingEnv
-> Log
-> m ()
forall {m :: Type -> Type} {r}.
MonadSTM 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 -> Log -> m ()
forall {m :: Type -> Type}.
(MonadTime m, MonadSTM m) =>
KeyHideSwitch -> FileLoggingEnv -> Log -> m ()
logFile KeyHideSwitch
keyHide FileLoggingEnv
fileLogging Log
log

            Log -> m ()
logFn Log
hello

            (Log -> m ()) -> CommandP1 -> m (Maybe Stderr)
forall env (m :: Type -> Type).
(HasInit env, HasCallStack, HasCommandLogging env,
 MonadHandleReader m, MonadIORef m, MonadMask m, MonadReader env m,
 MonadThread m, MonadTypedProcess m) =>
(Log -> m ()) -> CommandP1 -> m (Maybe Stderr)
tryCommandStream 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 -> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadReader env m, MonadSTM m) =>
CommandP1 -> m ()
prependCompletedCommand CommandP1
command

      pure $ RelativeTime -> CommandResult
CommandSuccess (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 -> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadReader env m, MonadSTM m) =>
CommandP1 -> m ()
prependCompletedCommand CommandP1
command

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

      pure $ RelativeTime -> Stderr -> CommandResult
CommandFailure (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
      let formatted :: ConsoleLog
formatted = KeyHideSwitch -> ConsoleLoggingEnv -> Log -> ConsoleLog
formatConsoleLog KeyHideSwitch
keyHide ConsoleLoggingEnv
consoleLogging Log
log
      TBQueue (LogRegion r) -> LogRegion r -> m ()
forall (m :: Type -> Type) a.
(HasCallStack, MonadSTM 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)

    logFile :: KeyHideSwitch -> FileLoggingEnv -> Log -> m ()
logFile KeyHideSwitch
keyHide FileLoggingEnv
fileLogging Log
log = do
      FileLog
formatted <- KeyHideSwitch -> FileLoggingEnv -> Log -> m FileLog
forall (m :: Type -> Type).
(HasCallStack, MonadTime m) =>
KeyHideSwitch -> FileLoggingEnv -> Log -> m FileLog
formatFileLog KeyHideSwitch
keyHide FileLoggingEnv
fileLogging Log
log
      TBQueue FileLog -> FileLog -> m ()
forall (m :: Type -> Type) a.
(HasCallStack, MonadSTM 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

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

-- | Similar to 'tryCommand' except we attempt to stream the commands' output
-- instead of the usual swallowing.
tryCommandStream ::
  ( HasInit env,
    HasCallStack,
    HasCommandLogging env,
    MonadHandleReader m,
    MonadIORef m,
    MonadMask m,
    MonadReader env m,
    MonadThread m,
    MonadTypedProcess m
  ) =>
  -- | Function to apply to streamed logs.
  (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, HasCommandLogging env,
 MonadHandleReader m, MonadIORef m, MonadMask m, MonadReader env m,
 MonadThread m, MonadTypedProcess m) =>
(Log -> m ()) -> CommandP1 -> m (Maybe Stderr)
tryCommandStream Log -> m ()
logFn CommandP1
cmd = do
  let outSpec :: StreamSpec anyStreamType Handle
outSpec = StreamSpec anyStreamType Handle
forall (anyStreamType :: StreamType).
StreamSpec anyStreamType Handle
P.createPipe
      errSpec :: StreamSpec anyStreamType Handle
errSpec = StreamSpec anyStreamType Handle
forall (anyStreamType :: StreamType).
StreamSpec anyStreamType Handle
P.createPipe

  ProcessConfig () Handle Handle
procConfig <-
    (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
      m (Maybe Text)
-> (Maybe Text -> ProcessConfig () Handle Handle)
-> m (ProcessConfig () Handle Handle)
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> StreamSpec 'STOutput Handle
-> ProcessConfig () Handle () -> ProcessConfig () Handle Handle
forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
P.setStderr StreamSpec 'STOutput Handle
forall (anyStreamType :: StreamType).
StreamSpec anyStreamType Handle
outSpec
      (ProcessConfig () Handle () -> ProcessConfig () Handle Handle)
-> (Maybe Text -> ProcessConfig () Handle ())
-> Maybe Text
-> ProcessConfig () Handle Handle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamSpec 'STOutput Handle
-> ProcessConfig () () () -> ProcessConfig () Handle ()
forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
P.setStdout StreamSpec 'STOutput Handle
forall (anyStreamType :: StreamType).
StreamSpec anyStreamType Handle
errSpec
      (ProcessConfig () () () -> ProcessConfig () Handle ())
-> (Maybe Text -> ProcessConfig () () ())
-> Maybe Text
-> ProcessConfig () Handle ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandP1 -> Maybe Text -> ProcessConfig () () ()
commandToProcess CommandP1
cmd

  (ExitCode
exitCode, ReadHandleResult
finalData) <-
    ProcessConfig () Handle Handle
-> (Process () Handle Handle -> m (ExitCode, ReadHandleResult))
-> m (ExitCode, ReadHandleResult)
forall stdin stdout stderr a.
HasCallStack =>
ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a) -> m a
forall (m :: Type -> Type) stdin stdout stderr a.
(MonadTypedProcess m, HasCallStack) =>
ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a) -> m a
P.withProcessWait ProcessConfig () Handle Handle
procConfig ((Log -> m ())
-> CommandP1
-> Process () Handle Handle
-> m (ExitCode, ReadHandleResult)
forall (m :: Type -> Type) env.
(HasCallStack, HasCommandLogging env, MonadCatch m,
 MonadHandleReader m, MonadIORef m, MonadReader env m,
 MonadThread m, MonadTypedProcess m) =>
(Log -> m ())
-> CommandP1
-> Process () Handle Handle
-> m (ExitCode, ReadHandleResult)
streamOutput Log -> m ()
logFn CommandP1
cmd)

  Maybe Stderr -> m (Maybe Stderr)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe Stderr -> m (Maybe Stderr))
-> Maybe Stderr -> m (Maybe Stderr)
forall a b. (a -> b) -> a -> b
$ 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

-- NOTE: This was an attempt to set the buffering so that we could use
-- hGetLine. Unfortunately that failed, see Note
-- [Blocking / Streaming output]. Leaving this here as documentation.
--
--  where
--    -- copy of P.createPipe except we set the buffering
--    createPipe' = P.mkPipeStreamSpec $ \_ h -> do
--      hSetBuffering h NoBuffering
--      pure (h, hClose h)

streamOutput ::
  forall m env.
  ( HasCallStack,
    HasCommandLogging env,
    MonadCatch m,
    MonadHandleReader m,
    MonadIORef m,
    MonadReader env m,
    MonadThread m,
    MonadTypedProcess m
  ) =>
  -- | Function to apply to streamed logs.
  (Log -> m ()) ->
  -- | Command that was run.
  CommandP1 ->
  -- | Process handle.
  Process () Handle Handle ->
  -- | Exit code along w/ any leftover data.
  m (ExitCode, ReadHandleResult)
streamOutput :: forall (m :: Type -> Type) env.
(HasCallStack, HasCommandLogging env, MonadCatch m,
 MonadHandleReader m, MonadIORef m, MonadReader env m,
 MonadThread m, MonadTypedProcess m) =>
(Log -> m ())
-> CommandP1
-> Process () Handle Handle
-> m (ExitCode, ReadHandleResult)
streamOutput Log -> m ()
logFn CommandP1
cmd Process () Handle Handle
p = 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.
  IORef ReadHandleResult
lastReadOutRef <- ReadHandleResult -> m (IORef ReadHandleResult)
forall a. HasCallStack => a -> m (IORef a)
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
a -> m (IORef a)
newIORef ReadHandleResult
ReadNoData
  IORef ReadHandleResult
lastReadErrRef <- ReadHandleResult -> m (IORef ReadHandleResult)
forall a. HasCallStack => a -> m (IORef a)
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
a -> m (IORef a)
newIORef ReadHandleResult
ReadNoData
  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 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 =
        Natural -> Int
forall a b.
(Bits a, Bits b, HasCallStack, Integral a, Integral b, Show a,
 Typeable a, Typeable b) =>
a -> b
unsafeConvertIntegral
          (Natural -> Int) -> Natural -> Int
forall a b. (a -> b) -> a -> b
$ 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 ReadSize ReadSize
#readSize Optic
  A_Lens NoIx CommandLoggingEnv CommandLoggingEnv ReadSize ReadSize
-> Optic
     An_Iso NoIx ReadSize ReadSize (Bytes 'B Natural) (Bytes 'B Natural)
-> Optic
     A_Lens
     NoIx
     CommandLoggingEnv
     CommandLoggingEnv
     (Bytes 'B Natural)
     (Bytes 'B 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 ReadSize ReadSize (Bytes 'B Natural) (Bytes 'B Natural)
#unReadSize Optic
  A_Lens
  NoIx
  CommandLoggingEnv
  CommandLoggingEnv
  (Bytes 'B Natural)
  (Bytes 'B Natural)
-> Optic
     An_Iso NoIx (Bytes 'B Natural) (Bytes 'B Natural) 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 (Bytes 'B Natural) (Bytes 'B Natural) Natural Natural
forall (s :: Size) n. Iso' (Bytes s n) n
_MkBytes)

      readBlock :: (HasCallStack) => Handle -> m ReadHandleResult
      readBlock :: HasCallStack => Handle -> m ReadHandleResult
readBlock = Int -> Handle -> m ReadHandleResult
forall (m :: Type -> Type).
(HasCallStack, MonadCatch m, MonadHandleReader m) =>
Int -> Handle -> m ReadHandleResult
readHandle Int
blockSize

  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
    ReadHandleResult
outResult <- HasCallStack => Handle -> m ReadHandleResult
Handle -> m ReadHandleResult
readBlock (Process () Handle Handle -> Handle
forall stdin stdout stderr. Process stdin stdout stderr -> stdout
P.getStdout Process () Handle Handle
p)
    ReadHandleResult
errResult <- HasCallStack => Handle -> m ReadHandleResult
Handle -> m ReadHandleResult
readBlock (Process () Handle Handle -> Handle
forall stdin stdout stderr. Process stdin stdout stderr -> stderr
P.getStderr Process () Handle Handle
p)

    (Log -> m ())
-> ReportReadErrorsSwitch
-> CommandP1
-> IORef ReadHandleResult
-> ReadHandleResult
-> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadIORef m) =>
(Log -> m ())
-> ReportReadErrorsSwitch
-> CommandP1
-> IORef ReadHandleResult
-> ReadHandleResult
-> m ()
writeLog Log -> m ()
logFn ReportReadErrorsSwitch
reportReadErrors CommandP1
cmd IORef ReadHandleResult
lastReadOutRef ReadHandleResult
outResult
    (Log -> m ())
-> ReportReadErrorsSwitch
-> CommandP1
-> IORef ReadHandleResult
-> ReadHandleResult
-> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadIORef m) =>
(Log -> m ())
-> ReportReadErrorsSwitch
-> CommandP1
-> IORef ReadHandleResult
-> ReadHandleResult
-> m ()
writeLog Log -> m ()
logFn ReportReadErrorsSwitch
reportReadErrors CommandP1
cmd IORef ReadHandleResult
lastReadErrRef ReadHandleResult
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

    Process () Handle Handle -> m (Maybe ExitCode)
forall stdin stdout stderr.
HasCallStack =>
Process stdin stdout stderr -> m (Maybe ExitCode)
forall (m :: Type -> Type) stdin stdout stderr.
(MonadTypedProcess m, HasCallStack) =>
Process stdin stdout stderr -> m (Maybe ExitCode)
P.getExitCode Process () Handle Handle
p

  -- Try to get final data.
  ReadHandleResult
lastReadOut <- IORef ReadHandleResult -> m ReadHandleResult
forall a. HasCallStack => IORef a -> m a
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
IORef a -> m a
readIORef IORef ReadHandleResult
lastReadOutRef
  ReadHandleResult
lastReadErr <- IORef ReadHandleResult -> m ReadHandleResult
forall a. HasCallStack => IORef a -> m a
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
IORef a -> m a
readIORef IORef ReadHandleResult
lastReadErrRef

  -- Leftover data. We need this as the process can exit before everything
  -- is read.
  ReadHandleResult
remainingOut <- HasCallStack => Handle -> m ReadHandleResult
Handle -> m ReadHandleResult
readBlock (Process () Handle Handle -> Handle
forall stdin stdout stderr. Process stdin stdout stderr -> stdout
P.getStdout Process () Handle Handle
p)
  ReadHandleResult
remainingErr <- HasCallStack => Handle -> m ReadHandleResult
Handle -> m ReadHandleResult
readBlock (Process () Handle Handle -> Handle
forall stdin stdout stderr. Process stdin stdout stderr -> stderr
P.getStderr Process () Handle Handle
p)

  -- NOTE: [Stderr reporting]
  --
  -- In the event of a process failure (exitCode == ExitFailure), we want to
  -- return the last (successful) read, as it is the most likely to have
  -- relevant information. We have two possible reads here:
  --
  -- 1. The last read while the process was running (lastReadErr)
  -- 2. A final read after the process exited (remainingData)
  --
  -- We prioritize (Semigroup), in order:
  --
  -- 1. remainingErr
  -- 2. lastReadErr
  -- 3. remainingOut
  -- 4. lastReadOut
  --
  -- We make the assumption that the most recent Stderr is the most likely to
  -- have the relevant error message, though we fall back to stdout as this
  -- is not always true.
  let finalData :: ReadHandleResult
finalData =
        [ReadHandleResult] -> ReadHandleResult
forall a. Monoid a => [a] -> a
mconcat
          [ ReadHandleResult
remainingErr,
            ReadHandleResult
lastReadErr,
            ReadHandleResult
remainingOut,
            ReadHandleResult
lastReadOut
          ]

  pure (ExitCode
exitCode, ReadHandleResult
finalData)

-- 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 ReadHandleResult ->
  ReadHandleResult ->
  m ()
writeLog :: forall (m :: Type -> Type).
(HasCallStack, MonadIORef m) =>
(Log -> m ())
-> ReportReadErrorsSwitch
-> CommandP1
-> IORef ReadHandleResult
-> ReadHandleResult
-> m ()
writeLog Log -> m ()
_ ReportReadErrorsSwitch
_ CommandP1
_ IORef ReadHandleResult
_ ReadHandleResult
ReadNoData = () -> m ()
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
writeLog Log -> m ()
_ ReportReadErrorsSwitch
ReportReadErrorsOff CommandP1
_ IORef ReadHandleResult
_ (ReadErr List UnlinedText
_) = () -> m ()
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
writeLog Log -> m ()
logFn ReportReadErrorsSwitch
ReportReadErrorsOn CommandP1
cmd IORef ReadHandleResult
lastReadRef r :: ReadHandleResult
r@(ReadErr List UnlinedText
messages) =
  (Log -> m ())
-> CommandP1
-> IORef ReadHandleResult
-> ReadHandleResult
-> List UnlinedText
-> m ()
forall (m :: Type -> Type) b.
(HasCallStack, MonadIORef m) =>
(Log -> m b)
-> CommandP1
-> IORef ReadHandleResult
-> ReadHandleResult
-> List UnlinedText
-> m ()
writeLogHelper Log -> m ()
logFn CommandP1
cmd IORef ReadHandleResult
lastReadRef ReadHandleResult
r List UnlinedText
messages
writeLog Log -> m ()
logFn ReportReadErrorsSwitch
_ CommandP1
cmd IORef ReadHandleResult
lastReadRef r :: ReadHandleResult
r@(ReadSuccess List UnlinedText
messages) =
  (Log -> m ())
-> CommandP1
-> IORef ReadHandleResult
-> ReadHandleResult
-> List UnlinedText
-> m ()
forall (m :: Type -> Type) b.
(HasCallStack, MonadIORef m) =>
(Log -> m b)
-> CommandP1
-> IORef ReadHandleResult
-> ReadHandleResult
-> List UnlinedText
-> m ()
writeLogHelper Log -> m ()
logFn CommandP1
cmd IORef ReadHandleResult
lastReadRef ReadHandleResult
r List UnlinedText
messages

writeLogHelper ::
  ( HasCallStack,
    MonadIORef m
  ) =>
  (Log -> m b) ->
  CommandP1 ->
  IORef ReadHandleResult ->
  ReadHandleResult ->
  [UnlinedText] ->
  m ()
writeLogHelper :: forall (m :: Type -> Type) b.
(HasCallStack, MonadIORef m) =>
(Log -> m b)
-> CommandP1
-> IORef ReadHandleResult
-> ReadHandleResult
-> List UnlinedText
-> m ()
writeLogHelper Log -> m b
logFn CommandP1
cmd IORef ReadHandleResult
lastReadRef ReadHandleResult
handleResult List UnlinedText
messages = do
  IORef ReadHandleResult -> ReadHandleResult -> m ()
forall a. HasCallStack => IORef a -> a -> m ()
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
IORef a -> a -> m ()
writeIORef IORef ReadHandleResult
lastReadRef ReadHandleResult
handleResult
  List 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_ List 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,
          UnlinedText
msg :: UnlinedText
msg :: UnlinedText
msg,
          lvl :: LogLevel
lvl = LogLevel
LevelCommand,
          mode :: LogMode
mode = LogMode
LogModeSet
        }