-- | This modules contains support for external command execution.
--
-- @since 0.5.65
module B9.B9Exec
  ( cmd,
    cmdStdout,
    cmdInteractive,
    hostCmdEither,
    hostCmdStdoutEither,
    hostCmd,
    hostCmdStdIn,
    Timeout (..),
    ptyCmdInteractive,
    HostCommandStdin (..),
    HostCommandStdout (..),
  )
where

import B9.B9Config
import B9.B9Error
import B9.B9Logging
import B9.BuildInfo (BuildInfoReader, isInteractive)
import qualified Conduit as CL
import Control.Concurrent (readMVar, newMVar, modifyMVar_, threadDelay, MVar)
import Control.Concurrent.Async (Concurrently (..), race)
import Control.Eff
import qualified Control.Exception as ExcIO
import Control.Lens (view)
import Control.Monad.Trans.Control (control, embed_, restoreM)
import qualified Data.ByteString as Strict
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.ByteString.Builder as Strict
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Conduit.Process
import Data.Functor ()
import Data.Maybe
import qualified Data.Text as Text
import GHC.Stack
import System.Exit
import System.Posix.Terminal 
import System.Posix.Types 
import System.Posix.Pty
import           Control.Applicative      ((*>))
import           Control.Exception (try, IOException())
import           Data.Conduit             (ConduitT, yield, (.|), runConduit, Void)
import           Data.Conduit.Process     (ClosedStream (..), streamingProcess,
                                           waitForStreamingProcess)
import           Control.Monad.IO.Class   (liftIO)


-- | Execute the given shell command.
--
-- If 'isInteractive' is true, the standard-in will be passed to the external command,
-- and all output of the program will be directed to standard-out.
--
-- The command and the output is either logged to the logfile with 'traceL' or 'errorL' or
-- written to stdout.
--
-- If the command exists with non-zero exit code, the current process exists with the same
-- exit code.
--
-- @since 2.0.0
cmdInteractive ::
  (HasCallStack, Member ExcB9 e, Member BuildInfoReader e, CommandIO e) =>
  String ->
  Eff e ()
cmdInteractive :: String -> Eff e ()
cmdInteractive String
str = do
  Maybe Timeout
t <- Getting (Maybe Timeout) B9Config (Maybe Timeout)
-> B9Config -> Maybe Timeout
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe Timeout) B9Config (Maybe Timeout)
Lens' B9Config (Maybe Timeout)
defaultTimeout (B9Config -> Maybe Timeout)
-> Eff e B9Config -> Eff e (Maybe Timeout)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff e B9Config
forall (e :: [* -> *]). Member B9ConfigReader e => Eff e B9Config
getB9Config
  Bool
inheritStdIn <- Eff e Bool
forall (e :: [* -> *]). Member BuildInfoReader e => Eff e Bool
isInteractive
  Either Timeout ExitCode
ok <-
    if Bool
inheritStdIn
      then HostCommandStdin
-> String -> Maybe Timeout -> Eff e (Either Timeout ExitCode)
forall (e :: [* -> *]).
CommandIO e =>
HostCommandStdin
-> String -> Maybe Timeout -> Eff e (Either Timeout ExitCode)
hostCmdEither HostCommandStdin
HostCommandInheritStdin String
str Maybe Timeout
t
      else HostCommandStdin
-> String -> Maybe Timeout -> Eff e (Either Timeout ExitCode)
forall (e :: [* -> *]).
CommandIO e =>
HostCommandStdin
-> String -> Maybe Timeout -> Eff e (Either Timeout ExitCode)
hostCmdEither HostCommandStdin
HostCommandNoStdin String
str Maybe Timeout
t
  case Either Timeout ExitCode
ok of
    Right ExitCode
_ ->
      () -> Eff e ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Left Timeout
e ->
      String -> Eff e ()
forall (e :: [* -> *]) a.
(CommandIO e, Member ExcB9 e) =>
String -> Eff e a
errorExitL (String
"SYSTEM COMMAND FAILED: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Timeout -> String
forall a. Show a => a -> String
show Timeout
e)

-- | Execute the given shell command.
--
-- The command and the output is either logged to the logfile with 'traceL' or 'errorL' or
-- written to stdout.
--
-- If the command exists with non-zero exit code, the current process exists with the same
-- exit code.
--
-- @since 0.5.65
cmd ::
  (HasCallStack, Member ExcB9 e, CommandIO e) =>
  String ->
  Eff e ()
cmd :: String -> Eff e ()
cmd String
str = do
  Maybe Timeout
t <- Getting (Maybe Timeout) B9Config (Maybe Timeout)
-> B9Config -> Maybe Timeout
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe Timeout) B9Config (Maybe Timeout)
Lens' B9Config (Maybe Timeout)
defaultTimeout (B9Config -> Maybe Timeout)
-> Eff e B9Config -> Eff e (Maybe Timeout)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff e B9Config
forall (e :: [* -> *]). Member B9ConfigReader e => Eff e B9Config
getB9Config
  Either Timeout ExitCode
ok <- HostCommandStdin
-> String -> Maybe Timeout -> Eff e (Either Timeout ExitCode)
forall (e :: [* -> *]).
CommandIO e =>
HostCommandStdin
-> String -> Maybe Timeout -> Eff e (Either Timeout ExitCode)
hostCmdEither HostCommandStdin
HostCommandNoStdin String
str Maybe Timeout
t
  case Either Timeout ExitCode
ok of
    Right ExitCode
_ ->
      () -> Eff e ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Left Timeout
e ->
      String -> Eff e ()
forall (e :: [* -> *]) a.
(CommandIO e, Member ExcB9 e) =>
String -> Eff e a
errorExitL (String
"SYSTEM COMMAND FAILED: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Timeout -> String
forall a. Show a => a -> String
show Timeout
e)

-- | Execute the given shell command and collect its standard output.
--
-- The command and the output is additionally either logged to the logfile with 'traceL' or 'errorL' or
-- written to stdout.
--
-- If the command exists with non-zero exit code, the current process exists with the same
-- exit code.
--
-- @since 3.1.0
cmdStdout ::
  (HasCallStack, Member ExcB9 e, CommandIO e) =>
  String ->
  Eff e Strict.ByteString
