-- | A simple formatter that saves all logs from the test to a file.
--
-- This is a "secondary formatter," i.e. one that can run in the background while a "primary formatter" (such as the TerminalUI or Print formatters) monopolize the foreground.
--
-- Documentation can be found <https://codedownio.github.io/sandwich/docs/formatters/log_saver here>.

module Test.Sandwich.Formatters.LogSaver (
  defaultLogSaverFormatter

  -- * Options
  , logSaverPath
  , logSaverLogLevel
  , logSaverFormatter

  -- * Auxiliary types
  , LogPath(..)
  , LogEntryFormatter
  ) where

import Control.Concurrent.STM
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader
import qualified Data.ByteString.Char8 as BS8
import System.FilePath
import System.IO
import Test.Sandwich.Interpreters.RunTree.Logging
import Test.Sandwich.Interpreters.RunTree.Util
import Test.Sandwich.Types.ArgParsing
import Test.Sandwich.Types.RunTree
import Test.Sandwich.Util


-- | Used to save test all logs from the tests to a given path.
data LogSaverFormatter = LogSaverFormatter {
  LogSaverFormatter -> LogPath
logSaverPath :: LogPath
  -- ^ Path where logs will be saved.
  , LogSaverFormatter -> LogLevel
logSaverLogLevel :: LogLevel
  -- ^ Minimum log level to save.
  , LogSaverFormatter -> LogEntryFormatter
logSaverFormatter :: LogEntryFormatter
  -- ^ Formatter function for log entries.
  }

instance Show LogSaverFormatter where
  show :: LogSaverFormatter -> String
show LogSaverFormatter
_ = String
"<LogSaverFormatter>"

-- | A path under which to save logs.
data LogPath =
  LogPathRelativeToRunRoot FilePath
  -- ^ Interpret the path as relative to the test's run root. (If there is no run root, the logs won't be saved.)
  | LogPathAbsolute FilePath
  -- ^ Interpret the path as an absolute path.

defaultLogSaverFormatter :: LogSaverFormatter
defaultLogSaverFormatter :: LogSaverFormatter
defaultLogSaverFormatter = LogSaverFormatter {
  logSaverPath :: LogPath
logSaverPath = String -> LogPath
LogPathRelativeToRunRoot String
"logs.txt"
  , logSaverLogLevel :: LogLevel
logSaverLogLevel = LogLevel
LevelWarn
  , logSaverFormatter :: LogEntryFormatter
logSaverFormatter = LogEntryFormatter
defaultLogEntryFormatter
  }

instance Formatter LogSaverFormatter where
  formatterName :: LogSaverFormatter -> String
formatterName LogSaverFormatter
_ = String
"log-saver-formatter"
  runFormatter :: forall (m :: * -> *).
(MonadLoggerIO m, MonadUnliftIO m, MonadCatch m) =>
LogSaverFormatter
-> [RunNode BaseContext]
-> Maybe (CommandLineOptions ())
-> BaseContext
-> m ()
runFormatter = LogSaverFormatter
-> [RunNode BaseContext]
-> Maybe (CommandLineOptions ())
-> BaseContext
-> m ()
forall (m :: * -> *).
MonadIO m =>
LogSaverFormatter
-> [RunNode BaseContext]
-> Maybe (CommandLineOptions ())
-> BaseContext
-> m ()
runApp
  finalizeFormatter :: forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadCatch m) =>
LogSaverFormatter -> [RunNode BaseContext] -> BaseContext -> m ()
finalizeFormatter LogSaverFormatter
_ [RunNode BaseContext]
_ BaseContext
_ = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

runApp :: (MonadIO m) => LogSaverFormatter -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m ()
runApp :: forall (m :: * -> *).
MonadIO m =>
LogSaverFormatter
-> [RunNode BaseContext]
-> Maybe (CommandLineOptions ())
-> BaseContext
-> m ()
runApp lsf :: LogSaverFormatter
lsf@(LogSaverFormatter {LogLevel
LogPath
LogEntryFormatter
logSaverPath :: LogSaverFormatter -> LogPath
logSaverLogLevel :: LogSaverFormatter -> LogLevel
logSaverFormatter :: LogSaverFormatter -> LogEntryFormatter
logSaverPath :: LogPath
logSaverLogLevel :: LogLevel
logSaverFormatter :: LogEntryFormatter
..}) [RunNode BaseContext]
rts Maybe (CommandLineOptions ())
_maybeCommandLineOptions BaseContext
bc = do
  let maybePath :: Maybe String
