{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module GenAI.Client.LoggingMonadLogger where
import Control.Exception.Safe qualified as E
import Control.Monad.IO.Class qualified as P
import Data.Text qualified as T
import Data.Time qualified as TI
import Data.Text (Text)
import Control.Monad.Logger qualified as LG
type LogExecWithContext =
forall m a.
(P.MonadIO m) =>
LogContext ->
LogExec m a
type LogExec m a = LG.LoggingT m a -> m a
type LogContext = LG.LogSource -> LG.LogLevel -> Bool
type LogLevel = LG.LogLevel
initLogContext :: IO LogContext
initLogContext :: IO LogContext
initLogContext = LogContext -> IO LogContext
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LogContext
infoLevelFilter
runDefaultLogExecWithContext :: LogExecWithContext
runDefaultLogExecWithContext :: LogExecWithContext
runDefaultLogExecWithContext = LogContext -> LogExec m a
LogExecWithContext
runNullLogExec
stdoutLoggingExec :: LogExecWithContext
stdoutLoggingExec :: LogExecWithContext
stdoutLoggingExec LogContext
cxt = LoggingT m a -> m a
forall (m :: * -> *) a. MonadIO m => LoggingT m a -> m a
LG.runStdoutLoggingT (LoggingT m a -> m a)
-> (LoggingT m a -> LoggingT m a) -> LoggingT m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogContext -> LoggingT m a -> LoggingT m a
forall (m :: * -> *) a. LogContext -> LoggingT m a -> LoggingT m a
LG.filterLogger LogContext
cxt
stdoutLoggingContext :: LogContext -> IO LogContext
stdoutLoggingContext :: LogContext -> IO LogContext
stdoutLoggingContext = LogContext -> IO LogContext
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
stderrLoggingExec :: LogExecWithContext
stderrLoggingExec :: LogExecWithContext
stderrLoggingExec LogContext
cxt = LoggingT m a -> m a
forall (m :: * -> *) a. MonadIO m => LoggingT m a -> m a
LG.runStderrLoggingT (LoggingT m a -> m a)
-> (LoggingT m a -> LoggingT m a) -> LoggingT m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogContext -> LoggingT m a -> LoggingT m a
forall (m :: * -> *) a. LogContext -> LoggingT m a -> LoggingT m a
LG.filterLogger LogContext
cxt
stderrLoggingContext :: LogContext -> IO LogContext
stderrLoggingContext :: LogContext -> IO LogContext
stderrLoggingContext = LogContext -> IO LogContext
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
runNullLogExec :: LogExecWithContext
runNullLogExec :: LogExecWithContext
runNullLogExec = LogExec m a -> LogContext -> LogExec m a
forall a b. a -> b -> a
const (LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
forall (m :: * -> *) a.
LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
`LG.runLoggingT` Loc -> LogSource -> LogLevel -> LogStr -> IO ()
nullLogger)
nullLogger :: LG.Loc -> LG.LogSource -> LG.LogLevel -> LG.LogStr -> IO ()
nullLogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
nullLogger Loc
_ LogSource
_ LogLevel
_ LogStr
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
_log :: (P.MonadIO m, LG.MonadLogger m) => Text -> LG.LogLevel -> Text -> m ()
_log :: forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogSource -> LogLevel -> LogSource -> m ()
_log LogSource
src LogLevel
level LogSource
msg = do
LogSource
now <- IO LogSource -> m LogSource
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
P.liftIO (UTCTime -> LogSource
formatTimeLog (UTCTime -> LogSource) -> IO UTCTime -> IO LogSource
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
TI.getCurrentTime)
LogSource -> LogLevel -> LogSource -> m ()
forall (m :: * -> *).
MonadLogger m =>
LogSource -> LogLevel -> LogSource -> m ()
LG.logOtherNS (LogSource
"GenAI.Client." LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> LogSource
src) LogLevel
level (LogSource
"[" LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> LogSource
now LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> LogSource
"] " LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> LogSource
msg)
where
formatTimeLog :: UTCTime -> LogSource
formatTimeLog =
String -> LogSource
T.pack (String -> LogSource)
-> (UTCTime -> String) -> UTCTime -> LogSource
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
TI.formatTime TimeLocale
TI.defaultTimeLocale String
"%Y-%m-%dT%H:%M:%S%Z"
logExceptions ::
(LG.MonadLogger m, E.MonadCatch m, P.MonadIO m) =>
Text ->
m a ->
m a
logExceptions :: forall (m :: * -> *) a.
(MonadLogger m, MonadCatch m, MonadIO m) =>
LogSource -> m a -> m a
logExceptions LogSource
src =
(SomeException -> m a) -> m a -> m a
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
E.handle
( \(SomeException
e :: E.SomeException) -> do
LogSource -> LogLevel -> LogSource -> m ()
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogSource -> LogLevel -> LogSource -> m ()
_log LogSource
src LogLevel
LG.LevelError ((String -> LogSource
T.pack (String -> LogSource)
-> (SomeException -> String) -> SomeException -> LogSource
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show) SomeException
e)
SomeException -> m a
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
E.throw SomeException
e
)
levelInfo :: LogLevel
levelInfo :: LogLevel
levelInfo = LogLevel
LG.LevelInfo
levelError :: LogLevel
levelError :: LogLevel
levelError = LogLevel
LG.LevelError
levelDebug :: LogLevel
levelDebug :: LogLevel
levelDebug = LogLevel
LG.LevelDebug
minLevelFilter :: LG.LogLevel -> LG.LogSource -> LG.LogLevel -> Bool
minLevelFilter :: LogLevel -> LogContext
minLevelFilter LogLevel
l LogSource
_ LogLevel
l' = LogLevel
l' LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= LogLevel
l
infoLevelFilter :: LG.LogSource -> LG.LogLevel -> Bool
infoLevelFilter :: LogContext
infoLevelFilter = LogLevel -> LogContext
minLevelFilter LogLevel
LG.LevelInfo