cmdStdout :: String -> Eff e ByteString
cmdStdout String
str = do
  Maybe Timeout
t <- Getting (Maybe Timeout) B9Config (Maybe Timeout)
-> B9Config -> Maybe Timeout
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe Timeout) B9Config (Maybe Timeout)
Lens' B9Config (Maybe Timeout)
defaultTimeout (B9Config -> Maybe Timeout)
-> Eff e B9Config -> Eff e (Maybe Timeout)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff e B9Config
forall (e :: [* -> *]). Member B9ConfigReader e => Eff e B9Config
getB9Config
  Either Timeout (ByteString, ExitCode)
ok <- HostCommandStdin
-> HostCommandStdout (ByteString, ExitCode)
-> String
-> Maybe Timeout
-> Eff e (Either Timeout (ByteString, ExitCode))
forall (e :: [* -> *]) a.
CommandIO e =>
HostCommandStdin
-> HostCommandStdout a
-> String
-> Maybe Timeout
-> Eff e (Either Timeout a)
hostCmdStdoutEither HostCommandStdin
HostCommandNoStdin HostCommandStdout (ByteString, ExitCode)
HostCommandStdoutLogAndCapture String
str Maybe Timeout
t
  case Either Timeout (ByteString, ExitCode)
ok of
    Right (ByteString
out, ExitCode
ExitSuccess) ->
      ByteString -> Eff e ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
out
    Right (ByteString
_, e :: ExitCode
e@(ExitFailure Int
_)) -> 
      String -> Eff e ByteString
forall (e :: [* -> *]) a.
(CommandIO e, Member ExcB9 e) =>
String -> Eff e a
errorExitL (String
"SYSTEM COMMAND FAILED: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExitCode -> String
forall a. Show a => a -> String
show ExitCode
e)
    Left Timeout
e ->
      String -> Eff e ByteString
forall (e :: [* -> *]) a.
(CommandIO e, Member ExcB9 e) =>
String -> Eff e a
errorExitL (String
"SYSTEM COMMAND FAILED: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Timeout -> String
forall a. Show a => a -> String
show Timeout
e)

-- | Run a shell command defined by a string and optionally interrupt the command
-- after a given time has elapsed.
-- If the shell command did not exit with 'ExitSuccess', or the timer elapsed,
-- a 'B9Error' is thrown.
--
-- This is only useful for non-interactive commands.
--
-- @since 1.0.0
hostCmd ::
  (CommandIO e, Member ExcB9 e) =>
  -- | The shell command to execute.
  String ->
  -- | An optional 'Timeout'
  Maybe Timeout ->
  -- | An action that performs the shell command and returns 'True' on success
  Eff e Bool
hostCmd :: String -> Maybe Timeout -> Eff e Bool
hostCmd String
cmdStr Maybe Timeout
timeout = do
  Either Timeout ExitCode
res <- HostCommandStdin
-> String -> Maybe Timeout -> Eff e (Either Timeout ExitCode)
forall (e :: [* -> *]).
CommandIO e =>
HostCommandStdin
-> String -> Maybe Timeout -> Eff e (Either Timeout ExitCode)
hostCmdEither HostCommandStdin
HostCommandNoStdin String
cmdStr Maybe Timeout
timeout
  case Either Timeout ExitCode
res of
    Left Timeout
e ->
      String -> Eff e Bool
forall (e :: [* -> *]) a. Member ExcB9 e => String -> Eff e a
throwB9Error (String
"Command timed out: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
cmdStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Timeout -> String
forall a. Show a => a -> String
show Timeout
e)
    Right (ExitFailure Int
ec) -> do
      String -> Eff e ()
forall (e :: [* -> *]). CommandIO e => String -> Eff e ()
errorL (String
"Command exited with error code: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
cmdStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ec)
      Bool -> Eff e Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Right ExitCode
ExitSuccess ->
      Bool -> Eff e Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

-- | Like 'hostCmd' but with std-input attached.
--
-- @since 1.0.0
hostCmdStdIn ::
  (CommandIO e, Member ExcB9 e) =>
  -- | A 'HostCommandStdin' to define standard input.
  -- If the value is 'HostCommandInheritStdin' then
  -- **also stdout and stderr** will be redirected to
  -- the 'Inherited' file descriptors.
  HostCommandStdin ->
  -- | The shell command to execute.
  String ->
  -- | An optional 'Timeout'
  Maybe Timeout ->
  -- | An action that performs the shell command and returns 'True' on success
  Eff e Bool
hostCmdStdIn :: HostCommandStdin -> String -> Maybe Timeout -> Eff e Bool
hostCmdStdIn HostCommandStdin
hostStdIn String
cmdStr Maybe Timeout
timeout = do
  Either Timeout ExitCode
res <- HostCommandStdin
-> String -> Maybe Timeout -> Eff e (Either Timeout ExitCode)
forall (e :: [* -> *]).
CommandIO e =>
HostCommandStdin
-> String -> Maybe Timeout -> Eff e (Either Timeout ExitCode)
hostCmdEither HostCommandStdin
hostStdIn String
cmdStr Maybe Timeout
timeout
  case Either Timeout ExitCode
res of
    Left Timeout
e ->
      String -> Eff e Bool
forall (e :: [* -> *]) a. Member ExcB9 e => String -> Eff e a
throwB9Error (String
"Command timed out: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
cmdStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Timeout -> String
forall a. Show a => a -> String
show Timeout
e)
    Right (ExitFailure Int
ec) -> do
      String -> Eff e ()
forall (e :: [* -> *]). CommandIO e => String -> Eff e ()
errorL (String
"Command exited with error code: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
cmdStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ec)
      Bool -> Eff e Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Right ExitCode
ExitSuccess ->
      Bool -> Eff e Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

