{-# LANGUAGE CPP #-}

-- | Logging functions.

module Test.Sandwich.Logging (
  debug
  , info
  , warn
  , Test.Sandwich.Logging.logError
  , Test.Sandwich.Logging.logOther

  -- * Process functions with logging
  , createProcessWithLogging
  , readCreateProcessWithLogging
  , createProcessWithLoggingAndStdin
  , callCommandWithLogging

  , createProcessWithLogging'
  , readCreateProcessWithLogging'
  , createProcessWithLoggingAndStdin'
  , callCommandWithLogging'
  ) where

import Control.Concurrent
import Control.Concurrent.Async.Lifted
import Control.DeepSeq (rnf)
import qualified Control.Exception as C
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger hiding (logOther)
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.String.Interpolate
import Data.Text
import Foreign.C.Error
import GHC.IO.Exception
import GHC.Stack
import System.IO
import System.IO.Error (mkIOError)
import System.Process

#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail
#endif


-- * Basic logging functions


-- | Log a message at level 'LevelDebug'.
debug :: (HasCallStack, MonadLogger m) => Text -> m ()
debug :: forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug = CallStack -> Text -> m ()
forall (m :: * -> *). MonadLogger m => CallStack -> Text -> m ()
logDebugCS CallStack
HasCallStack => CallStack
callStack

-- | Log a message at level 'LevelInfo'.
info :: (HasCallStack, MonadLogger m) => Text -> m ()
info :: forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
info = CallStack -> Text -> m ()
forall (m :: * -> *). MonadLogger m => CallStack -> Text -> m ()
logInfoCS CallStack
HasCallStack => CallStack
callStack

-- | Log a message at level 'LevelWarn'.
warn :: (HasCallStack, MonadLogger m) => Text -> m ()
warn :: forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
warn = CallStack -> Text -> m ()
forall (m :: * -> *). MonadLogger m => CallStack -> Text -> m ()
logWarnCS CallStack
HasCallStack => CallStack
callStack

-- | Log a message at level 'LevelError'.
logError :: (HasCallStack, MonadLogger m) => Text -> m ()
logError :: forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logError = CallStack -> Text -> m ()
forall (m :: * -> *). MonadLogger m => CallStack -> Text -> m ()
logErrorCS CallStack
HasCallStack => CallStack
callStack

-- | Log with a custom 'LogLevel'.
logOther :: (HasCallStack, MonadLogger m) => LogLevel -> Text -> m ()
logOther :: forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
LogLevel -> Text -> m ()
logOther = CallStack -> LogLevel -> Text -> m ()
forall (m :: * -> *).
MonadLogger m =>
CallStack -> LogLevel -> Text -> m ()
logOtherCS CallStack
HasCallStack => CallStack
callStack


-- * System.Process helpers
--
-- | Functions for launching processes while capturing their output in the logs.

-- | Spawn a process with its stdout and stderr connected to the logging system.
-- Every line output by the process will be fed to a 'debug' call.
createProcessWithLogging :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => CreateProcess -> m ProcessHandle
createProcessWithLogging :: forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) =>
CreateProcess -> m ProcessHandle
createProcessWithLogging = LogLevel -> CreateProcess -> m ProcessHandle
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) =>
LogLevel -> CreateProcess -> m ProcessHandle
createProcessWithLogging' LogLevel
LevelDebug

-- | Spawn a process with its stdout and stderr connected to the logging system.
createProcessWithLogging' :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => LogLevel -> CreateProcess -> m ProcessHandle
createProcessWithLogging' :: forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) =>
LogLevel -> CreateProcess -> m ProcessHandle
createProcessWithLogging' LogLevel
logLevel CreateProcess
cp = do
  (Handle
hRead, Handle
hWrite) <- IO (Handle, Handle) -> m (Handle, Handle)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Handle, Handle)
createPipe

  let name :: FilePath
name = case CreateProcess -> CmdSpec
cmdspec CreateProcess
cp of
        ShellCommand {} -> FilePath
