-- This Source Code Form is subject to the terms of the Mozilla Public
-- License, v. 2.0. If a copy of the MPL was not distributed with this
-- file, You can obtain one at http://mozilla.org/MPL/2.0/.

{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Small layer on top of @fast-logger@ which adds log-levels and
-- timestamp support and not much more.
module System.Logger
    ( -- * Settings
      Settings
    , defSettings
    , logLevel
    , setLogLevel
    , logLevelOf
    , setLogLevelOf
    , output
    , setOutput
    , format
    , setFormat
    , delimiter
    , readEnvironment
    , setDelimiter
    , setNetStrings
    , setReadEnvironment
    , setRendererNetstr
    , setRendererDefault
    , bufSize
    , setBufSize
    , name
    , setName
    , setRenderer
    , renderer

      -- * Type definitions
    , Logger
    , Level      (..)
    , Output     (..)
    , DateFormat (..)
    , Renderer
    , iso8601UTC

      -- * Core API
    , new
    , create
    , level
    , flush
    , close
    , clone
    , settings

      -- ** Logging
    , log
    , trace
    , debug
    , info
    , warn
    , err
    , fatal

    , module M
    ) where

import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class
import Data.Bool (bool)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.UnixTime
import System.Environment (lookupEnv)
import System.Logger.Message as M
import System.Logger.Settings
import Prelude hiding (log)

import qualified Data.Map.Strict       as Map
import qualified System.Log.FastLogger as FL

data Logger = Logger
    { Logger -> LoggerSet
logger    :: FL.LoggerSet
    , Logger -> Settings
settings  :: Settings
    , Logger -> IO (Msg -> Msg)
getDate   :: IO (Msg -> Msg)
    }

-- | Create a new 'Logger' with the given 'Settings'.
-- Please note that the 'logLevel' can be dynamically adjusted by setting
-- the environment variable @LOG_LEVEL@ accordingly. Likewise the buffer
-- size can be dynamically set via @LOG_BUFFER@ and netstrings encoding
-- can be enabled with @LOG_NETSTR=True@.  **NOTE: If you do this any custom
-- renderers you may have passed with the settings will be overwritten!**
--
-- Since version 0.11 one can also use @LOG_LEVEL_MAP@ to specify log
-- levels per (named) logger. The syntax uses standard haskell syntax for
-- association lists of type @[(Text, Level)]@. For example:
--
-- If you want to ignore environment variables, call @setReadEnvironment False@ on the
-- 'Settings'.
--
-- @
-- $ LOG_LEVEL=Info LOG_LEVEL_MAP='[("foo", Warn), ("bar", Trace)]' cabal repl
-- > g1 <- new defSettings
-- > let g2 = clone (Just "foo") g1
-- > let g3 = clone (Just "bar") g1
-- > let g4 = clone (Just "xxx") g1
-- > logLevel (settings g1)
-- Info
-- > logLevel (settings g2)
-- Warn
-- > logLevel (settings g3)
-- Trace
-- > logLevel (settings g4)
-- Info
-- @
new :: MonadIO m => Settings -> m Logger
new :: forall (m :: * -> *). MonadIO m => Settings -> m Logger
new Settings
s = IO Logger -> m Logger
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Logger -> m Logger) -> IO Logger -> m Logger
forall a b. (a -> b) -> a -> b
$ do
    !Maybe BufSize
n <- (String -> BufSize) -> Maybe String -> Maybe BufSize
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String -> BufSize
forall a. Read a => String -> String -> a
readNote String
"Invalid LOG_BUFFER") (Maybe String -> Maybe BufSize)
-> IO (Maybe String) -> IO (Maybe BufSize)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
maybeLookupEnv String
"LOG_BUFFER"
    !Maybe Level
l <- (String -> Level) -> Maybe String -> Maybe Level
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String -> Level
forall a. Read a => String -> String -> a
readNote String
"Invalid LOG_LEVEL")  (Maybe String -> Maybe Level)
-> IO (Maybe String) -> IO (Maybe Level)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
maybeLookupEnv String
"LOG_LEVEL"
    !Maybe Bool