-- | Ways to process std-input.
--
-- @since 1.0.0
data HostCommandStdin
  = -- | Disbale std-in
    HostCommandNoStdin
  | -- | Inherit std-in
    HostCommandInheritStdin
  | -- | Produce std-in
    HostCommandStdInConduit (ConduitT () Strict.ByteString IO ())

-- | Run a shell command defined by a string and optionally interrupt the command
-- after a given time has elapsed.
-- This is only useful for non-interactive commands.
--
-- @since 1.0.0
hostCmdEither ::
  forall e.
  (CommandIO e) =>
  -- | A 'HostCommandStdin' to define standard input.
  -- If the value is 'HostCommandInheritStdin' then
  -- **also stdout and stderr** will be redirected to
  -- the 'Inherited' file descriptors.
  HostCommandStdin ->
  -- | The shell command to execute.
  String ->
  -- | An optional 'Timeout'
  Maybe Timeout ->
  Eff e (Either Timeout ExitCode)
hostCmdEither :: HostCommandStdin
-> String -> Maybe Timeout -> Eff e (Either Timeout ExitCode)
hostCmdEither HostCommandStdin
inputSource String
cmdStr Maybe Timeout
timeoutArg = do
  HostCommandStdin
-> HostCommandStdout ExitCode
-> String
-> Maybe Timeout
-> Eff e (Either Timeout ExitCode)
forall (e :: [* -> *]) a.
CommandIO e =>
HostCommandStdin
-> HostCommandStdout a
-> String
-> Maybe Timeout
-> Eff e (Either Timeout a)
hostCmdStdoutEither HostCommandStdin
inputSource HostCommandStdout ExitCode
HostCommandStdoutLog String
cmdStr Maybe Timeout
timeoutArg

-- | Ways to process std-output.
--
-- @since 3.1.0
data HostCommandStdout a where
  -- | Write std-out to the log sink.
  HostCommandStdoutLog :: HostCommandStdout ExitCode
  -- | Write std-out to the log sink, additionally collect and return it. 
  HostCommandStdoutLogAndCapture :: HostCommandStdout (Strict.ByteString, ExitCode)

data HostCommandStdoutState a where
  HostCommandStdoutStateLog :: HostCommandStdoutState ExitCode
  HostCommandStdoutStateLogAndCapture :: MVar Strict.Builder -> HostCommandStdoutState (Strict.ByteString, ExitCode)

emptyState :: (CommandIO e) => HostCommandStdout a -> Eff e (HostCommandStdoutState a)
emptyState :: HostCommandStdout a -> Eff e (HostCommandStdoutState a)
emptyState HostCommandStdout a
HostCommandStdoutLog = HostCommandStdoutState ExitCode
-> Eff e (HostCommandStdoutState ExitCode)
forall (m :: * -> *) a. Monad m => a -> m a
return HostCommandStdoutState ExitCode
HostCommandStdoutStateLog
emptyState HostCommandStdout a
HostCommandStdoutLogAndCapture = IO (MVar Builder) -> Eff e (MVar Builder)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Builder -> IO (MVar Builder)
forall a. a -> IO (MVar a)
newMVar Builder
forall a. Monoid a => a
mempty) Eff e (MVar Builder)
-> (MVar Builder
    -> Eff e (HostCommandStdoutState (ByteString, ExitCode)))
-> Eff e (HostCommandStdoutState (ByteString, ExitCode))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HostCommandStdoutState (ByteString, ExitCode)
-> Eff e (HostCommandStdoutState (ByteString, ExitCode))
forall (m :: * -> *) a. Monad m => a -> m a
return (HostCommandStdoutState (ByteString, ExitCode)
 -> Eff e (HostCommandStdoutState (ByteString, ExitCode)))
-> (MVar Builder -> HostCommandStdoutState (ByteString, ExitCode))
-> MVar Builder
-> Eff e (HostCommandStdoutState (ByteString, ExitCode))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar Builder -> HostCommandStdoutState (ByteString, ExitCode)
HostCommandStdoutStateLogAndCapture

-- | Run a shell command defined by a string and optionally interrupt the command
-- after a given time has elapsed.
-- This is only useful for non-interactive commands.
--
-- Also provide the possibility to receive the stdout of the command. It of course be collected
-- in ram, so be sure the command doesn't have to much output.
--
-- @since 3.1.0
hostCmdStdoutEither ::
  forall e a.
  (CommandIO e) =>
  -- | A 'HostCommandStdin' to define standard input.
  -- If the value is 'HostCommandInheritStdin' then
  -- **also stdout and stderr** will be redirected to
  -- the 'Inherited' file descriptors.
  HostCommandStdin ->
  -- | A 'HostCommandStdout' to define standard output.
  -- No output will be returned in case of timeout or
  -- 'HostComandStdin' being 'HostComandInheritStdin'.
  HostCommandStdout a ->
  -- | The shell command to execute.
  String ->
  -- | An optional 'Timeout'
  Maybe Timeout ->
  Eff e (Either Timeout a)
hostCmdStdoutEither :: HostCommandStdin
-> HostCommandStdout a
-> String
-> Maybe Timeout
-> Eff e (Either Timeout a)
hostCmdStdoutEither HostCommandStdin
inputSource HostCommandStdout a
outputSinkType String
cmdStr Maybe Timeout
timeoutArg = do
  let tag :: String
tag = String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Hashable a => a -> String
printHash String
cmdStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
  String -> Eff e ()
forall (e :: [* -> *]). CommandIO e => String -> Eff e ()
traceL (String -> Eff e ()) -> String -> Eff e ()
forall a b. (a -> b) -> a -> b
$ String
"COMMAND " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tag String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmdStr
  Int
tf <- Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
1 (Maybe Int -> Int) -> (B9Config -> Maybe Int) -> B9Config -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Maybe Int) B9Config (Maybe Int) -> B9Config -> Maybe Int
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe Int) B9Config (Maybe Int)
Lens' B9Config (Maybe Int)
timeoutFactor (B9Config -> Int) -> Eff e B9Config -> Eff e Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff e B9Config
forall (e :: [* -> *]). Member B9ConfigReader e => Eff e B9Config
getB9Config
  Maybe Timeout
