-- | 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 = forall (m :: * -> *).
(MonadIO m, MonadLogger 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
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

  forall (m :: * -> *) a b. Monad m => Maybe a -> (a -> m b) -> m ()
whenJust Maybe String
maybePath forall a b. (a -> b) -> a -> b
$ \String
path ->
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
path IOMode
AppendMode forall a b. (a -> b) -> a -> b
$ \Handle
h ->
      forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ 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)
runNodeExample :: forall s l t context.
RunNodeWithStatus context s l t -> ExampleT context IO ()
runNodeCommon :: forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeExample :: ExampleT context IO ()
runNodeCommon :: RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
..}) = do
  let RunNodeCommonWithStatus {Bool
Int
String
Maybe String
Maybe SrcLoc
Var Bool
Var (Seq LogEntry)
Var Status
Seq Int
runTreeLoc :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe SrcLoc
runTreeLogs :: forall s l t. RunNodeCommonWithStatus s l t -> l
runTreeRecordTime :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeVisibilityLevel :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeFolder :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe String
runTreeVisible :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeStatus :: forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeOpen :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeToggled :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeAncestors :: forall s l t. RunNodeCommonWithStatus s l t -> Seq Int
runTreeId :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeLabel :: forall s l t. RunNodeCommonWithStatus s l t -> String
runTreeLoc :: Maybe SrcLoc
runTreeLogs :: Var (Seq LogEntry)
runTreeRecordTime :: Bool
runTreeVisibilityLevel :: Int
runTreeFolder :: Maybe String
runTreeVisible :: Bool
runTreeStatus :: Var Status
runTreeOpen :: Var Bool
runTreeToggled :: Var Bool
runTreeAncestors :: Seq Int
runTreeId :: Int
runTreeLabel :: String
..} = RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon
  Result
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall context. RunNode context -> IO Result
waitForTree RunNode context
node
  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
runTreeLoc :: Maybe SrcLoc
runTreeLogs :: Var (Seq LogEntry)
runTreeRecordTime :: Bool
runTreeVisibilityLevel :: Int
runTreeFolder :: Maybe String
runTreeVisible :: Bool
runTreeStatus :: Var Status
runTreeOpen :: Var Bool
runTreeToggled :: Var Bool
runTreeAncestors :: Seq Int
runTreeId :: Int
runTreeLabel :: String
runTreeLoc :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe SrcLoc
runTreeLogs :: forall s l t. RunNodeCommonWithStatus s l t -> l
runTreeRecordTime :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeVisibilityLevel :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeFolder :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe String
runTreeVisible :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeStatus :: forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeOpen :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeToggled :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeAncestors :: forall s l t. RunNodeCommonWithStatus s l t -> Seq Int
runTreeId :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeLabel :: forall s l t. RunNodeCommonWithStatus s l t -> String
..} = forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon RunNode context
node
  Result
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall context. RunNode context -> IO Result
waitForTree RunNode context
node
  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
logSaverFormatter :: LogEntryFormatter
logSaverLogLevel :: LogLevel
logSaverPath :: LogPath
logSaverFormatter :: LogSaverFormatter -> LogEntryFormatter
logSaverLogLevel :: LogSaverFormatter -> LogLevel
logSaverPath :: LogSaverFormatter -> LogPath
..}, Handle
h) <- forall r (m :: * -> *). MonadReader r m => m r
ask
  t LogEntry
logEntries <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> IO a
readTVarIO TVar (t LogEntry)
runTreeLogs
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t LogEntry
logEntries forall a b. (a -> b) -> a -> b
$ \(LogEntry {UTCTime
LogSource
LogStr
LogLevel
Loc
logEntryStr :: LogEntry -> LogStr
logEntryLevel :: LogEntry -> LogLevel
logEntrySource :: LogEntry -> LogSource
logEntryLoc :: LogEntry -> Loc
logEntryTime :: LogEntry -> UTCTime
logEntryStr :: LogStr
logEntryLevel :: LogLevel
logEntrySource :: LogSource
logEntryLoc :: Loc
logEntryTime :: UTCTime
..}) ->
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LogLevel
logEntryLevel forall a. Ord a => a -> a -> Bool
>= LogLevel
logSaverLogLevel) forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
BS8.hPutStr Handle
h forall a b. (a -> b) -> a -> b
$
        LogEntryFormatter
logSaverFormatter UTCTime
logEntryTime Loc
logEntryLoc LogSource
logEntrySource LogLevel
logEntryLevel LogStr
logEntryStr