{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP #-}

-- | Logging functions.

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


-- * Basic logging functions


-- | Log a message at level 'LevelDebug'.
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

-- | Log a message at level 'LevelInfo'.
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

-- | Log a message at level 'LevelWarn'.
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

-- | Log a message at level 'LevelError'.
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

-- | Log with a custom 'LogLevel'.
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


-- * 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 :: 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

-- | 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 :: 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
  -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
  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
    -- 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 (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


-- | Higher level version of 'createProcessWithLogging', accepting a shell command.
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}'|]