Logger.hs

module Yam.Logger(
    LogRank(..)
  , Logger
  , LoggerConfig(..)
  , LogFunc
  , defaultLoggerConfig
  , stdoutLoggerConfig
  , toApacheLogger
  , toMonadLogger
  , logger
  , logL
  , logLn
  , traceLn
  , debugLn
  , infoLn
  , warnLn
  , errorLn
  ) where

import           Control.Monad           (when)
import           Control.Monad.IO.Class  (MonadIO, liftIO)
import           Control.Monad.Logger
import           Data.Aeson
import           Data.Monoid             ((<>))
import           Data.String.Conversions (cs)
import           Data.Text               (Text, intercalate, pack)
import           Network.Wai.Logger
import           System.Log.FastLogger

data LogRank
  = TRACE
  | DEBUG
  | INFO
  | WARN
  | ERROR
  deriving (Show, Eq, Ord)

instance FromJSON LogRank where
  parseJSON v = go <$> parseJSON v
    where go :: Text -> LogRank
          go "trace" = TRACE
          go "debug" = DEBUG
          go "info"  = INFO
          go "warn"  = WARN
          go "error" = ERROR
          go  _      = INFO

type Logger = LogStr -> IO ()
type Clock  = IO FormattedTime

data LoggerConfig = LoggerConfig
  { func  :: Logger
  , clock :: Clock
  , names :: [Text]
  , rank  :: LogRank
  }

defaultLoggerConfig :: IO LoggerConfig
defaultLoggerConfig = do
  c <- newTimeCache "%F %X"
  return $ LoggerConfig (\_ -> return ()) c [] INFO

stdoutLoggerConfig :: IO LoggerConfig
stdoutLoggerConfig = do
  lc <- defaultLoggerConfig
  ls <- newStdoutLoggerSet 4096
  return lc { func = pushLogStr ls }

logger :: LoggerConfig -> LogRank -> Logger
logger LoggerConfig{..} r str = when (r >= rank) $ do
  now <- clock
  func $ toLogStr (cs now <> " [" <> pack (show r) <> "] - " <> intercalate "." names <> " - ") <> str

toApacheLogger :: LoggerConfig -> IO ApacheLoggerActions
toApacheLogger lc@LoggerConfig{..} = initLogger FromFallback (LogCallback (logger lc INFO) (return ())) clock

toRank :: LogLevel -> LogRank
toRank LevelDebug = DEBUG
toRank LevelInfo  = INFO
toRank LevelWarn  = WARN
toRank LevelError = ERROR
toRank _          = INFO

type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO ()

toMonadLogger :: LoggerConfig -> LogFunc
toMonadLogger lc@LoggerConfig{..} _ ls level str = logger lc {names=ls:names} (toRank level) str

logL :: forall msg . (ToLogStr msg) => LoggerConfig -> LogRank -> msg -> IO ()
logL lc rank = logger lc rank . toLogStr

logLn :: LoggerConfig -> LogRank -> Text -> IO ()
logLn lc rank msg = logL lc rank $ msg <> "\n"

traceLn :: MonadIO m => LoggerConfig -> Text -> m ()
traceLn lc = liftIO . logLn lc TRACE
{-# INLINE traceLn #-}
debugLn :: MonadIO m => LoggerConfig -> Text -> m ()
debugLn lc = liftIO . logLn lc DEBUG
{-# INLINE debugLn #-}
infoLn  :: MonadIO m => LoggerConfig -> Text -> m ()
infoLn  lc = liftIO . logLn lc INFO
{-# INLINE infoLn #-}
warnLn  :: MonadIO m => LoggerConfig -> Text -> m ()
warnLn  lc = liftIO . logLn lc WARN
{-# INLINE warnLn #-}
errorLn :: MonadIO m => LoggerConfig -> Text -> m ()
errorLn lc = liftIO . logLn lc ERROR
{-# INLINE errorLn #-}