timeout <-
    (Timeout -> Timeout) -> Maybe Timeout -> Maybe Timeout
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Timeout
TimeoutMicros (Int -> Timeout) -> (Timeout -> Int) -> Timeout -> Timeout
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \(TimeoutMicros Int
t) -> Int
tf Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
t)
      (Maybe Timeout -> Maybe Timeout)
-> Eff e (Maybe Timeout) -> Eff e (Maybe Timeout)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff e (Maybe Timeout)
-> (Timeout -> Eff e (Maybe Timeout))
-> Maybe Timeout
-> Eff e (Maybe Timeout)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (Getting (Maybe Timeout) B9Config (Maybe Timeout)
-> B9Config -> Maybe Timeout
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe Timeout) B9Config (Maybe Timeout)
Lens' B9Config (Maybe Timeout)
defaultTimeout (B9Config -> Maybe Timeout)
-> Eff e B9Config -> Eff e (Maybe Timeout)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff e B9Config
forall (e :: [* -> *]). Member B9ConfigReader e => Eff e B9Config
getB9Config)
        (Maybe Timeout -> Eff e (Maybe Timeout)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Timeout -> Eff e (Maybe Timeout))
-> (Timeout -> Maybe Timeout) -> Timeout -> Eff e (Maybe Timeout)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Timeout -> Maybe Timeout
forall a. a -> Maybe a
Just)
        Maybe Timeout
timeoutArg
  (RunInBase (Eff e) IO -> IO (StM (Eff e) (Either Timeout a)))
-> Eff e (Either Timeout a)
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b (StM m a)) -> m a
control ((RunInBase (Eff e) IO -> IO (StM (Eff e) (Either Timeout a)))
 -> Eff e (Either Timeout a))
-> (RunInBase (Eff e) IO -> IO (StM (Eff e) (Either Timeout a)))
-> Eff e (Either Timeout a)
forall a b. (a -> b) -> a -> b
$ \RunInBase (Eff e) IO
runInIO ->
    do
      IO (StM (Eff e) (Either Timeout a))
-> (SomeException -> IO (StM (Eff e) (Either Timeout a)))
-> IO (StM (Eff e) (Either Timeout a))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
ExcIO.catch
        (Eff e (Either Timeout a) -> IO (StM (Eff e) (Either Timeout a))
RunInBase (Eff e) IO
runInIO (Maybe Timeout -> String -> Eff e (Either Timeout a)
go Maybe Timeout
timeout String
tag))
        ( \(SomeException
e :: ExcIO.SomeException) -> do
            Eff e () -> IO (StM (Eff e) ())
RunInBase (Eff e) IO
runInIO (String -> Eff e ()
forall (e :: [* -> *]). CommandIO e => String -> Eff e ()
errorL (String
"COMMAND " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tag String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" interrupted: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e))
            Eff e (Either Timeout a) -> IO (StM (Eff e) (Either Timeout a))
RunInBase (Eff e) IO
runInIO (Either Timeout a -> Eff e (Either Timeout a)
forall (m :: * -> *) a. Monad m => a -> m a
return (HostCommandStdout a -> ExitCode -> Either Timeout a
wrapEmptyOutputResult HostCommandStdout a
outputSinkType (Int -> ExitCode
ExitFailure Int
126)))
        )
      IO (StM (Eff e) (Either Timeout a))
-> (StM (Eff e) (Either Timeout a)
    -> IO (StM (Eff e) (Either Timeout a)))
-> IO (StM (Eff e) (Either Timeout a))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StM (Eff e) (Either Timeout a)
-> IO (StM (Eff e) (Either Timeout a))
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM
  where
    wrapEmptyOutputResult :: HostCommandStdout a -> ExitCode -> Either Timeout a
    wrapEmptyOutputResult :: HostCommandStdout a -> ExitCode -> Either Timeout a
wrapEmptyOutputResult HostCommandStdout a
HostCommandStdoutLog ExitCode
ec = ExitCode -> Either Timeout ExitCode
forall a b. b -> Either a b
Right ExitCode
ec
    wrapEmptyOutputResult HostCommandStdout a
HostCommandStdoutLogAndCapture ExitCode
ec = (ByteString, ExitCode) -> Either Timeout (ByteString, ExitCode)
forall a b. b -> Either a b
Right (ByteString
forall a. Monoid a => a
mempty, ExitCode
ec)

    wrapOutputResult :: HostCommandStdoutState a -> ExitCode -> Eff e a
    wrapOutputResult :: HostCommandStdoutState a -> ExitCode -> Eff e a
wrapOutputResult HostCommandStdoutState a
HostCommandStdoutStateLog ExitCode
ec = ExitCode -> Eff e ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ec
    wrapOutputResult (HostCommandStdoutStateLogAndCapture MVar Builder
mvar) ExitCode
ec = do
      Builder
value <- IO Builder -> Eff e Builder
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MVar Builder -> IO Builder
forall a. MVar a -> IO a
readMVar MVar Builder
mvar)
      (ByteString, ExitCode) -> Eff e (ByteString, ExitCode)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ByteString
Lazy.toStrict (Builder -> ByteString
Strict.toLazyByteString Builder
value), ExitCode
ec)

    go :: Maybe Timeout -> String -> Eff e (Either Timeout a)
    go :: Maybe Timeout -> String -> Eff e (Either Timeout a)
go Maybe Timeout
timeout String
tag = do
      ProcessLogger
errorLC <- String -> Eff e ProcessLogger
forall (e :: [* -> *]).
CommandIO e =>
String -> Eff e ProcessLogger
errorMsgProcessLogger String
tag
      let timer :: Timeout -> IO Timeout
timer t :: Timeout
t@(TimeoutMicros Int
micros) = do
            Int -> IO ()
threadDelay Int
micros
            Timeout -> IO Timeout
forall (m :: * -> *) a. Monad m => a -> m a
return Timeout
t
      HostCommandStdoutState a