"shell"
        RawCommand FilePath
path [FilePath]
_ -> FilePath
path

  Async (StM m Any)
_ <- m Any -> m (Async (StM m Any))
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> m (Async (StM m a))
async (m Any -> m (Async (StM m Any))) -> m Any -> m (Async (StM m Any))
forall a b. (a -> b) -> a -> b
$ m () -> m Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m Any) -> m () -> m Any
forall a b. (a -> b) -> a -> b
$ do
    FilePath
line <- IO FilePath -> m FilePath
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ Handle -> IO FilePath
hGetLine Handle
hRead
    LogLevel -> Text -> m ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
LogLevel -> Text -> m ()
logOther LogLevel
logLevel [i|#{name}: #{line}|]

  (Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
p) <- IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
 -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (CreateProcess
cp { std_out = UseHandle hWrite, std_err = UseHandle hWrite })
  ProcessHandle -> m ProcessHandle
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessHandle
p

-- | Like 'readCreateProcess', but capture the stderr output in the logs.
-- Every line output by the process will be fed to a 'debug' call.
readCreateProcessWithLogging :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => CreateProcess -> String -> m String
readCreateProcessWithLogging :: forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) =>
CreateProcess -> FilePath -> m FilePath
readCreateProcessWithLogging = LogLevel -> CreateProcess -> FilePath -> m FilePath
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) =>
LogLevel -> CreateProcess -> FilePath -> m FilePath
readCreateProcessWithLogging' LogLevel
LevelDebug

-- | Like 'readCreateProcess', but capture the stderr output in the logs.
readCreateProcessWithLogging' :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => LogLevel -> CreateProcess -> String -> m String
readCreateProcessWithLogging' :: forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) =>
LogLevel -> CreateProcess -> FilePath -> m FilePath
readCreateProcessWithLogging' LogLevel
logLevel CreateProcess
cp FilePath
input = do
  (Handle
hReadErr, Handle
hWriteErr) <- IO (Handle, Handle) -> m (Handle, Handle)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Handle, Handle)
createPipe

  let name :: FilePath
name = case CreateProcess -> CmdSpec
cmdspec CreateProcess
cp of
        ShellCommand {} -> FilePath
"shell"
        RawCommand FilePath
path [FilePath]
_ -> FilePath
path

  Async (StM m Any)
_ <- m Any -> m (Async (StM m Any))
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> m (Async (StM m a))
async (m Any -> m (Async (StM m Any))) -> m Any -> m (Async (StM m Any))
forall a b. (a -> b) -> a -> b
$ m () -> m Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m Any) -> m () -> m Any
forall a b. (a -> b) -> a -> b
$ do
    FilePath
line <- IO FilePath -> m FilePath
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ Handle -> IO FilePath
hGetLine Handle
hReadErr
    LogLevel -> Text -> m ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
LogLevel -> Text -> m ()
logOther LogLevel
logLevel [i|#{name}: #{line}|]

  -- Do this just like 'readCreateProcess'
  -- https://hackage.haskell.org/package/process-1.6.17.0/docs/src/System.Process.html#readCreateProcess
  (ExitCode
ex, FilePath
output) <- IO (ExitCode, FilePath) -> m (ExitCode, FilePath)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, FilePath) -> m (ExitCode, FilePath))
-> IO (ExitCode, FilePath) -> m (ExitCode, FilePath)
forall a b. (a -> b) -> a -> b
$ CreateProcess
-> (Maybe Handle
    -> Maybe Handle
    -> Maybe Handle
    -> ProcessHandle
    -> IO (ExitCode, FilePath))
-> IO (ExitCode, FilePath)
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess (CreateProcess
cp { std_in = CreatePipe, std_out = CreatePipe, std_err = UseHandle hWriteErr }) ((Maybe Handle
  -> Maybe Handle
  -> Maybe Handle
  -> ProcessHandle
  -> IO (ExitCode, FilePath))
 -> IO (ExitCode, FilePath))
