{-# 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.DeepSeq (rnf)
import qualified Control.Exception as C
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift
import Control.Monad.Logger hiding (logOther)
import Data.String.Interpolate
import Data.Text (Text)
import Foreign.C.Error
import GHC.IO.Exception
import GHC.Stack
import System.IO
import System.IO.Error (mkIOError)
import System.Process
import UnliftIO.Async hiding (wait)
import UnliftIO.Exception

#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 :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => CreateProcess -> m ProcessHandle
createProcessWithLogging :: forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadLogger m) =>
CreateProcess -> m ProcessHandle
createProcessWithLogging = (HasCallStack => CreateProcess -> m ProcessHandle)
-> CreateProcess -> m ProcessHandle
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (LogLevel -> CreateProcess -> m ProcessHandle
forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadLogger m) =>
LogLevel -> CreateProcess -> m ProcessHandle
createProcessWithLogging' LogLevel
LevelDebug)

-- | Spawn a process with its stdout and stderr connected to the logging system.
createProcessWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => LogLevel -> CreateProcess -> m ProcessHandle
createProcessWithLogging' :: forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadLogger m) =>
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 Any
_ <- m Any -> m (Async Any)
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (m Any -> m (Async Any)) -> m Any -> m (Async 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
    CallStack -> LogLevel -> Text -> m ()
forall (m :: * -> *).
MonadLogger m =>
CallStack -> LogLevel -> Text -> m ()
logOtherCS CallStack
HasCallStack => CallStack
callStack 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 :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => CreateProcess -> String -> m String
readCreateProcessWithLogging :: forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadLogger m) =>
CreateProcess -> FilePath -> m FilePath
readCreateProcessWithLogging = (HasCallStack => CreateProcess -> FilePath -> m FilePath)
-> CreateProcess -> FilePath -> m FilePath
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (LogLevel -> CreateProcess -> FilePath -> m FilePath
forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadLogger m) =>
LogLevel -> CreateProcess -> FilePath -> m FilePath
readCreateProcessWithLogging' LogLevel
LevelDebug)

-- | Like 'readCreateProcess', but capture the stderr output in the logs.
readCreateProcessWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => LogLevel -> CreateProcess -> String -> m String
readCreateProcessWithLogging' :: forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadLogger m) =>
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 Any
_ <- m Any -> m (Async Any)
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (m Any -> m (Async Any)) -> m Any -> m (Async 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
    CallStack -> LogLevel -> Text -> m ()
forall (m :: * -> *).
MonadLogger m =>
CallStack -> LogLevel -> Text -> m ()
logOtherCS CallStack
HasCallStack => CallStack
callStack 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. (MonadIO m, Exception e) => e -> m a
throwIO (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. (MonadIO m, Exception e) => e -> m a
throwIO (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 :: (HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m) => CreateProcess -> String -> m ProcessHandle
createProcessWithLoggingAndStdin :: forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m) =>
CreateProcess -> FilePath -> m ProcessHandle
createProcessWithLoggingAndStdin = (HasCallStack => CreateProcess -> FilePath -> m ProcessHandle)
-> CreateProcess -> FilePath -> m ProcessHandle
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (LogLevel -> CreateProcess -> FilePath -> m ProcessHandle
forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m) =>
LogLevel -> CreateProcess -> FilePath -> m ProcessHandle
createProcessWithLoggingAndStdin' LogLevel
LevelDebug)

-- | Spawn a process with its stdout and stderr connected to the logging system.
createProcessWithLoggingAndStdin' :: (HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m) => LogLevel -> CreateProcess -> String -> m ProcessHandle
createProcessWithLoggingAndStdin' :: forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m) =>
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 Any
_ <- m Any -> m (Async Any)
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (m Any -> m (Async Any)) -> m Any -> m (Async 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
    CallStack -> LogLevel -> Text -> m ()
forall (m :: * -> *).
MonadLogger m =>
CallStack -> LogLevel -> Text -> m ()
logOtherCS CallStack
HasCallStack => CallStack
callStack 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 :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => String -> m ()
callCommandWithLogging :: forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadLogger m) =>
FilePath -> m ()
callCommandWithLogging = (HasCallStack => FilePath -> m ()) -> FilePath -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (LogLevel -> FilePath -> m ()
forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadLogger m) =>
LogLevel -> FilePath -> m ()
callCommandWithLogging' LogLevel
LevelDebug)

-- | Higher level version of 'createProcessWithLogging'', accepting a shell command.
callCommandWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => LogLevel -> String -> m ()
callCommandWithLogging' :: forall (m :: * -> *).
(HasCallStack, MonadUnliftIO 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 Any
_ <- m Any -> m (Async Any)
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (m Any -> m (Async Any)) -> m Any -> m (Async 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
    CallStack -> LogLevel -> Text -> m ()
forall (m :: * -> *).
MonadLogger m =>
CallStack -> LogLevel -> Text -> m ()
logOtherCS CallStack
HasCallStack => CallStack
callStack 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. (MonadIO m, Exception e) => e -> m a
throwIO (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 ()
asy 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 (m :: * -> *) b.
MonadUnliftIO m =>
((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.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (IO () -> IO ()
forall a. IO a -> IO a
restore IO ()
asy) 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. (MonadIO 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. (MonadIO 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)