{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
module Pinboard.Logging
( withStdoutLogging
, withStderrLogging
, withNoLogging
, logNST
, logOnException
, runLogOnException
, nullLogger
, runNullLoggingT
, errorLevelFilter
, infoLevelFilter
, debugLevelFilter
) where
import Control.Monad.IO.Class
import Control.Monad.Logger
import UnliftIO
import Data.Time
import Data.Text as T
import Pinboard.Types
import Data.Monoid
withStdoutLogging :: PinboardConfig -> PinboardConfig
withStdoutLogging p =
p
{ execLoggingT = runStdoutLoggingT
}
withStderrLogging :: PinboardConfig -> PinboardConfig
withStderrLogging p =
p
{ execLoggingT = runStderrLoggingT
}
withNoLogging :: PinboardConfig -> PinboardConfig
withNoLogging p =
p
{ execLoggingT = runNullLoggingT
}
logOnException
:: (MonadLogger m, MonadUnliftIO m)
=> T.Text -> m a -> m a
logOnException src =
handle
(\(e :: SomeException) -> do
logNST LevelError src (toText e)
throwIO e)
runLogOnException
:: MonadUnliftIO m
=> T.Text -> PinboardConfig -> LoggingT m a -> m a
runLogOnException logSrc config = runConfigLoggingT config . logOnException logSrc
logNST
:: (MonadIO m, MonadLogger m)
=> LogLevel -> Text -> Text -> m ()
logNST l s t =
liftIO (toText <$> getCurrentTime) >>=
\time -> logOtherNS ("[pinboard/" <> s <> "]") l ("@(" <> time <> ") " <> t)
nullLogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
nullLogger _ _ _ _ = return ()
runNullLoggingT :: LoggingT m a -> m a
runNullLoggingT = (`runLoggingT` nullLogger)
errorLevelFilter :: LogSource -> LogLevel -> Bool
errorLevelFilter = minLevelFilter LevelError
infoLevelFilter :: LogSource -> LogLevel -> Bool
infoLevelFilter = minLevelFilter LevelInfo
debugLevelFilter :: LogSource -> LogLevel -> Bool
debugLevelFilter = minLevelFilter LevelDebug
minLevelFilter :: LogLevel -> LogSource -> LogLevel -> Bool
minLevelFilter l _ l' = l' >= l
toText
:: Show a
=> a -> Text
toText = T.pack . show