-> (Maybe Handle
    -> Maybe Handle
    -> Maybe Handle
    -> ProcessHandle
    -> IO (ExitCode, FilePath))
-> IO (ExitCode, FilePath)
forall a b. (a -> b) -> a -> b
$ \Maybe Handle
sin Maybe Handle
sout Maybe Handle
_ ProcessHandle
p -> do
    case (Maybe Handle
sin, Maybe Handle
sout) of
      (Just Handle
hIn, Just Handle
hOut) -> do
        FilePath
output  <- Handle -> IO FilePath
hGetContents Handle
hOut
        IO () -> (IO () -> IO ()) -> IO ()
forall a. IO () -> (IO () -> IO a) -> IO a
withForkWait (() -> IO ()
forall a. a -> IO a
C.evaluate (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ()
forall a. NFData a => a -> ()
rnf FilePath
output) ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
waitOut -> do
          -- now write any input
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
Prelude.null FilePath
input) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            IO () -> IO ()
ignoreSigPipe (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStr Handle
hIn FilePath
input
          -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
          IO () -> IO ()
ignoreSigPipe (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
hIn

          -- wait on the output
          IO ()
waitOut
          Handle -> IO ()
hClose Handle
hOut

        -- wait on the process
        ExitCode
ex <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
p
        (ExitCode, FilePath) -> IO (ExitCode, FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
ex, FilePath
output)
      (Maybe Handle
Nothing, Maybe Handle
_) -> IO (ExitCode, FilePath) -> IO (ExitCode, FilePath)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, FilePath) -> IO (ExitCode, FilePath))
-> IO (ExitCode, FilePath) -> IO (ExitCode, FilePath)
forall a b. (a -> b) -> a -> b
$ IOException -> IO (ExitCode, FilePath)
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throw (IOException -> IO (ExitCode, FilePath))
-> IOException -> IO (ExitCode, FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> IOException
userError FilePath
"readCreateProcessWithStderrLogging: Failed to get a stdin handle."
      (Maybe Handle
_, Maybe Handle
Nothing) -> IO (ExitCode, FilePath) -> IO (ExitCode, FilePath)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, FilePath) -> IO (ExitCode, FilePath))
-> IO (ExitCode, FilePath) -> IO (ExitCode, FilePath)
forall a b. (a -> b) -> a -> b
$ IOException -> IO (ExitCode, FilePath)
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throw (IOException -> IO (ExitCode, FilePath))
-> IOException -> IO (ExitCode, FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> IOException
userError FilePath
"readCreateProcessWithStderrLogging: Failed to get a stdout handle."

  case ExitCode
ex of
    ExitCode
ExitSuccess -> FilePath -> m FilePath
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
output
    ExitFailure Int
r -> IO FilePath -> m FilePath
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> [FilePath] -> Int -> IO FilePath
forall a. FilePath -> FilePath -> [FilePath] -> Int -> IO a
processFailedException FilePath
"readCreateProcessWithLogging" FilePath
cmd [FilePath]
args Int
r

  where
    cmd :: FilePath
cmd = case CreateProcess
cp of
            CreateProcess { cmdspec :: CreateProcess -> CmdSpec
cmdspec = ShellCommand FilePath
sc } -> FilePath
sc
            CreateProcess { cmdspec :: CreateProcess -> CmdSpec
cmdspec = RawCommand FilePath
fp [FilePath]
_ } -> FilePath
fp
    args :: [FilePath]
args = case CreateProcess
cp of
             CreateProcess { cmdspec :: CreateProcess -> CmdSpec
cmdspec = ShellCommand FilePath
_ } -> []
             CreateProcess { cmdspec :: CreateProcess -> CmdSpec
cmdspec = RawCommand FilePath
_ [FilePath]
args' } -> [FilePath]
args'


-- | Spawn a process with its stdout and stderr connected to the logging system.
-- Every line output by the process will be fed to a 'debug' call.
createProcessWithLoggingAndStdin :: (MonadIO m, MonadFail m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => CreateProcess -> String -> m ProcessHandle
createProcessWithLoggingAndStdin :: forall (m :: * -> *).
(MonadIO m, MonadFail m, MonadBaseControl IO m, MonadLogger m,
 HasCallStack) =>
CreateProcess -> FilePath -> m ProcessHandle
createProcessWithLoggingAndStdin = LogLevel -> CreateProcess -> FilePath -> m ProcessHandle
forall (m :: * -> *).
(MonadIO m, MonadFail m, MonadBaseControl IO m, MonadLogger m,
 HasCallStack) =>
LogLevel -> CreateProcess -> FilePath -> m ProcessHandle
createProcessWithLoggingAndStdin' LogLevel
LevelDebug

-- | Spawn a process with its stdout and stderr connected to the logging system.
createProcessWithLoggingAndStdin' :: (MonadIO m, MonadFail m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => LogLevel -> CreateProcess -> String -> m ProcessHandle
createProcessWithLoggingAndStdin' :: forall (m :: * -> *).
(MonadIO m, MonadFail m, MonadBaseControl IO m, MonadLogger m,
 HasCallStack) =>
LogLevel -> CreateProcess -> FilePath -> m ProcessHandle
createProcessWithLoggingAndStdin' LogLevel
logLevel CreateProcess
cp FilePath
input = do
  (Handle
hRead, Handle
hWrite) <- IO (Handle, Handle) -> m (Handle, Handle)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Handle, Handle)
createPipe

  let name :: FilePath
name = case CreateProcess -> CmdSpec
cmdspec CreateProcess
cp of
        ShellCommand {} -> FilePath
"shell"
        RawCommand FilePath
path [FilePath]
_ -> FilePath
path

  Async (StM m Any)
_ <- m Any -> m (Async (StM m Any))
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> m (Async (StM m a))
async (m Any -> m (Async (StM m Any))) -> m Any -> m (Async (StM m Any))
forall a b. (a -> b) -> a -> b
$ m () -> m Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m Any) -> m () -> m Any
forall a b. (a -> b) -> a -> b
$ do
    FilePath
line <- IO FilePath -> m FilePath
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ Handle -> IO FilePath
hGetLine Handle
hRead
    LogLevel -> Text -> m ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
LogLevel -> Text -> m ()
logOther LogLevel
logLevel [i|#{name}: #{line}|]

  (Just Handle
inh, Maybe Handle
_, Maybe Handle
_, ProcessHandle
p) <- IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
 -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (
    CreateProcess
cp { std_out = UseHandle hWrite
       , std_err = UseHandle hWrite
       , std_in = CreatePipe }
    )

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
Prelude.null FilePath
input) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
ignoreSigPipe (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStr Handle
inh FilePath
input
  -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
ignoreSigPipe (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
inh

  ProcessHandle -> m ProcessHandle
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessHandle
p

-- | Higher level version of 'createProcessWithLogging', accepting a shell command.
callCommandWithLogging :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => String -> m ()
callCommandWithLogging :: forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadLogger m) =>
FilePath -> m ()
callCommandWithLogging = LogLevel -> FilePath -> m ()
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadLogger m) =>
LogLevel -> FilePath -> m ()
callCommandWithLogging' LogLevel
LevelDebug

-- | Higher level version of 'createProcessWithLogging'', accepting a shell command.
callCommandWithLogging' :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => LogLevel -> String -> m ()
callCommandWithLogging' :: forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadLogger m) =>
LogLevel -> FilePath -> m ()
callCommandWithLogging' LogLevel
logLevel FilePath
cmd = do
  (Handle
hRead, Handle
hWrite) <- IO (Handle, Handle) -> m (Handle, Handle)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Handle, Handle)
createPipe

  (Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
p) <- IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
 -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (FilePath -> CreateProcess
shell FilePath
cmd) {
    delegate_ctlc = True
    , std_out = UseHandle hWrite
    , std_err = UseHandle hWrite
    }

  Async (StM m Any)
