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

-- | Logging functions.

module Test.Sandwich.Logging where

import Control.Concurrent.Async.Lifted
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 GHC.Stack
import System.Exit
import System.IO
import System.Process


-- * 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) => 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

-- | Same as 'createProcessWithLogging', but using 'readCreateProcess'.
readCreateProcessWithLogging :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => CreateProcess -> String -> m String
readCreateProcessWithLogging :: CreateProcess -> [Char] -> m [Char]
readCreateProcessWithLogging 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}|]

  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
$ CreateProcess -> [Char] -> IO [Char]
readCreateProcess (CreateProcess
cp { std_out :: StdStream
std_out = Handle -> StdStream
UseHandle Handle
hWrite, std_err :: StdStream
std_err = Handle -> StdStream
UseHandle Handle
hWrite }) [Char]
input

-- | Higher level version of 'readCreateProcessWithLogging', 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
$ IOError -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw (IOError -> IO ()) -> IOError -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IOError
userError [i|callCommandWithLogging failed for '#{cmd}': '#{r}'|]