e <- (String -> Bool) -> Maybe String -> Maybe Bool
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String -> Bool
forall a. Read a => String -> String -> a
readNote String
"Invalid LOG_NETSTR") (Maybe String -> Maybe Bool)
-> IO (Maybe String) -> IO (Maybe Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
maybeLookupEnv String
"LOG_NETSTR"
    !String
m <- String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"[]" (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
maybeLookupEnv String
"LOG_LEVEL_MAP"
    let !k :: Map Text Level
k  = Settings -> Map Text Level
logLevelMap Settings
s Map Text Level -> String -> Map Text Level
forall {k} {a}.
(Ord k, Read k, Read a) =>
Map k a -> String -> Map k a
`mergeWith` String
m
    let !s' :: Settings
s' = Level -> Settings -> Settings
setLogLevel (Level -> Maybe Level -> Level
forall a. a -> Maybe a -> a
fromMaybe (Settings -> Level
logLevel Settings
s) Maybe Level
l)
            (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Settings -> Settings)
-> (Bool -> Settings -> Settings)
-> Maybe Bool
-> Settings
-> Settings
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Settings -> Settings
forall a. a -> a
id ((Settings -> Settings)
-> (Settings -> Settings) -> Bool -> Settings -> Settings
forall a. a -> a -> Bool -> a
bool Settings -> Settings
forall a. a -> a
id Settings -> Settings
setRendererNetstr) Maybe Bool
e
            (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text Level -> Settings -> Settings
setLogLevelMap Map Text Level
k
            (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$ Settings
s
    LoggerSet
g <- Output -> BufSize -> IO LoggerSet
fn (Settings -> Output
output Settings
s) (BufSize -> Maybe BufSize -> BufSize
forall a. a -> Maybe a -> a
fromMaybe (Settings -> BufSize
bufSize Settings
s) Maybe BufSize
n)
    LoggerSet -> Settings -> IO (Msg -> Msg) -> Logger
Logger LoggerSet
g Settings
s' (IO (Msg -> Msg) -> Logger) -> IO (IO (Msg -> Msg)) -> IO Logger
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe DateFormat -> IO (IO (Msg -> Msg))
forall {m :: * -> *}.
Monad m =>
Maybe DateFormat -> m (IO (Msg -> Msg))
mkGetDate (Settings -> Maybe DateFormat
format Settings
s)
  where
    maybeLookupEnv :: String -> IO (Maybe String)
    maybeLookupEnv :: String -> IO (Maybe String)
maybeLookupEnv String
key =
        if Settings -> Bool
readEnvironment Settings
s
            then String -> IO (Maybe String)
lookupEnv String
key
            else Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing

    fn :: Output -> BufSize -> IO LoggerSet
fn Output
StdOut   = BufSize -> IO LoggerSet
FL.newStdoutLoggerSet
    fn Output
StdErr   = BufSize -> IO LoggerSet
FL.newStderrLoggerSet
    fn (Path String
p) = (BufSize -> String -> IO LoggerSet)
-> String -> BufSize -> IO LoggerSet
forall a b c. (a -> b -> c) -> b -> a -> c
flip BufSize -> String -> IO LoggerSet
FL.newFileLoggerSet String
p

    mkGetDate :: Maybe DateFormat -> m (IO (Msg -> Msg))
mkGetDate Maybe DateFormat
Nothing  = IO (Msg -> Msg) -> m (IO (Msg -> Msg))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Msg -> Msg) -> IO (Msg -> Msg)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Msg -> Msg
forall a. a -> a
id)
    mkGetDate (Just DateFormat
f) = IO (Msg -> Msg) -> m (IO (Msg -> Msg))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
msg (ByteString -> Msg -> Msg)
-> (UnixTime -> ByteString) -> UnixTime -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DateFormat -> UnixTime -> ByteString
display DateFormat
f) (UnixTime -> Msg -> Msg) -> IO UnixTime -> IO (Msg -> Msg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UnixTime
getUnixTime)

    mergeWith :: Map k a -> String -> Map k a
mergeWith Map k a
m String
e = [(k, a)] -> Map k a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (String -> String -> [(k, a)]
forall a. Read a => String -> String -> a
readNote String
"Invalid LOG_LEVEL_MAP" String
e) Map k a -> Map k a -> Map k a
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map k a
m

-- | Invokes 'new' with default settings and the given output as log sink.
create :: MonadIO m => Output -> m Logger
create :: forall (m :: * -> *). MonadIO m => Output -> m Logger
create Output
o = Settings -> m Logger
forall (m :: * -> *). MonadIO m => Settings -> m Logger
new (Settings -> m Logger) -> Settings -> m Logger
forall a b. (a -> b) -> a -> b
$ Output -> Settings -> Settings
setOutput Output
o Settings
defSettings

readNote :: Read a => String -> String -> a
readNote :: forall a. Read a => String -> String -> a
readNote String
m String
s = case ReadS a
forall a. Read a => ReadS a
reads String
s of
    [(a
a, String
"")] -> a
a
    [(a, String)]
_         -> String -> a
forall a. HasCallStack => String -> a
error String
m

-- | Logs a message with the given level if greater or equal to the
-- logger's threshold.
log :: MonadIO m => Logger -> Level -> (Msg -> Msg) -> m ()
log :: forall (m :: * -> *).
MonadIO m =>
Logger -> Level -> (Msg -> Msg) -> m ()
log Logger
g Level
l Msg -> Msg
m = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Logger -> Level
level Logger
g Level -> Level -> Bool
forall a. Ord a => a -> a -> Bool
> Level
l) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> Level -> (Msg -> Msg) -> m ()
forall (m :: * -> *).
MonadIO m =>
Logger -> Level -> (Msg -> Msg) -> m ()
putMsg Logger
g Level
l Msg -> Msg
m
{-# INLINE log #-}

-- | Abbreviation of 'log' using the corresponding log level.
trace, debug, info, warn, err, fatal :: MonadIO m => Logger -> (Msg -> Msg) -> m ()
trace :: forall (m :: * -> *). MonadIO m => Logger -> (Msg -> Msg) -> m ()
trace Logger
g = Logger -> Level -> (Msg -> Msg) -> m ()
forall (m :: * -> *).
MonadIO m =>
Logger -> Level -> (Msg -> Msg) -> m ()
log Logger
g Level
Trace
debug :: forall (m :: * -> *). MonadIO m => Logger -> (Msg -> Msg) -> m ()
debug Logger
g = Logger -> Level -> (Msg -> Msg) -> m ()
forall (m :: * -> *).
MonadIO m =>
Logger -> Level -> (Msg -> Msg) -> m ()
log Logger
g Level
Debug
info :: forall (m :: * -> *). MonadIO m => Logger -> (Msg -> Msg) -> m ()
info  Logger
g = Logger -> Level -> (Msg -> Msg) -> m ()
forall (m :: * -> *).
MonadIO m =>
Logger -> Level -> (Msg -> Msg) -> m ()
log Logger
g Level
Info
warn :: forall (m :: * -> *). MonadIO m => Logger -> (Msg -> Msg) -> m ()
warn  Logger
g = Logger -> Level -> (Msg -> Msg) -> m ()
forall (m :: * -> *).
MonadIO m =>
Logger -> Level -> (Msg -> Msg) -> m ()
log Logger
g Level
Warn
err :: forall (m :: * -> *). MonadIO m => Logger -> (Msg -> Msg) -> m ()
err   Logger
g = Logger -> Level -> (Msg -> Msg) -> m ()
forall (m :: * -> *).
MonadIO m =>
Logger -> Level -> (Msg -> Msg) -> m ()
log Logger
g Level
Error
fatal :: forall (m :: * -> *). MonadIO m => Logger -> (Msg -> Msg) -> m ()
fatal Logger
g = Logger -> Level -> (Msg -> Msg) -> m ()
forall (m :: * -> *).
MonadIO m =>
Logger -> Level -> (Msg -> Msg) -> m ()
log Logger
g Level
Fatal
{-# INLINE trace #-}
{-# INLINE debug #-}
{-# INLINE info  #-}
{-# INLINE warn  #-}
{-# INLINE err   #-}
{-# INLINE fatal #-}

-- | Clone the given logger and optionally give it a name
-- (use @Nothing@ to clear).
--
-- If 'logLevelOf' returns a custom 'Level' for this name
-- then the cloned logger will use it for its log messages.
clone :: Maybe Text -> Logger -> Logger
clone :: Maybe Text -> Logger -> Logger
clone Maybe Text
Nothing  Logger
g = Logger
g { settings = setName Nothing (settings g) }
clone (Just Text
n) Logger
g =
    let s :: Settings
s = Logger -> Settings
settings Logger
g
        l :: Level
l = Level -> Maybe Level -> Level
forall a. a -> Maybe a -> a
fromMaybe (Settings -> Level
logLevel Settings
s) (Maybe Level -> Level) -> Maybe Level -> Level
forall a b. (a -> b) -> a -> b
$ Text -> Settings -> Maybe Level
logLevelOf Text
n Settings
s
    in Logger
g { settings = setName (Just n) . setLogLevel l $ s }

-- | Force buffered bytes to output sink.
flush :: MonadIO m => Logger -> m ()
flush :: forall (m :: * -> *). MonadIO m => Logger -> m ()
flush = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Logger -> IO ()) -> Logger -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoggerSet -> IO ()
FL.flushLogStr (LoggerSet -> IO ()) -> (Logger -> LoggerSet) -> Logger -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Logger -> LoggerSet
logger

-- | Closes the logger.
close :: MonadIO m => Logger -> m ()
close :: forall (m :: * -> *). MonadIO m => Logger -> m ()
close Logger
g = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ LoggerSet -> IO ()
FL.rmLoggerSet (Logger -> LoggerSet
logger Logger
g)

-- | Inspect this logger's threshold.
level :: Logger -> Level
level :: Logger -> Level
level = Settings -> Level
logLevel (Settings -> Level) -> (Logger -> Settings) -> Logger -> Level
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Logger -> Settings
settings
{-# INLINE level #-}

putMsg :: MonadIO m => Logger -> Level -> (Msg -> Msg) -> m ()
putMsg :: forall (m :: * -> *).
MonadIO m =>
Logger -> Level -> (Msg -> Msg) -> m ()
putMsg Logger
g Level
l Msg -> Msg
f = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Msg -> Msg
d <- Logger -> IO (Msg -> Msg)
getDate Logger
g
    let r :: Renderer
r = Settings -> Renderer
renderer  (Settings -> Renderer) -> Settings -> Renderer
forall a b. (a -> b) -> a -> b
$ Logger -> Settings
settings Logger
g
    let x :: ByteString
x = Settings -> ByteString
delimiter (Settings -> ByteString) -> Settings -> ByteString
forall a b. (a -> b) -> a -> b
$ Logger -> Settings
settings Logger
g
    let s :: Msg -> Msg
s = Settings -> Msg -> Msg
nameMsg   (Settings -> Msg -> Msg) -> Settings -> Msg -> Msg
forall a b. (a -> b) -> a -> b
$ Logger -> Settings
settings Logger
g
    let df :: DateFormat
df = DateFormat -> Maybe DateFormat -> DateFormat
forall a. a -> Maybe a -> a
fromMaybe DateFormat
iso8601UTC (Maybe DateFormat -> DateFormat)
-> (Settings -> Maybe DateFormat) -> Settings -> DateFormat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Settings -> Maybe DateFormat
format (Settings -> DateFormat) -> Settings -> DateFormat
forall a b. (a -> b) -> a -> b
$ Logger -> Settings
settings Logger
g
    let ll :: Level
ll = Settings -> Level
logLevel (Settings -> Level) -> Settings -> Level
forall a b. (a -> b) -> a -> b
$ Logger -> Settings
settings Logger
g
    let m :: ByteString
m = ([Element] -> Builder) -> (Msg -> Msg) -> ByteString
render (Renderer
r ByteString
x DateFormat
df Level
ll) (Msg -> Msg
d (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Level -> Msg -> Msg
lmsg Level
l (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> Msg
s (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> Msg
f)
    LoggerSet -> LogStr -> IO ()
FL.pushLogStr (Logger -> LoggerSet
logger Logger
g) (ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
FL.toLogStr ByteString
m)

lmsg :: Level -> (Msg -> Msg)
lmsg :: Level -> Msg -> Msg
lmsg Level
Trace = Builder -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
msg (ByteString -> Builder
val ByteString
"T")
lmsg Level
Debug = Builder -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
msg (ByteString -> Builder
val ByteString
"D")
lmsg Level
Info  = Builder -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
msg (ByteString -> Builder
val ByteString
"I")
lmsg Level
Warn  = Builder -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
msg (ByteString -> Builder
val ByteString
"W")
lmsg Level
Error = Builder -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
msg (ByteString -> Builder
val ByteString
"E")
lmsg Level
Fatal = Builder -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
msg (ByteString -> Builder
val ByteString
"F")
{-# INLINE lmsg #-}