_ <- m Any -> m (Async (StM m Any))
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> m (Async (StM m a))
async (m Any -> m (Async (StM m Any))) -> m Any -> m (Async (StM m Any))
forall a b. (a -> b) -> a -> b
$ m () -> m Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m Any) -> m () -> m Any
forall a b. (a -> b) -> a -> b
$ do
    FilePath
line <- IO FilePath -> m FilePath
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ Handle -> IO FilePath
hGetLine Handle
hRead
    LogLevel -> Text -> m ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
LogLevel -> Text -> m ()
logOther LogLevel
logLevel [i|#{cmd}: #{line}|]

  IO ExitCode -> m ExitCode
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
p) m ExitCode -> (ExitCode -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    ExitCode
ExitSuccess -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ExitFailure Int
r -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IOException -> IO ()
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throw (IOException -> IO ()) -> IOException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IOException
userError [i|callCommandWithLogging failed for '#{cmd}': '#{r}'|]


-- * Util

-- Copied from System.Process
withForkWait :: IO () -> (IO () ->  IO a) -> IO a
withForkWait :: forall a. IO () -> (IO () -> IO a) -> IO a
withForkWait IO ()
async IO () -> IO a
body = do
  MVar (Either SomeException ())
waitVar <- IO (MVar (Either SomeException ()))
forall a. IO (MVar a)
newEmptyMVar :: IO (MVar (Either SomeException ()))
  ((forall a. IO a -> IO a) -> IO a) -> IO a
forall b.
HasCallStack =>
((forall a. IO a -> IO a) -> IO b) -> IO b
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. IO a -> IO a) -> IO a) -> IO a)
-> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
    ThreadId