stdoutState <- HostCommandStdout a -> Eff e (HostCommandStdoutState a)
forall (e :: [* -> *]) a.
CommandIO e =>
HostCommandStdout a -> Eff e (HostCommandStdoutState a)
emptyState HostCommandStdout a
outputSinkType
      (StreamingProcessHandle
cph, IO ExitCode
runCmd) <- case HostCommandStdin
inputSource of
        HostCommandStdin
HostCommandNoStdin -> do
          StdoutSink
outSink <- HostCommandStdoutState a -> String -> Eff e StdoutSink
forall (e :: [* -> *]) a.
CommandIO e =>
HostCommandStdoutState a -> String -> Eff e StdoutSink
createStdoutSink HostCommandStdoutState a
stdoutState String
tag
          (ClosedStream
ClosedStream, ConduitM () ByteString IO ()
cpOut, ConduitM () ByteString IO ()
cpErr, StreamingProcessHandle
cph) <- CreateProcess
-> Eff
     e
     (ClosedStream, ConduitM () ByteString IO (),
      ConduitM () ByteString IO (), StreamingProcessHandle)
forall (m :: * -> *) stdin stdout stderr.
(MonadIO m, InputSource stdin, OutputSink stdout,
 OutputSink stderr) =>
CreateProcess -> m (stdin, stdout, stderr, StreamingProcessHandle)
streamingProcess (String -> CreateProcess
shell String
cmdStr)
          let runCmd :: IO ExitCode
runCmd =
                Concurrently ExitCode -> IO ExitCode
forall a. Concurrently a -> IO a
runConcurrently
                  ( IO () -> Concurrently ()
forall a. IO a -> Concurrently a
Concurrently (ConduitT () Void IO () -> IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitM () ByteString IO ()
cpOut ConduitM () ByteString IO ()
-> ConduitM ByteString Void IO () -> ConduitT () Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| StdoutSink -> ConduitM ByteString Void IO ()
runStdoutSink StdoutSink
outSink))
                      Concurrently () -> Concurrently () -> Concurrently ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IO () -> Concurrently ()
forall a. IO a -> Concurrently a
Concurrently (ConduitT () Void IO () -> IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitM () ByteString IO ()
cpErr ConduitM () ByteString IO ()
-> ConduitM ByteString Void IO () -> ConduitT () Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ProcessLogger -> ConduitM ByteString Void IO ()
runProcessLogger ProcessLogger
errorLC))
                      Concurrently () -> Concurrently ExitCode -> Concurrently ExitCode
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IO ExitCode -> Concurrently ExitCode
forall a. IO a -> Concurrently a
Concurrently (StreamingProcessHandle -> IO ExitCode
forall (m :: * -> *).
MonadIO m =>
StreamingProcessHandle -> m ExitCode
waitForStreamingProcess StreamingProcessHandle
cph)
                  )
          (StreamingProcessHandle, IO ExitCode)
-> Eff e (StreamingProcessHandle, IO ExitCode)
forall (m :: * -> *) a. Monad m => a -> m a
return (StreamingProcessHandle
cph, IO ExitCode
runCmd)
        HostCommandStdin
HostCommandInheritStdin -> do
          (Inherited
Inherited, Inherited
Inherited, Inherited
Inherited, StreamingProcessHandle
cph) <- CreateProcess
-> Eff e (Inherited, Inherited, Inherited, StreamingProcessHandle)
forall (m :: * -> *) stdin stdout stderr.
(MonadIO m, InputSource stdin, OutputSink stdout,
 OutputSink stderr) =>
CreateProcess -> m (stdin, stdout, stderr, StreamingProcessHandle)
streamingProcess (String -> CreateProcess
shell String
cmdStr)
          let runCmd :: IO ExitCode
runCmd = StreamingProcessHandle -> IO ExitCode
forall (m :: * -> *).
MonadIO m =>
StreamingProcessHandle -> m ExitCode
waitForStreamingProcess StreamingProcessHandle
cph
          (StreamingProcessHandle, IO ExitCode)
-> Eff e (StreamingProcessHandle, IO ExitCode)
forall (m :: * -> *) a. Monad m => a -> m a
return (StreamingProcessHandle
cph, IO ExitCode
runCmd)
        HostCommandStdInConduit ConduitM () ByteString IO ()
inputC -> do
          StdoutSink
outSink <- HostCommandStdoutState a -> String -> Eff e StdoutSink
forall (e :: [* -> *]) a.
CommandIO e =>
HostCommandStdoutState a -> String -> Eff e StdoutSink
createStdoutSink HostCommandStdoutState a
stdoutState String
tag
          (ConduitM ByteString Void IO ()
stdIn, ConduitM () ByteString IO ()
cpOut, ConduitM () ByteString IO ()
cpErr, StreamingProcessHandle
cph) <- CreateProcess
-> Eff
     e
     (ConduitM ByteString Void IO (), ConduitM () ByteString IO (),
      ConduitM () ByteString IO (), StreamingProcessHandle)
forall (m :: * -> *) stdin stdout stderr.
(MonadIO m, InputSource stdin, OutputSink stdout,
 OutputSink stderr) =>
CreateProcess -> m (stdin, stdout, stderr, StreamingProcessHandle)
streamingProcess (String -> CreateProcess
shell String
cmdStr)
          let runCmd :: IO ExitCode
runCmd =
                Concurrently ExitCode -> IO ExitCode
forall a. Concurrently a -> IO a
runConcurrently
                  ( IO () -> Concurrently ()
forall a. IO a -> Concurrently a
Concurrently (ConduitT () Void IO () -> IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitM () ByteString IO ()
cpOut ConduitM () ByteString IO ()
-> ConduitM ByteString Void IO () -> ConduitT () Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| StdoutSink -> ConduitM ByteString Void IO ()
runStdoutSink StdoutSink
outSink))
                      Concurrently () -> Concurrently () -> Concurrently ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IO () -> Concurrently ()
forall a. IO a -> Concurrently a
Concurrently (ConduitT () Void IO () -> IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitM () ByteString IO ()
cpErr ConduitM () ByteString IO ()
-> ConduitM ByteString Void IO () -> ConduitT () Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ProcessLogger -> ConduitM ByteString Void IO ()
runProcessLogger ProcessLogger
errorLC))
                      Concurrently () -> Concurrently () -> Concurrently ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IO () -> Concurrently ()
