{-# 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 :: forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug = forall (m :: * -> *). MonadLogger m => CallStack -> Text -> m ()
logDebugCS HasCallStack => CallStack
callStack

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

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

-- | Log a message at level 'LevelError'.
logError :: (HasCallStack, MonadLogger m) => Text -> m ()
logError :: forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logError = forall (m :: * -> *). MonadLogger m => CallStack -> Text -> m ()
logErrorCS 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 = forall (m :: * -> *).
MonadLogger m =>
CallStack -> LogLevel -> Text -> m ()
logOtherCS 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 CreateProcess
cp = do
  (Handle
hRead, Handle
hWrite) <- 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)
_ <- forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> m (Async (StM m a))
async forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
    FilePath
line <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> IO FilePath
hGetLine Handle
hRead
    forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|#{name}: #{line}|]

  (Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
p) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 })
  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 :: forall (m :: * -> *).
(MonadIO m, MonadFail m, MonadBaseControl IO m, MonadLogger m,
 HasCallStack) =>
CreateProcess -> FilePath -> m ProcessHandle
createProcessWithLoggingAndStdin CreateProcess
cp FilePath
input = do
  (Handle
hRead, Handle
hWrite) <- 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)
_ <- forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> m (Async (StM m a))
async forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
    FilePath
line <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> IO FilePath
hGetLine Handle
hRead
    forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|#{name}: #{line}|]

  (Just Handle
inh, Maybe Handle
_, Maybe Handle
_, ProcessHandle
p) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 }
    )

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
Prelude.null FilePath
input) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
ignoreSigPipe 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
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
ignoreSigPipe forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
inh

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

  where
    -- Copied from System.Process
    ignoreSigPipe :: IO () -> IO ()
    ignoreSigPipe :: IO () -> IO ()
ignoreSigPipe = forall e a. Exception e => (e -> IO a) -> IO a -> IO a
C.handle 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 forall a. Eq a => a -> a -> Bool
== Errno
ePIPE -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      IOException
e -> 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 :: forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadLogger m) =>
FilePath -> m ()
callCommandWithLogging FilePath
cmd = do
  (Handle
hRead, Handle
hWrite) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Handle, Handle)
createPipe

  (Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
p) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (FilePath -> CreateProcess
shell FilePath
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)
_ <- forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> m (Async (StM m a))
async forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
    FilePath
line <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> IO FilePath
hGetLine Handle
hRead
    forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|#{cmd}: #{line}|]

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