{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP #-}
module Test.Sandwich.Logging where
import Control.Concurrent.Async.Lifted
import qualified Control.Exception as C
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger
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.Process
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail
#endif
debug :: (HasCallStack, MonadLogger m) => Text -> m ()
debug :: Text -> m ()
debug = CallStack -> Text -> m ()
forall (m :: * -> *). MonadLogger m => CallStack -> Text -> m ()
logDebugCS CallStack
HasCallStack => CallStack
callStack
info :: (HasCallStack, MonadLogger m) => Text -> m ()
info :: Text -> m ()
info = CallStack -> Text -> m ()
forall (m :: * -> *). MonadLogger m => CallStack -> Text -> m ()
logInfoCS CallStack
HasCallStack => CallStack
callStack
warn :: (HasCallStack, MonadLogger m) => Text -> m ()
warn :: Text -> m ()
warn = CallStack -> Text -> m ()
forall (m :: * -> *). MonadLogger m => CallStack -> Text -> m ()
logWarnCS CallStack
HasCallStack => CallStack
callStack
logError :: (HasCallStack, MonadLogger m) => Text -> m ()
logError :: Text -> m ()
logError = CallStack -> Text -> m ()
forall (m :: * -> *). MonadLogger m => CallStack -> Text -> m ()
logErrorCS CallStack
HasCallStack => CallStack
callStack
logOther :: (HasCallStack, MonadLogger m) => LogLevel -> Text -> m ()
logOther :: LogLevel -> Text -> m ()
logOther = CallStack -> LogLevel -> Text -> m ()
forall (m :: * -> *).
MonadLogger m =>
CallStack -> LogLevel -> Text -> m ()
logOtherCS CallStack
HasCallStack => CallStack
callStack
createProcessWithLogging :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => CreateProcess -> m ProcessHandle
createProcessWithLogging :: CreateProcess -> m ProcessHandle
createProcessWithLogging CreateProcess
cp = do
(Handle
hRead, Handle
hWrite) <- IO (Handle, Handle) -> m (Handle, Handle)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Handle, Handle)
createPipe
let name :: [Char]
name = case CreateProcess -> CmdSpec
cmdspec CreateProcess
cp of
ShellCommand {} -> [Char]
"shell"
RawCommand [Char]
path [[Char]]
_ -> [Char]
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
[Char]
line <- IO [Char] -> m [Char]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> m [Char]) -> IO [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ Handle -> IO [Char]
hGetLine Handle
hRead
Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [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 (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 :: StdStream
std_out = Handle -> StdStream
UseHandle Handle
hWrite, std_err :: StdStream
std_err = Handle -> StdStream
UseHandle Handle
hWrite })
ProcessHandle -> m ProcessHandle
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessHandle
p
createProcessWithLoggingAndStdin :: (MonadIO m, MonadFail m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => CreateProcess -> String -> m ProcessHandle
createProcessWithLoggingAndStdin :: CreateProcess -> [Char] -> m ProcessHandle
createProcessWithLoggingAndStdin CreateProcess
cp [Char]
input = do
(Handle
hRead, Handle
hWrite) <- IO (Handle, Handle) -> m (Handle, Handle)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Handle, Handle)
createPipe
let name :: [Char]
name = case CreateProcess -> CmdSpec
cmdspec CreateProcess
cp of
ShellCommand {} -> [Char]
"shell"
RawCommand [Char]
path [[Char]]
_ -> [Char]
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
[Char]
line <- IO [Char] -> m [Char]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> m [Char]) -> IO [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ Handle -> IO [Char]
hGetLine Handle
hRead
Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [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 (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 :: StdStream
std_out = Handle -> StdStream
UseHandle Handle
hWrite
, std_err :: StdStream
std_err = Handle -> StdStream
UseHandle Handle
hWrite
, std_in :: StdStream
std_in = StdStream
CreatePipe }
)
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
Prelude.null [Char]
input) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
IO () -> m ()
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 -> [Char] -> IO ()
hPutStr Handle
inh [Char]
input
IO () -> m ()
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 (m :: * -> *) a. Monad m => a -> m a
return ProcessHandle
p
where
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 (m :: * -> *) a. Monad m => a -> m a
return ()
IOException
e -> IOException -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOException
e
callCommandWithLogging :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => String -> m ()
callCommandWithLogging :: [Char] -> m ()
callCommandWithLogging [Char]
cmd = do
(Handle
hRead, Handle
hWrite) <- IO (Handle, Handle) -> m (Handle, Handle)
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 (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 ([Char] -> CreateProcess
shell [Char]
cmd) {
delegate_ctlc :: Bool
delegate_ctlc = Bool
True
, std_out :: StdStream
std_out = Handle -> StdStream
UseHandle Handle
hWrite
, std_err :: StdStream
std_err = Handle -> StdStream
UseHandle Handle
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
[Char]
line <- IO [Char] -> m [Char]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> m [Char]) -> IO [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ Handle -> IO [Char]
hGetLine Handle
hRead
Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|#{cmd}: #{line}|]
IO ExitCode -> m ExitCode
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
p) m ExitCode -> (ExitCode -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
ExitCode
ExitSuccess -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ExitFailure Int
r -> IO () -> m ()
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. (MonadThrow m, Exception e) => e -> m a
throw (IOException -> IO ()) -> IOException -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IOException
userError [i|callCommandWithLogging failed for '#{cmd}': '#{r}'|]