forall a. IO a -> Concurrently a
Concurrently (ConduitT () Void IO () -> IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitM () ByteString IO ()
inputC ConduitM () ByteString IO ()
-> ConduitM ByteString Void IO () -> ConduitT () Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM ByteString Void IO ()
stdIn))
                      Concurrently () -> Concurrently ExitCode -> Concurrently ExitCode
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IO ExitCode -> Concurrently ExitCode
forall a. IO a -> Concurrently a
Concurrently (StreamingProcessHandle -> IO ExitCode
forall (m :: * -> *).
MonadIO m =>
StreamingProcessHandle -> m ExitCode
waitForStreamingProcess StreamingProcessHandle
cph)
                  )
          (StreamingProcessHandle, IO ExitCode)
-> Eff e (StreamingProcessHandle, IO ExitCode)
forall (m :: * -> *) a. Monad m => a -> m a
return (StreamingProcessHandle
cph, IO ExitCode
runCmd)
      Either Timeout ExitCode
e <- IO (Either Timeout ExitCode) -> Eff e (Either Timeout ExitCode)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((IO ExitCode -> IO (Either Timeout ExitCode))
-> (Timeout -> IO ExitCode -> IO (Either Timeout ExitCode))
-> Maybe Timeout
-> IO ExitCode
-> IO (Either Timeout ExitCode)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((ExitCode -> Either Timeout ExitCode)
-> IO ExitCode -> IO (Either Timeout ExitCode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ExitCode -> Either Timeout ExitCode
forall a b. b -> Either a b
Right) (IO Timeout -> IO ExitCode -> IO (Either Timeout ExitCode)
forall a b. IO a -> IO b -> IO (Either a b)
race (IO Timeout -> IO ExitCode -> IO (Either Timeout ExitCode))
-> (Timeout -> IO Timeout)
-> Timeout
-> IO ExitCode
-> IO (Either Timeout ExitCode)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Timeout -> IO Timeout
timer) Maybe Timeout
timeout IO ExitCode
runCmd)
      StreamingProcessHandle -> Eff e ()
forall (m :: * -> *). MonadIO m => StreamingProcessHandle -> m ()
closeStreamingProcessHandle StreamingProcessHandle
cph
      case Either Timeout ExitCode
e of
        Left Timeout
_ ->
          String -> Eff e ()
forall (e :: [* -> *]). CommandIO e => String -> Eff e ()
errorL (String -> Eff e ()) -> String -> Eff e ()
forall a b. (a -> b) -> a -> b
$ String
"COMMAND TIMED OUT " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tag
        Right ExitCode
ExitSuccess ->
          String -> Eff e ()
forall (e :: [* -> *]). CommandIO e => String -> Eff e ()
traceL (String -> Eff e ()) -> String -> Eff e ()
forall a b. (a -> b) -> a -> b
$ String
"COMMAND FINISHED " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tag
        Right (ExitFailure Int
ec) ->
          String -> Eff e ()
forall (e :: [* -> *]). CommandIO e => String -> Eff e ()
errorL (String -> Eff e ()) -> String -> Eff e ()
forall a b. (a -> b) -> a -> b
$ String
"COMMAND FAILED EXIT CODE: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ec String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tag
      (ExitCode -> Eff e a)
-> Either Timeout ExitCode -> Eff e (Either Timeout a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (HostCommandStdoutState a -> ExitCode -> Eff e a
wrapOutputResult HostCommandStdoutState a
stdoutState) Either Timeout ExitCode
e

-- | Execute the given shell command in a newly created pseudo terminal, if necessary.
--
-- @since 2.1.1
ptyCmdInteractive ::
  (HasCallStack, Member ExcB9 e, Member BuildInfoReader e, CommandIO e) =>
  Maybe Timeout ->
  String ->
  [String] ->
  Eff e ()
ptyCmdInteractive :: Maybe Timeout -> String -> [String] -> Eff e ()
ptyCmdInteractive Maybe Timeout
timeoutArg String
progName [String]
progArgs  = do 
--   isInATerm <- liftIO (queryTerminal (Fd 0))
    let cmdStr :: String
cmdStr = [String] -> String
unwords (String
progNameString -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
progArgs)
--   if isInATerm then cmdInteractive cmdStr
--   else do            
    let tag :: String
tag = String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Hashable a => a -> String
printHash String
cmdStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
    String -> Eff e ()
forall (e :: [* -> *]). CommandIO e => String -> Eff e ()
traceL (String -> Eff e ()) -> String -> Eff e ()
forall a b. (a -> b) -> a -> b
$ String
"PTY-COMMAND " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tag String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmdStr
    Int
tf <- Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
1 (Maybe Int -> Int) -> (B9Config -> Maybe Int) -> B9Config -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Maybe Int) B9Config (Maybe Int) -> B9Config -> Maybe Int
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe Int) B9Config (Maybe Int)
Lens' B9Config (Maybe Int)
timeoutFactor (B9Config -> Int) -> Eff e B9Config -> Eff e Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff e B9Config
forall (e :: [* -> *]). Member B9ConfigReader e => Eff e B9Config
getB9Config
    Maybe Timeout
timeout <-
      (Timeout -> Timeout) -> Maybe Timeout -> Maybe Timeout
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Timeout
TimeoutMicros (Int -> Timeout) -> (Timeout -> Int) -> Timeout -> Timeout
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \(TimeoutMicros Int
t) -> Int
tf Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
t)
        (Maybe Timeout -> Maybe Timeout)