maybePath = case LogPath
logSaverPath of
        LogPathAbsolute String
p -> String -> Maybe String
forall a. a -> Maybe a
Just String
p
        LogPathRelativeToRunRoot String
p -> case BaseContext -> Maybe String
baseContextRunRoot BaseContext
bc of
          Maybe String
Nothing -> Maybe String
forall a. Maybe a
Nothing
          Just String
rr -> String -> Maybe String
forall a. a -> Maybe a
Just (String
rr String -> ShowS
</> String
p)

  Maybe String -> (String -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => Maybe a -> (a -> m b) -> m ()
whenJust Maybe String
maybePath ((String -> m ()) -> m ()) -> (String -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \String
path ->
    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
$ String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
path IOMode
AppendMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h ->
      ReaderT (LogSaverFormatter, Handle) IO ()
-> (LogSaverFormatter, Handle) -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ((RunNode BaseContext -> ReaderT (LogSaverFormatter, Handle) IO ())
-> [RunNode BaseContext]
-> ReaderT (LogSaverFormatter, Handle) IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RunNode BaseContext -> ReaderT (LogSaverFormatter, Handle) IO ()
forall context.
RunNode context -> ReaderT (LogSaverFormatter, Handle) IO ()
run [RunNode BaseContext]
rts) (LogSaverFormatter
lsf, Handle
h)

run :: RunNode context -> ReaderT (LogSaverFormatter, Handle) IO ()
run :: forall context.
RunNode context -> ReaderT (LogSaverFormatter, Handle) IO ()
run node :: RunNode context
node@(RunNodeIt {ExampleT context IO ()
RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon :: RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeExample :: ExampleT context IO ()
runNodeCommon :: forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeExample :: forall s l t context.
RunNodeWithStatus context s l t -> ExampleT context IO ()
..}) = do
  let RunNodeCommonWithStatus {Bool
Int
String
Maybe String
Maybe SrcLoc
Var Bool
Var (Seq LogEntry)
Var Status
Seq Int
runTreeLabel :: String
runTreeId :: Int
runTreeAncestors :: Seq Int
runTreeToggled :: Var Bool
runTreeOpen :: Var Bool
runTreeStatus :: Var Status
runTreeVisible :: Bool
runTreeFolder :: Maybe String
runTreeVisibilityLevel :: Int
runTreeRecordTime :: Bool
runTreeLogs :: Var (Seq LogEntry)
runTreeLoc :: Maybe SrcLoc
runTreeLabel :: forall s l t. RunNodeCommonWithStatus s l t -> String
runTreeId :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeAncestors :: forall s l t. RunNodeCommonWithStatus s l t -> Seq Int
runTreeToggled :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeOpen :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeStatus :: forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeVisible :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeFolder :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe String
runTreeVisibilityLevel :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeRecordTime :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeLogs :: forall s l t. RunNodeCommonWithStatus s l t -> l
runTreeLoc :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe SrcLoc
..} = RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon
  Result
_ <- IO Result -> ReaderT (LogSaverFormatter, Handle) IO Result
forall a. IO a -> ReaderT (LogSaverFormatter, Handle) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Result -> ReaderT (LogSaverFormatter, Handle) IO Result)
-> IO Result -> ReaderT (LogSaverFormatter, Handle) IO Result
forall a b. (a -> b) -> a -> b
$ RunNode context -> IO Result
forall context. RunNode context -> IO Result
waitForTree RunNode context
node
  Var (Seq LogEntry) -> ReaderT (LogSaverFormatter, Handle) IO ()
forall (m :: * -> *) (t :: * -> *).
(MonadIO m, MonadReader (LogSaverFormatter, Handle) m,
 Foldable t) =>
TVar (t LogEntry) -> m ()
printLogs Var (Seq LogEntry)
runTreeLogs
run RunNode context
node = do
  let RunNodeCommonWithStatus {Bool
Int
String
Maybe String
Maybe SrcLoc
Var Bool
Var (Seq LogEntry)
Var Status
Seq Int
runTreeLabel :: forall s l t. RunNodeCommonWithStatus s l t -> String
runTreeId :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeAncestors :: forall s l t. RunNodeCommonWithStatus s l t -> Seq Int
runTreeToggled :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeOpen :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeStatus :: forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeVisible :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeFolder :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe String
runTreeVisibilityLevel :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeRecordTime :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeLogs :: forall s l t. RunNodeCommonWithStatus s l t -> l
runTreeLoc :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe SrcLoc
runTreeLabel :: String
runTreeId :: Int
runTreeAncestors :: Seq Int
runTreeToggled :: Var Bool
runTreeOpen :: Var Bool
runTreeStatus :: Var Status
runTreeVisible :: Bool
runTreeFolder :: Maybe String
runTreeVisibilityLevel :: Int
runTreeRecordTime :: Bool
runTreeLogs :: Var (Seq LogEntry)
runTreeLoc :: Maybe SrcLoc
..} = RunNode context
-> RunNodeCommonWithStatus
     (Var Status) (Var (Seq LogEntry)) (Var Bool)
forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon RunNode context
node
  Result
_ <- IO Result -> ReaderT (LogSaverFormatter, Handle) IO Result
forall a. IO a -> ReaderT (LogSaverFormatter, Handle) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Result -> ReaderT (LogSaverFormatter, Handle) IO Result)
-> IO Result -> ReaderT (LogSaverFormatter, Handle) IO Result
forall a b. (a -> b) -> a -> b
$ RunNode context -> IO Result
forall context. RunNode context -> IO Result
waitForTree RunNode context
node
  Var (Seq LogEntry) -> ReaderT (LogSaverFormatter, Handle) IO ()
