{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}

-- |
-- Module      : Pinboard.Logging
-- Copyright   : (c) Jon Schoning, 2015
-- Maintainer  : jonschoning@gmail.com
-- Stability   : experimental
-- Portability : POSIX
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 :: PinboardConfig -> PinboardConfig
withStdoutLogging PinboardConfig
p =
  PinboardConfig
p
  { execLoggingT :: ExecLoggingT
execLoggingT = ExecLoggingT
forall (m :: * -> *) a. MonadIO m => LoggingT m a -> m a
runStdoutLoggingT
  }

withStderrLogging :: PinboardConfig -> PinboardConfig
withStderrLogging :: PinboardConfig -> PinboardConfig
withStderrLogging PinboardConfig
p =
  PinboardConfig
p
  { execLoggingT :: ExecLoggingT
execLoggingT = ExecLoggingT
forall (m :: * -> *) a. MonadIO m => LoggingT m a -> m a
runStderrLoggingT
  }

withNoLogging :: PinboardConfig -> PinboardConfig
withNoLogging :: PinboardConfig -> PinboardConfig
withNoLogging PinboardConfig
p =
  PinboardConfig
p
  { execLoggingT :: ExecLoggingT
execLoggingT = ExecLoggingT
forall (m :: * -> *) a. LoggingT m a -> m a
runNullLoggingT
  }

------------------------------------------------------------------------------

logOnException
  :: (MonadLogger m, MonadUnliftIO m)
  => T.Text -> m a -> m a
logOnException :: Text -> m a -> m a
logOnException Text
src =
  (SomeException -> m a) -> m a -> m a
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
(e -> m a) -> m a -> m a
handle
    (\(SomeException
e :: SomeException) -> do
       LogLevel -> Text -> Text -> m ()
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> Text -> Text -> m ()
logNST LogLevel
LevelError Text
src (SomeException -> Text
forall a. Show a => a -> Text
toText SomeException
e)
       SomeException -> m a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SomeException
e)

runLogOnException
  :: MonadUnliftIO m
  => T.Text -> PinboardConfig -> LoggingT m a -> m a
runLogOnException :: Text -> PinboardConfig -> LoggingT m a -> m a
runLogOnException Text
logSrc PinboardConfig
config = PinboardConfig -> ExecLoggingT
runConfigLoggingT PinboardConfig
config (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
. Text -> LoggingT m a -> LoggingT m a
forall (m :: * -> *) a.
(MonadLogger m, MonadUnliftIO m) =>
Text -> m a -> m a
logOnException Text
logSrc

------------------------------------------------------------------------------

logNST
  :: (MonadIO m, MonadLogger m)
  => LogLevel -> Text -> Text -> m ()
logNST :: LogLevel -> Text -> Text -> m ()
logNST LogLevel
l Text
s Text
t =
  IO Text -> m Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (UTCTime -> Text
forall a. Show a => a -> Text
toText (UTCTime -> Text) -> IO UTCTime -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime) m Text -> (Text -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  \Text
time -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *).
MonadLogger m =>
Text -> LogLevel -> Text -> m ()
logOtherNS (Text
"[pinboard/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]") LogLevel
l (Text
"@(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
time Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t)

------------------------------------------------------------------------------

nullLogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
nullLogger :: Loc -> Text -> LogLevel -> LogStr -> IO ()
nullLogger Loc
_ Text
_ LogLevel
_ LogStr
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

runNullLoggingT :: LoggingT m a -> m a
runNullLoggingT :: LoggingT m a -> m a
runNullLoggingT = (LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
forall (m :: * -> *) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
`runLoggingT` Loc -> Text -> LogLevel -> LogStr -> IO ()
nullLogger)

------------------------------------------------------------------------------

errorLevelFilter :: LogSource -> LogLevel -> Bool
errorLevelFilter :: Text -> LogLevel -> Bool
errorLevelFilter = LogLevel -> Text -> LogLevel -> Bool
minLevelFilter LogLevel
LevelError

infoLevelFilter :: LogSource -> LogLevel -> Bool
infoLevelFilter :: Text -> LogLevel -> Bool
infoLevelFilter = LogLevel -> Text -> LogLevel -> Bool
minLevelFilter LogLevel
LevelInfo

debugLevelFilter :: LogSource -> LogLevel -> Bool
debugLevelFilter :: Text -> LogLevel -> Bool
debugLevelFilter = LogLevel -> Text -> LogLevel -> Bool
minLevelFilter LogLevel
LevelDebug

minLevelFilter :: LogLevel -> LogSource -> LogLevel -> Bool
minLevelFilter :: LogLevel -> Text -> LogLevel -> Bool
minLevelFilter LogLevel
l Text
_ LogLevel
l' = LogLevel
l' LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= LogLevel
l

toText
  :: Show a
  => a -> Text
toText :: a -> Text
toText = String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show