-> Eff e (Maybe Timeout) -> Eff e (Maybe Timeout)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff e (Maybe Timeout)
-> (Timeout -> Eff e (Maybe Timeout))
-> Maybe Timeout
-> Eff e (Maybe Timeout)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          (Getting (Maybe Timeout) B9Config (Maybe Timeout)
-> B9Config -> Maybe Timeout
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe Timeout) B9Config (Maybe Timeout)
Lens' B9Config (Maybe Timeout)
defaultTimeout (B9Config -> Maybe Timeout)
-> Eff e B9Config -> Eff e (Maybe Timeout)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff e B9Config
forall (e :: [* -> *]). Member B9ConfigReader e => Eff e B9Config
getB9Config)
          (Maybe Timeout -> Eff e (Maybe Timeout)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Timeout -> Eff e (Maybe Timeout))
-> (Timeout -> Maybe Timeout) -> Timeout -> Eff e (Maybe Timeout)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Timeout -> Maybe Timeout
forall a. a -> Maybe a
Just)
          Maybe Timeout
timeoutArg
    ProcessLogger
traceLC <- String -> Eff e ProcessLogger
forall (e :: [* -> *]).
CommandIO e =>
String -> Eff e ProcessLogger
traceMsgProcessLogger String
tag
    let timer :: Timeout -> IO Timeout
timer t :: Timeout
t@(TimeoutMicros Int
micros) = do
          Int -> IO ()
threadDelay Int
micros
          Timeout -> IO Timeout
forall (m :: * -> *) a. Monad m => a -> m a
return Timeout
t

        runCmd :: IO ExitCode
runCmd = IO ExitCode -> IO ExitCode
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExitCode -> IO ExitCode) -> IO ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ do 
          (Pty
pty, ProcessHandle
procH) <- Maybe [(String, String)]
-> Bool
-> String
-> [String]
-> (Int, Int)
-> IO (Pty, ProcessHandle)
spawnWithPty Maybe [(String, String)]
forall a. Maybe a
Nothing Bool
True String
progName [String]
progArgs (Int
80, Int
25)
          let close :: ConduitM () ByteString IO ()
close = IO () -> ConduitM () ByteString IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (do 
                (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
cleanupProcess (Maybe Handle
forall a. Maybe a
Nothing, Maybe Handle
forall a. Maybe a
Nothing, Maybe Handle
forall a. Maybe a
Nothing, ProcessHandle
procH)
                Pty -> IO ()
closePty Pty
pty)
              output :: IO ()
output = ConduitT () Void IO () -> IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO () -> IO ())
-> ConduitT () Void IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ConduitM () ByteString IO ()
fromProcess ConduitM () ByteString IO ()
-> ConduitM ByteString Void IO () -> ConduitT () Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ProcessLogger -> ConduitM ByteString Void IO ()
runProcessLogger ProcessLogger
traceLC
              fromProcess :: ConduitM () ByteString IO ()
fromProcess = do
                Either IOException ByteString