forall (m :: * -> *) (t :: * -> *).
(MonadIO m, MonadReader (LogSaverFormatter, Handle) m,
 Foldable t) =>
TVar (t LogEntry) -> m ()
printLogs Var (Seq LogEntry)
runTreeLogs

printLogs :: (MonadIO m, MonadReader (LogSaverFormatter, Handle) m, Foldable t) => TVar (t LogEntry) -> m ()
printLogs :: forall (m :: * -> *) (t :: * -> *).
(MonadIO m, MonadReader (LogSaverFormatter, Handle) m,
 Foldable t) =>
TVar (t LogEntry) -> m ()
printLogs TVar (t LogEntry)
runTreeLogs = do
  (LogSaverFormatter {LogLevel
LogPath
LogEntryFormatter
logSaverPath :: LogSaverFormatter -> LogPath
logSaverLogLevel :: LogSaverFormatter -> LogLevel
logSaverFormatter :: LogSaverFormatter -> LogEntryFormatter
logSaverPath :: LogPath
logSaverLogLevel :: LogLevel
logSaverFormatter :: LogEntryFormatter
..}, Handle
h) <- m (LogSaverFormatter, Handle)
forall r (m :: * -> *). MonadReader r m => m r
ask
  t LogEntry
logEntries <- IO (t LogEntry) -> m (t LogEntry)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (t LogEntry) -> m (t LogEntry))
-> IO (t LogEntry) -> m (t LogEntry)
forall a b. (a -> b) -> a -> b
$ TVar (t LogEntry) -> IO (t LogEntry)
forall a. TVar a -> IO a
readTVarIO TVar (t LogEntry)
runTreeLogs
  t LogEntry -> (LogEntry -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t LogEntry
logEntries ((LogEntry -> m ()) -> m ()) -> (LogEntry -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(LogEntry {LogSource
UTCTime
LogStr
Loc
LogLevel
logEntryTime :: UTCTime
logEntryLoc :: Loc
logEntrySource :: LogSource
logEntryLevel :: LogLevel
logEntryStr :: LogStr
logEntryTime :: LogEntry -> UTCTime
logEntryLoc :: LogEntry -> Loc
logEntrySource :: LogEntry -> LogSource
logEntryLevel :: LogEntry -> LogLevel
logEntryStr :: LogEntry -> LogStr
..}) ->
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LogLevel
logEntryLevel LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= LogLevel
logSaverLogLevel) (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
$ Handle -> ByteString -> IO ()
BS8.hPutStr Handle
h (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$
        LogEntryFormatter
logSaverFormatter UTCTime
logEntryTime Loc
logEntryLoc LogSource
logEntrySource LogLevel
logEntryLevel LogStr
logEntryStr