tid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Either SomeException ())
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (IO () -> IO ()
forall a. IO a -> IO a
restore IO ()
async) IO (Either SomeException ())
-> (Either SomeException () -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar (Either SomeException ()) -> Either SomeException () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException ())
waitVar
    let wait :: IO ()
wait = MVar (Either SomeException ()) -> IO (Either SomeException ())
forall a. MVar a -> IO a
takeMVar MVar (Either SomeException ())
waitVar IO (Either SomeException ())
-> (Either SomeException () -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeException -> IO ())
-> (() -> IO ()) -> Either SomeException () -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> IO ()
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwIO () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
    IO a -> IO a
forall a. IO a -> IO a
restore (IO () -> IO a
body IO ()
wait) IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`C.onException` ThreadId -> IO ()
killThread ThreadId
tid

-- Copied from System.Process
ignoreSigPipe :: IO () -> IO ()
ignoreSigPipe :: IO () -> IO ()
ignoreSigPipe = (IOException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
C.handle ((IOException -> IO ()) -> IO () -> IO ())
-> (IOException -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ \case
  IOError { ioe_type :: IOException -> IOErrorType
ioe_type  = IOErrorType
ResourceVanished, ioe_errno :: IOException -> Maybe CInt
ioe_errno = Just CInt
ioe } | CInt -> Errno
Errno CInt
ioe Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
ePIPE -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  IOException
e -> IOException -> IO ()
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwIO IOException
e

-- Copied from System.Process
processFailedException :: String -> String -> [String] -> Int -> IO a
processFailedException :: forall a. FilePath -> FilePath -> [FilePath] -> Int -> IO a
processFailedException FilePath
fun FilePath
cmd [FilePath]
args Int
exit_code =
      IOException -> IO a
forall a. IOException -> IO a
ioError (IOErrorType
-> FilePath -> Maybe Handle -> Maybe FilePath -> IOException
mkIOError IOErrorType
OtherError (FilePath
fun FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
cmd FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                                     (FilePath -> FilePath) -> [FilePath] -> FilePath
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
Prelude.concatMap ((Char
' 'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:) (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
forall a. Show a => a -> FilePath
show) [FilePath]
args FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                                     FilePath
" (exit " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
exit_code FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
")")
                                 Maybe Handle
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing)