{-# LANGUAGE UndecidableInstances #-}
module Control.Eff.Log.Handler
(
logMsg
, logWithSeverity
, logWithSeverity'
, logEmergency
, logEmergency'
, logAlert
, logAlert'
, logCritical
, logCritical'
, logError
, logError'
, logWarning
, logWarning'
, logNotice
, logNotice'
, logInfo
, logInfo'
, logDebug
, logDebug'
, logCallStack
, logMultiLine
, logMultiLine'
, includeLogMessages
, excludeLogMessages
, setLogPredicate
, modifyLogPredicate
, askLogPredicate
, setLogWriter
, addLogWriter
, modifyLogWriter
, censorLogs
, censorLogsIo
, Logs()
, FilteredLogging
, IoLogging
, LoggingAndIo
, withLogging
, withoutLogging
, runLogs
, runLogsWithoutLogging
, respondToLogMessage
, interceptLogMessages
)
where
import Control.DeepSeq
import Control.Eff as Eff
import Control.Eff.Extend
import Control.Eff.Log.Message
import Control.Eff.Log.Writer
import qualified Control.Exception.Safe as Safe
import Control.Lens
import Control.Monad ( when, (>=>) )
import Control.Monad.Base ( MonadBase() )
import qualified Control.Monad.Catch as Catch
import Control.Monad.Trans.Control ( MonadBaseControl
( restoreM
, liftBaseWith
, StM
)
)
import Data.Default
import Data.Function ( fix )
import Data.Hashable
import Data.Text as T
import GHC.Stack ( HasCallStack
, callStack
, withFrozenCallStack
, prettyCallStack
)
import Data.Foldable ( traverse_ )
import Text.Printf ( printf )
data Logs v where
AskLogFilter
:: Logs LogPredicate
WriteLogMessage
:: !LogMessage -> Logs ()
instance forall e a k. Handle Logs e a (LogPredicate -> k) where
handle h q AskLogFilter p = h (q ^$ p ) p
handle h q (WriteLogMessage _) p = h (q ^$ ()) p
instance forall m e. (MonadBase m IO, MonadBaseControl IO (Eff e), LiftedBase m e, Lifted IO e, IoLogging (Logs ': e))
=> MonadBaseControl m (Eff (Logs ': e)) where
type StM (Eff (Logs ': e)) a = StM (Eff e) a
liftBaseWith f = do
lf <- askLogPredicate
raise (liftBaseWith (\runInBase -> f (runInBase . runLogs lf)))
restoreM = raise . restoreM
instance (LiftedBase m e, Catch.MonadThrow (Eff e))
=> Catch.MonadThrow (Eff (Logs ': e)) where
throwM exception = raise (Catch.throwM exception)
instance (Applicative m, MonadBaseControl IO (Eff e), LiftedBase m e, Catch.MonadCatch (Eff e), IoLogging (Logs ': e), Lifted IO e)
=> Catch.MonadCatch (Eff (Logs ': e)) where
catch effect handler = do
lf <- askLogPredicate
let lower = runLogs lf
nestedEffects = lower effect
nestedHandler exception = lower (handler exception)
raise (Catch.catch nestedEffects nestedHandler)
instance (Applicative m, MonadBaseControl IO (Eff e), LiftedBase m e, Catch.MonadMask (Eff e), IoLogging (Logs ': e), Lifted IO e)
=> Catch.MonadMask (Eff (Logs ': e)) where
mask maskedEffect = do
lf <- askLogPredicate
let
lower :: Eff (Logs ': e) a -> Eff e a
lower = runLogs lf
raise
(Catch.mask
(\nestedUnmask -> lower
(maskedEffect
( raise . nestedUnmask . lower )
)
)
)
uninterruptibleMask maskedEffect = do
lf <- askLogPredicate
let
lower :: Eff (Logs ': e) a -> Eff e a
lower = runLogs lf
raise
(Catch.uninterruptibleMask
(\nestedUnmask -> lower
(maskedEffect
( raise . nestedUnmask . lower )
)
)
)
generalBracket acquire release useIt = do
lf <- askLogPredicate
let
lower :: Eff (Logs ': e) a -> Eff e a
lower = runLogs lf
raise
(Catch.generalBracket
(lower acquire)
(((.).(.)) lower release)
(lower . useIt)
)
type IoLogging e = (FilteredLogging e, Lifted IO e)
type FilteredLogging e = (Member Logs e, Member LogWriterReader e)
type LoggingAndIo = '[Logs, LogWriterReader, Lift IO]
withLogging :: Lifted IO e => LogWriter -> Eff (Logs ': LogWriterReader ': e) a -> Eff e a
withLogging lw = runLogWriterReader lw . runLogs allLogMessages
withoutLogging :: Eff (Logs ': LogWriterReader ': e) a -> Eff e a
withoutLogging = runLogWriterReader mempty . runLogsWithoutLogging noLogMessages
runLogs
:: forall e b .
( Member LogWriterReader (Logs ': e)
, Lifted IO e
)
=> LogPredicate
-> Eff (Logs ': e) b
-> Eff e b
runLogs p m =
fix (handle_relay (\a _ -> return a)) (sendLogMessageToLogWriter m) p
runLogsWithoutLogging
:: forall e b .
( Member LogWriterReader (Logs ': e)
)
=> LogPredicate
-> Eff (Logs ': e) b
-> Eff e b
runLogsWithoutLogging p m =
fix (handle_relay (\a _ -> return a)) m p
logMsg :: forall e . (HasCallStack, Member Logs e) => LogMessage -> Eff e ()
logMsg = withFrozenCallStack $ \msgIn -> do
lf <- askLogPredicate
when (lf msgIn) $
msgIn `deepseq` send @Logs (WriteLogMessage msgIn)
logWithSeverity
:: forall e .
( HasCallStack
, Member Logs e
)
=> Severity
-> Text
-> Eff e ()
logWithSeverity = withFrozenCallStack $ \s ->
logMsg
. setCallStack callStack
. set lmSeverity s
. flip (set lmMessage) def
logWithSeverity'
:: forall e .
( HasCallStack
, Member Logs e
)
=> Severity
-> String
-> Eff e ()
logWithSeverity' = withFrozenCallStack
(\s m ->
logMsg
$ setCallStack callStack
$ set lmSeverity s
$ ( def & lmMessage .~ T.pack m))
logEmergency
:: forall e .
( HasCallStack
, Member Logs e
)
=> Text
-> Eff e ()
logEmergency = withFrozenCallStack (logWithSeverity emergencySeverity)
logAlert
:: forall e .
( HasCallStack
, Member Logs e
)
=> Text
-> Eff e ()
logAlert = withFrozenCallStack (logWithSeverity alertSeverity)
logCritical
:: forall e .
( HasCallStack
, Member Logs e
)
=> Text
-> Eff e ()
logCritical = withFrozenCallStack (logWithSeverity criticalSeverity)
logError
:: forall e .
( HasCallStack
, Member Logs e
)
=> Text
-> Eff e ()
logError = withFrozenCallStack (logWithSeverity errorSeverity)
logWarning
:: forall e .
( HasCallStack
, Member Logs e
)
=> Text
-> Eff e ()
logWarning = withFrozenCallStack (logWithSeverity warningSeverity)
logNotice
:: forall e .
( HasCallStack
, Member Logs e
)
=> Text
-> Eff e ()
logNotice = withFrozenCallStack (logWithSeverity noticeSeverity)
logInfo
:: forall e .
( HasCallStack
, Member Logs e
)
=> Text
-> Eff e ()
logInfo = withFrozenCallStack (logWithSeverity informationalSeverity)
logDebug
:: forall e .
( HasCallStack
, Member Logs e
)
=> Text
-> Eff e ()
logDebug = withFrozenCallStack (logWithSeverity debugSeverity)
logEmergency'
:: forall e .
( HasCallStack
, Member Logs e
)
=> String
-> Eff e ()
logEmergency' = withFrozenCallStack (logWithSeverity' emergencySeverity)
logAlert'
:: forall e .
( HasCallStack
, Member Logs e
)
=> String
-> Eff e ()
logAlert' = withFrozenCallStack (logWithSeverity' alertSeverity)
logCritical'
:: forall e .
( HasCallStack
, Member Logs e
)
=> String
-> Eff e ()
logCritical' = withFrozenCallStack (logWithSeverity' criticalSeverity)
logError'
:: forall e .
( HasCallStack
, Member Logs e
)
=> String
-> Eff e ()
logError' = withFrozenCallStack (logWithSeverity' errorSeverity)
logWarning'
:: forall e .
( HasCallStack
, Member Logs e
)
=> String
-> Eff e ()
logWarning' = withFrozenCallStack (logWithSeverity' warningSeverity)
logNotice'
:: forall e .
( HasCallStack
, Member Logs e
)
=> String
-> Eff e ()
logNotice' = withFrozenCallStack (logWithSeverity' noticeSeverity)
logInfo'
:: forall e .
( HasCallStack
, Member Logs e
)
=> String
-> Eff e ()
logInfo' = withFrozenCallStack (logWithSeverity' informationalSeverity)
logDebug'
:: forall e .
( HasCallStack
, Member Logs e
)
=> String
-> Eff e ()
logDebug' = withFrozenCallStack (logWithSeverity' debugSeverity)
logCallStack :: forall e . (HasCallStack, Member Logs e) => Severity -> Eff e ()
logCallStack =
withFrozenCallStack $ \s ->
let stackTraceLines = T.lines (pack (prettyCallStack callStack))
in logMultiLine s stackTraceLines
logMultiLine
:: forall e
. ( HasCallStack
, Member Logs e
)
=> Severity
-> [Text]
-> Eff e ()
logMultiLine =
withFrozenCallStack $ \s messageLines -> do
let msgHash = T.pack $ printf "multi-line message %06X" $ hash messageLines `mod` 0x1000000
messageLinesWithLineNum =
let messageLineCount = Prelude.length messageLines
messageLineCountString = T.pack (show messageLineCount)
messageLineCountStringLen = T.length messageLineCountString
printLineNum i =
let i' = T.pack (show i)
padding = messageLineCountStringLen - T.length i'
in msgHash <> " line " <> T.replicate padding " " <> i' <> " of " <> messageLineCountString <> ": "
in Prelude.zipWith (<>) (printLineNum <$> [1 :: Int ..]) messageLines
traverse_ (logWithSeverity s) messageLinesWithLineNum
logMultiLine'
:: forall e
. ( HasCallStack
, Member Logs e
)
=> Severity
-> [String]
-> Eff e ()
logMultiLine' s = logMultiLine s . fmap pack
askLogPredicate :: forall e . (Member Logs e) => Eff e LogPredicate
askLogPredicate = send @Logs AskLogFilter
setLogPredicate
:: forall r b
. (Member Logs r, HasCallStack)
=> LogPredicate
-> Eff r b
-> Eff r b
setLogPredicate = modifyLogPredicate . const
modifyLogPredicate
:: forall e b
. (Member Logs e, HasCallStack)
=> (LogPredicate -> LogPredicate)
-> Eff e b
-> Eff e b
modifyLogPredicate lpIn e = askLogPredicate >>= fix step e . lpIn
where
ret x _ = return x
step :: (Eff e b -> LogPredicate -> Eff e b) -> Eff e b -> LogPredicate -> Eff e b
step k (E q (prj -> Just (WriteLogMessage !l))) lp = do
logMsg l
respond_relay @Logs ret k (q ^$ ()) lp
step k m lp = respond_relay @Logs ret k m lp
includeLogMessages
:: forall e a . (Member Logs e)
=> LogPredicate -> Eff e a -> Eff e a
includeLogMessages p = modifyLogPredicate (\p' m -> p' m || p m)
excludeLogMessages
:: forall e a . (Member Logs e)
=> LogPredicate -> Eff e a -> Eff e a
excludeLogMessages p = modifyLogPredicate (\p' m -> not (p m) && p' m)
respondToLogMessage
:: forall r b
. (Member Logs r)
=> (LogMessage -> Eff r ())
-> Eff r b
-> Eff r b
respondToLogMessage f e = askLogPredicate >>= fix step e
where
step :: (Eff r b -> LogPredicate -> Eff r b) -> Eff r b -> LogPredicate -> Eff r b
step k (E q (prj -> Just (WriteLogMessage !l))) lp = do
f l
respond_relay @Logs ret k (q ^$ ()) lp
step k m lp = respond_relay @Logs ret k m lp
ret x _lf = return x
interceptLogMessages
:: forall r b
. (Member Logs r)
=> (LogMessage -> Eff r LogMessage)
-> Eff r b
-> Eff r b
interceptLogMessages f = respondToLogMessage (f >=> logMsg)
sendLogMessageToLogWriter :: IoLogging e => Eff e b -> Eff e b
sendLogMessageToLogWriter = respondToLogMessage liftWriteLogMessage
modifyLogWriter :: IoLogging e => (LogWriter -> LogWriter) -> Eff e a -> Eff e a
modifyLogWriter f = localLogWriterReader f . sendLogMessageToLogWriter
setLogWriter :: IoLogging e => LogWriter -> Eff e a -> Eff e a
setLogWriter = modifyLogWriter . const
censorLogs :: IoLogging e => (LogMessage -> LogMessage) -> Eff e a -> Eff e a
censorLogs = modifyLogWriter . mappingLogWriter
censorLogsIo :: IoLogging e => (LogMessage -> IO LogMessage) -> Eff e a -> Eff e a
censorLogsIo = modifyLogWriter . mappingLogWriterIO
addLogWriter :: IoLogging e => LogWriter -> Eff e a -> Eff e a
addLogWriter lw2 = modifyLogWriter (\lw1 -> MkLogWriter (\m -> runLogWriter lw1 m >> runLogWriter lw2 m))