res <- IO (Either IOException ByteString)
-> ConduitT () ByteString IO (Either IOException ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> IO (Either IOException ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
try (Pty -> IO ByteString
readPty Pty
pty)) 
                case Either IOException ByteString
res of
                  Left (IOException
_ :: IOException) -> do 
                    ConduitM () ByteString IO ()
close
                  Right ByteString
d -> do
                    ByteString -> ConduitM () ByteString IO ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
d
                    ConduitM () ByteString IO ()
fromProcess

          Concurrently ExitCode -> IO ExitCode
forall a. Concurrently a -> IO a
runConcurrently (Concurrently ExitCode -> IO ExitCode)
-> Concurrently ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$
              IO () -> Concurrently ()
forall a. IO a -> Concurrently a
Concurrently IO ()
output Concurrently () -> Concurrently ExitCode -> Concurrently ExitCode
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
              IO ExitCode -> Concurrently ExitCode
forall a. IO a -> Concurrently a
Concurrently (ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
procH)

    Either Timeout ExitCode
e <- IO (Either Timeout ExitCode) -> Eff e (Either Timeout ExitCode)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((IO ExitCode -> IO (Either Timeout ExitCode))
-> (Timeout -> IO ExitCode -> IO (Either Timeout ExitCode))
-> Maybe Timeout
-> IO ExitCode
-> IO (Either Timeout ExitCode)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((ExitCode -> Either Timeout ExitCode)
-> IO ExitCode -> IO (Either Timeout ExitCode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ExitCode -> Either Timeout ExitCode
forall a b. b -> Either a b
Right) (IO Timeout -> IO ExitCode -> IO (Either Timeout ExitCode)
forall a b. IO a -> IO b -> IO (Either a b)
race (IO Timeout -> IO ExitCode -> IO (Either Timeout ExitCode))
-> (Timeout -> IO Timeout)
-> Timeout
-> IO ExitCode
-> IO (Either Timeout ExitCode)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Timeout -> IO Timeout
timer) Maybe Timeout
timeout IO ExitCode
runCmd)
    case Either Timeout ExitCode
e of
      Left Timeout
_ ->
        String -> Eff e ()
forall (e :: [* -> *]). CommandIO e => String -> Eff e ()
errorL (String -> Eff e ()) -> String -> Eff e ()
forall a b. (a -> b) -> a -> b
$ String
"PTY-COMMAND TIMED OUT " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tag
      Right ExitCode
ExitSuccess ->
        String -> Eff e ()
forall (e :: [* -> *]). CommandIO e => String -> Eff e ()
traceL (String -> Eff e ()) -> String -> Eff e ()
forall a b. (a -> b) -> a -> b
$ String
"PTY-COMMAND FINISHED " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tag
      Right (ExitFailure Int
ec) ->
        String -> Eff e ()
forall (e :: [* -> *]). CommandIO e => String -> Eff e ()
errorL (String -> Eff e ()) -> String -> Eff e ()
forall a b. (a -> b) -> a -> b
$ String
"PTY-COMMAND FAILED EXIT CODE: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ec String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tag

newtype ProcessLogger
  = MkProcessLogger
      {ProcessLogger -> ConduitM ByteString Void IO ()
runProcessLogger :: ConduitT Strict.ByteString Void IO ()}

traceMsgProcessLogger :: (CommandIO e) => String -> Eff e ProcessLogger
traceMsgProcessLogger :: String -> Eff e ProcessLogger
traceMsgProcessLogger = (String -> Eff e ()) -> String -> Eff e ProcessLogger
forall (e :: [* -> *]).
CommandIO e =>
(String -> Eff e ()) -> String -> Eff e ProcessLogger
mkMsgProcessLogger String -> Eff e ()
forall (e :: [* -> *]). CommandIO e => String -> Eff e ()
traceL

errorMsgProcessLogger :: (CommandIO e) => String -> Eff e ProcessLogger
errorMsgProcessLogger :: String -> Eff e ProcessLogger
errorMsgProcessLogger = (String -> Eff e ()) -> String -> Eff e ProcessLogger
forall (e :: [* -> *]).
CommandIO e =>
(String -> Eff e ()) -> String -> Eff e ProcessLogger
mkMsgProcessLogger String -> Eff e ()
forall (e :: [* -> *]). CommandIO e => String -> Eff e ()
errorL

mkMsgProcessLogger :: (CommandIO e) => (String -> Eff e ()) -> String -> Eff e ProcessLogger
mkMsgProcessLogger :: (String -> Eff e ()) -> String -> Eff e ProcessLogger
mkMsgProcessLogger String -> Eff e ()
logFun String
prefix = do
  Text -> IO ()
logIO <-
    (Text -> Eff e ()) -> Eff e (Text -> IO ())
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(a -> m ()) -> m (a -> b ())
embed_
      ( \Text
logBytes ->
          String -> Eff e ()
logFun (String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
logBytes)
      )
  ProcessLogger -> Eff e ProcessLogger
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( ConduitM ByteString Void IO () -> ProcessLogger
MkProcessLogger
        ( ConduitT ByteString ByteString IO ()
forall (m :: * -> *).
Monad m =>
ConduitT ByteString ByteString m ()
CB.lines
            ConduitT ByteString ByteString IO ()
-> ConduitM ByteString Void IO () -> ConduitM ByteString Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitT ByteString Text IO ()
forall (m :: * -> *). Monad m => ConduitT ByteString Text m ()
CL.decodeUtf8LenientC
            ConduitT ByteString Text IO ()
-> ConduitM Text Void IO () -> ConduitM ByteString Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (Text -> IO ()) -> ConduitM Text Void IO ()
forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_ (IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> (Text -> IO ()) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
logIO)
        )
    )

newtype StdoutSink
  = MkStdoutSink
      {StdoutSink -> ConduitM ByteString Void IO ()
runStdoutSink :: ConduitT Strict.ByteString Void IO ()}

createStdoutSink :: (CommandIO e) => HostCommandStdoutState a -> String -> Eff e StdoutSink
createStdoutSink :: HostCommandStdoutState a -> String -> Eff e StdoutSink
createStdoutSink HostCommandStdoutState a
HostCommandStdoutStateLog String
tag = String -> Eff e ProcessLogger
forall (e :: [* -> *]).
CommandIO e =>
String -> Eff e ProcessLogger
traceMsgProcessLogger String
tag Eff e ProcessLogger
-> (ProcessLogger -> Eff e StdoutSink) -> Eff e StdoutSink
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StdoutSink -> Eff e StdoutSink
forall (m :: * -> *) a. Monad m => a -> m a
return (StdoutSink -> Eff e StdoutSink)
-> (ProcessLogger -> StdoutSink)
-> ProcessLogger
-> Eff e StdoutSink
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConduitM ByteString Void IO () -> StdoutSink
MkStdoutSink (ConduitM ByteString Void IO () -> StdoutSink)
-> (ProcessLogger -> ConduitM ByteString Void IO ())
-> ProcessLogger
-> StdoutSink
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessLogger -> ConduitM ByteString Void IO ()
runProcessLogger
createStdoutSink (HostCommandStdoutStateLogAndCapture MVar Builder
_stdoutCollector) String
_tag = do
  ConduitM ByteString Void IO ()
logger <- ProcessLogger -> ConduitM ByteString Void IO ()
runProcessLogger (ProcessLogger -> ConduitM ByteString Void IO ())
-> Eff e ProcessLogger -> Eff e (ConduitM ByteString Void IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Eff e ProcessLogger
forall (e :: [* -> *]).
CommandIO e =>
String -> Eff e ProcessLogger
traceMsgProcessLogger String
_tag
  StdoutSink -> Eff e StdoutSink
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( ConduitM ByteString Void IO () -> StdoutSink
MkStdoutSink
       ( ZipSink ByteString IO () -> ConduitM ByteString Void IO ()
forall i (m :: * -> *) r. ZipSink i m r -> Sink i m r
CL.getZipSink
           ( ConduitM ByteString Void IO () -> ZipSink ByteString IO ()
forall i (m :: * -> *) r. Sink i m r -> ZipSink i m r
CL.ZipSink ConduitM ByteString Void IO ()
logger
             ZipSink ByteString IO ()
-> ZipSink ByteString IO () -> ZipSink ByteString IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ConduitM ByteString Void IO () -> ZipSink ByteString IO ()
forall i (m :: * -> *) r. Sink i m r -> ZipSink i m r
CL.ZipSink (MVar Builder -> ConduitM ByteString Void IO ()
forall (m :: * -> *) o.
MonadIO m =>
MVar Builder -> ConduitT ByteString o m ()
writeToMVar MVar Builder
_stdoutCollector)
           )
       )
    )
  where
    writeToMVar :: MVar Builder -> ConduitT ByteString o m ()
writeToMVar MVar Builder
mvar = do
      Maybe ByteString
chunk <- ConduitT ByteString o m (Maybe ByteString)
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
CL.await
      case Maybe ByteString
chunk of
        Maybe ByteString
Nothing -> () -> ConduitT ByteString o m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (Just ByteString
val) -> IO () -> ConduitT ByteString o m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ConduitT ByteString o m ())
-> IO () -> ConduitT ByteString o m ()
forall a b. (a -> b) -> a -> b
$ MVar Builder -> (Builder -> IO Builder) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Builder
mvar ((Builder -> IO Builder) -> IO ())
-> (Builder -> IO Builder) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Builder
old -> Builder -> IO Builder
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder
old Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
Strict.byteString ByteString
val)