-- Copyright (c) 2014-2015 PivotCloud, Inc.
--
-- System.Logger
--
-- Please feel free to contact us at licensing@pivotmail.com with any
-- contributions, additions, or other feedback; we would love to hear from
-- you.
--
-- Licensed under the Apache License, Version 2.0 (the "License"); you may
-- not use this file except in compliance with the License. You may obtain a
-- copy of the License at http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
-- WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
-- License for the specific language governing permissions and limitations
-- under the License.

-- |
-- Module: System.Logger
-- Description: Yet Another Logger
-- Copyright: Copyright © 2015 PivotCloud, Inc.
-- License: Apache-2.0
-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>
-- Stability: experimental
--
-- This module re-exports the logger interface from "System.Logger.Types" and
-- the implementation of that interface from "System.Logger.Logger" and
-- "System.Logger.Backend.Handle".
--

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnicodeSyntax #-}

module System.Logger
( withConsoleLogger
, withFileLogger

-- * Logger Interface
, module System.Logger.Types

-- * Yet Another Logger
, module System.Logger.Logger

-- * Handle Backend
, module System.Logger.Backend.Handle

-- * Logging System Configuration
, LogConfig(..)
, logConfigLogger
, logConfigBackend
, defaultLogConfig
, validateLogConfig
, pLogConfig
, pLogConfig_
) where

import Configuration.Utils hiding (Lens')

import Control.Monad.IO.Class
import Control.Monad.Trans.Control

import qualified Data.Text as T
import Data.Typeable

import GHC.Generics

import Lens.Micro

import Prelude.Unicode

import System.Logger.Backend.ColorOption
import System.Logger.Backend.Handle
import System.Logger.Logger
import System.Logger.Types

-- | A simple console logger
--
-- > import System.Logger
-- >
-- > main ∷ IO ()
-- > main = withConsoleLogger Info $ do
-- >     logg Info "moin"
-- >     withLabel ("function", "f") f
-- >     logg Warn "tschüss"
-- >   where
-- >     f = withLevel Debug $ do
-- >         logg Debug "debug f"
--
withConsoleLogger
    ∷ (MonadIO m, MonadBaseControl IO m)
    ⇒ LogLevel
    → LoggerT T.Text m α
    → m α
withConsoleLogger :: LogLevel -> LoggerT Text m α -> m α
withConsoleLogger LogLevel
level LoggerT Text m α
inner =
    HandleBackendConfig -> (LoggerBackend Text -> m α) -> m α
forall (m :: * -> *) α.
(MonadIO m, MonadBaseControl IO m) =>
HandleBackendConfig -> (LoggerBackend Text -> m α) -> m α
withHandleBackend (LogConfig
config LogConfig
-> Getting HandleBackendConfig LogConfig HandleBackendConfig
-> HandleBackendConfig
forall s a. s -> Getting a s a -> a
^. Getting HandleBackendConfig LogConfig HandleBackendConfig
Lens' LogConfig HandleBackendConfig
logConfigBackend) ((LoggerBackend Text -> m α) -> m α)
-> (LoggerBackend Text -> m α) -> m α
forall a b. (a -> b) -> a -> b
$ \LoggerBackend Text
backend →
        LoggerConfig -> LoggerBackend Text -> (Logger Text -> m α) -> m α
forall (μ :: * -> *) a α.
(MonadIO μ, MonadBaseControl IO μ) =>
LoggerConfig -> LoggerBackend a -> (Logger a -> μ α) -> μ α
withLogger (LogConfig
config LogConfig
-> Getting LoggerConfig LogConfig LoggerConfig -> LoggerConfig
forall s a. s -> Getting a s a -> a
^. Getting LoggerConfig LogConfig LoggerConfig
Lens' LogConfig LoggerConfig
logConfigLogger) LoggerBackend Text
backend ((Logger Text -> m α) -> m α) -> (Logger Text -> m α) -> m α
forall a b. (a -> b) -> a -> b
$ LoggerT Text m α -> Logger Text -> m α
forall a (m :: * -> *) α. LoggerT a m α -> Logger a -> m α
runLoggerT LoggerT Text m α
inner
  where
    config :: LogConfig
config = LogConfig
defaultLogConfig
        LogConfig -> (LogConfig -> LogConfig) -> LogConfig
forall a b. a -> (a -> b) -> b
& (LoggerConfig -> Identity LoggerConfig)
-> LogConfig -> Identity LogConfig
Lens' LogConfig LoggerConfig
logConfigLogger ((LoggerConfig -> Identity LoggerConfig)
 -> LogConfig -> Identity LogConfig)
-> ((LogLevel -> Identity LogLevel)
    -> LoggerConfig -> Identity LoggerConfig)
-> (LogLevel -> Identity LogLevel)
-> LogConfig
-> Identity LogConfig
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ (LogLevel -> Identity LogLevel)
-> LoggerConfig -> Identity LoggerConfig
Lens' LoggerConfig LogLevel
loggerConfigThreshold ((LogLevel -> Identity LogLevel)
 -> LogConfig -> Identity LogConfig)
-> LogLevel -> LogConfig -> LogConfig
forall s t a b. ASetter s t a b -> b -> s -> t
.~ LogLevel
level

-- | A simple file logger
--
withFileLogger
    ∷ (MonadIO m, MonadBaseControl IO m)
    ⇒ FilePath
    → LogLevel
    → LoggerT T.Text m α
    → m α
withFileLogger :: FilePath -> LogLevel -> LoggerT Text m α -> m α
withFileLogger FilePath
f LogLevel
level LoggerT Text m α
inner =
    HandleBackendConfig -> (LoggerBackend Text -> m α) -> m α
forall (m :: * -> *) α.
(MonadIO m, MonadBaseControl IO m) =>
HandleBackendConfig -> (LoggerBackend Text -> m α) -> m α
withHandleBackend (LogConfig
config LogConfig
-> Getting HandleBackendConfig LogConfig HandleBackendConfig
-> HandleBackendConfig
forall s a. s -> Getting a s a -> a
^. Getting HandleBackendConfig LogConfig HandleBackendConfig
Lens' LogConfig HandleBackendConfig
logConfigBackend) ((LoggerBackend Text -> m α) -> m α)
-> (LoggerBackend Text -> m α) -> m α
forall a b. (a -> b) -> a -> b
$ \LoggerBackend Text
backend →
        LoggerConfig -> LoggerBackend Text -> (Logger Text -> m α) -> m α
forall (μ :: * -> *) a α.
(MonadIO μ, MonadBaseControl IO μ) =>
LoggerConfig -> LoggerBackend a -> (Logger a -> μ α) -> μ α
withLogger (LogConfig
config LogConfig
-> Getting LoggerConfig LogConfig LoggerConfig -> LoggerConfig
forall s a. s -> Getting a s a -> a
^. Getting LoggerConfig LogConfig LoggerConfig
Lens' LogConfig LoggerConfig
logConfigLogger) LoggerBackend Text
backend ((Logger Text -> m α) -> m α) -> (Logger Text -> m α) -> m α
forall a b. (a -> b) -> a -> b
$ LoggerT Text m α -> Logger Text -> m α
forall a (m :: * -> *) α. LoggerT a m α -> Logger a -> m α
runLoggerT LoggerT Text m α
inner
  where
    config :: LogConfig
config = LogConfig
defaultLogConfig
        LogConfig -> (LogConfig -> LogConfig) -> LogConfig
forall a b. a -> (a -> b) -> b
& (LoggerConfig -> Identity LoggerConfig)
-> LogConfig -> Identity LogConfig
Lens' LogConfig LoggerConfig
logConfigLogger ((LoggerConfig -> Identity LoggerConfig)
 -> LogConfig -> Identity LogConfig)
-> ((LogLevel -> Identity LogLevel)
    -> LoggerConfig -> Identity LoggerConfig)
-> (LogLevel -> Identity LogLevel)
-> LogConfig
-> Identity LogConfig
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ (LogLevel -> Identity LogLevel)
-> LoggerConfig -> Identity LoggerConfig
Lens' LoggerConfig LogLevel
loggerConfigThreshold ((LogLevel -> Identity LogLevel)
 -> LogConfig -> Identity LogConfig)
-> LogLevel -> LogConfig -> LogConfig
forall s t a b. ASetter s t a b -> b -> s -> t
.~ LogLevel
level
        LogConfig -> (LogConfig -> LogConfig) -> LogConfig
forall a b. a -> (a -> b) -> b
& (HandleBackendConfig -> Identity HandleBackendConfig)
-> LogConfig -> Identity LogConfig
Lens' LogConfig HandleBackendConfig
logConfigBackend ((HandleBackendConfig -> Identity HandleBackendConfig)
 -> LogConfig -> Identity LogConfig)
-> ((ColorOption -> Identity ColorOption)
    -> HandleBackendConfig -> Identity HandleBackendConfig)
-> (ColorOption -> Identity ColorOption)
-> LogConfig
-> Identity LogConfig
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ (ColorOption -> Identity ColorOption)
-> HandleBackendConfig -> Identity HandleBackendConfig
Lens' HandleBackendConfig ColorOption
handleBackendConfigColor ((ColorOption -> Identity ColorOption)
 -> LogConfig -> Identity LogConfig)
-> ColorOption -> LogConfig -> LogConfig
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ColorOption
ColorFalse
        LogConfig -> (LogConfig -> LogConfig) -> LogConfig
forall a b. a -> (a -> b) -> b
& (HandleBackendConfig -> Identity HandleBackendConfig)
-> LogConfig -> Identity LogConfig
Lens' LogConfig HandleBackendConfig
logConfigBackend ((HandleBackendConfig -> Identity HandleBackendConfig)
 -> LogConfig -> Identity LogConfig)
-> ((LoggerHandleConfig -> Identity LoggerHandleConfig)
    -> HandleBackendConfig -> Identity HandleBackendConfig)
-> (LoggerHandleConfig -> Identity LoggerHandleConfig)
-> LogConfig
-> Identity LogConfig
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ (LoggerHandleConfig -> Identity LoggerHandleConfig)
-> HandleBackendConfig -> Identity HandleBackendConfig
Lens' HandleBackendConfig LoggerHandleConfig
handleBackendConfigHandle ((LoggerHandleConfig -> Identity LoggerHandleConfig)
 -> LogConfig -> Identity LogConfig)
-> LoggerHandleConfig -> LogConfig -> LogConfig
forall s t a b. ASetter s t a b -> b -> s -> t
.~ FilePath -> LoggerHandleConfig
FileHandle FilePath
f

-- -------------------------------------------------------------------------- --
-- Logging System Configuration

data LogConfig = LogConfig
    { LogConfig -> LoggerConfig
_logConfigLogger ∷ !LoggerConfig
    , LogConfig -> HandleBackendConfig
_logConfigBackend ∷ !HandleBackendConfig
    }
    deriving (Int -> LogConfig -> ShowS
[LogConfig] -> ShowS
LogConfig -> FilePath
(Int -> LogConfig -> ShowS)
-> (LogConfig -> FilePath)
-> ([LogConfig] -> ShowS)
-> Show LogConfig
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [LogConfig] -> ShowS
$cshowList :: [LogConfig] -> ShowS
show :: LogConfig -> FilePath
$cshow :: LogConfig -> FilePath
showsPrec :: Int -> LogConfig -> ShowS
$cshowsPrec :: Int -> LogConfig -> ShowS
Show, ReadPrec [LogConfig]
ReadPrec LogConfig
Int -> ReadS LogConfig
ReadS [LogConfig]
(Int -> ReadS LogConfig)
-> ReadS [LogConfig]
-> ReadPrec LogConfig
-> ReadPrec [LogConfig]
-> Read LogConfig
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [LogConfig]
$creadListPrec :: ReadPrec [LogConfig]
readPrec :: ReadPrec LogConfig
$creadPrec :: ReadPrec LogConfig
readList :: ReadS [LogConfig]
$creadList :: ReadS [LogConfig]
readsPrec :: Int -> ReadS LogConfig
$creadsPrec :: Int -> ReadS LogConfig
Read, LogConfig -> LogConfig -> Bool
(LogConfig -> LogConfig -> Bool)
-> (LogConfig -> LogConfig -> Bool) -> Eq LogConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LogConfig -> LogConfig -> Bool
$c/= :: LogConfig -> LogConfig -> Bool
== :: LogConfig -> LogConfig -> Bool
$c== :: LogConfig -> LogConfig -> Bool
Eq, Eq LogConfig
Eq LogConfig
-> (LogConfig -> LogConfig -> Ordering)
-> (LogConfig -> LogConfig -> Bool)
-> (LogConfig -> LogConfig -> Bool)
-> (LogConfig -> LogConfig -> Bool)
-> (LogConfig -> LogConfig -> Bool)
-> (LogConfig -> LogConfig -> LogConfig)
-> (LogConfig -> LogConfig -> LogConfig)
-> Ord LogConfig
LogConfig -> LogConfig -> Bool
LogConfig -> LogConfig -> Ordering
LogConfig -> LogConfig -> LogConfig
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LogConfig -> LogConfig -> LogConfig
$cmin :: LogConfig -> LogConfig -> LogConfig
max :: LogConfig -> LogConfig -> LogConfig
$cmax :: LogConfig -> LogConfig -> LogConfig
>= :: LogConfig -> LogConfig -> Bool
$c>= :: LogConfig -> LogConfig -> Bool
> :: LogConfig -> LogConfig -> Bool
$c> :: LogConfig -> LogConfig -> Bool
<= :: LogConfig -> LogConfig -> Bool
$c<= :: LogConfig -> LogConfig -> Bool
< :: LogConfig -> LogConfig -> Bool
$c< :: LogConfig -> LogConfig -> Bool
compare :: LogConfig -> LogConfig -> Ordering
$ccompare :: LogConfig -> LogConfig -> Ordering
$cp1Ord :: Eq LogConfig
Ord, Typeable, (forall x. LogConfig -> Rep LogConfig x)
-> (forall x. Rep LogConfig x -> LogConfig) -> Generic LogConfig
forall x. Rep LogConfig x -> LogConfig
forall x. LogConfig -> Rep LogConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LogConfig x -> LogConfig
$cfrom :: forall x. LogConfig -> Rep LogConfig x
Generic)

logConfigLogger ∷ Lens' LogConfig LoggerConfig
logConfigLogger :: (LoggerConfig -> f LoggerConfig) -> LogConfig -> f LogConfig
logConfigLogger = (LogConfig -> LoggerConfig)
-> (LogConfig -> LoggerConfig -> LogConfig)
-> Lens' LogConfig LoggerConfig
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens LogConfig -> LoggerConfig
_logConfigLogger ((LogConfig -> LoggerConfig -> LogConfig)
 -> Lens' LogConfig LoggerConfig)
-> (LogConfig -> LoggerConfig -> LogConfig)
-> Lens' LogConfig LoggerConfig
forall a b. (a -> b) -> a -> b
$ \LogConfig
a LoggerConfig
b → LogConfig
a { _logConfigLogger :: LoggerConfig
_logConfigLogger = LoggerConfig
b }

logConfigBackend ∷ Lens' LogConfig HandleBackendConfig
logConfigBackend :: (HandleBackendConfig -> f HandleBackendConfig)
-> LogConfig -> f LogConfig
logConfigBackend = (LogConfig -> HandleBackendConfig)
-> (LogConfig -> HandleBackendConfig -> LogConfig)
-> Lens' LogConfig HandleBackendConfig
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens LogConfig -> HandleBackendConfig
_logConfigBackend ((LogConfig -> HandleBackendConfig -> LogConfig)
 -> Lens' LogConfig HandleBackendConfig)
-> (LogConfig -> HandleBackendConfig -> LogConfig)
-> Lens' LogConfig HandleBackendConfig
forall a b. (a -> b) -> a -> b
$ \LogConfig
a HandleBackendConfig
b → LogConfig
a { _logConfigBackend :: HandleBackendConfig
_logConfigBackend = HandleBackendConfig
b }

defaultLogConfig ∷ LogConfig
defaultLogConfig :: LogConfig
defaultLogConfig = LogConfig :: LoggerConfig -> HandleBackendConfig -> LogConfig
LogConfig
    { _logConfigLogger :: LoggerConfig
_logConfigLogger = LoggerConfig
defaultLoggerConfig
    , _logConfigBackend :: HandleBackendConfig
_logConfigBackend = HandleBackendConfig
defaultHandleBackendConfig
    }

validateLogConfig ∷ ConfigValidation LogConfig []
validateLogConfig :: LogConfig -> m ()
validateLogConfig LogConfig{LoggerConfig
HandleBackendConfig
_logConfigBackend :: HandleBackendConfig
_logConfigLogger :: LoggerConfig
_logConfigBackend :: LogConfig -> HandleBackendConfig
_logConfigLogger :: LogConfig -> LoggerConfig
..} = do
    LoggerConfig -> m ()
forall (λ :: * -> *). ConfigValidation LoggerConfig λ
validateLoggerConfig LoggerConfig
_logConfigLogger
    HandleBackendConfig -> m ()
ConfigValidation HandleBackendConfig []
validateHandleBackendConfig HandleBackendConfig
_logConfigBackend

instance ToJSON LogConfig where
    toJSON :: LogConfig -> Value
toJSON LogConfig{LoggerConfig
HandleBackendConfig
_logConfigBackend :: HandleBackendConfig
_logConfigLogger :: LoggerConfig
_logConfigBackend :: LogConfig -> HandleBackendConfig
_logConfigLogger :: LogConfig -> LoggerConfig
..} = [Pair] -> Value
object
        [ Key
"logger" Key -> LoggerConfig -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= LoggerConfig
_logConfigLogger
        , Key
"backend" Key -> HandleBackendConfig -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= HandleBackendConfig
_logConfigBackend
        ]

instance FromJSON (LogConfig → LogConfig) where
    parseJSON :: Value -> Parser (LogConfig -> LogConfig)
parseJSON = FilePath
-> (Object -> Parser (LogConfig -> LogConfig))
-> Value
-> Parser (LogConfig -> LogConfig)
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"LogConfig" ((Object -> Parser (LogConfig -> LogConfig))
 -> Value -> Parser (LogConfig -> LogConfig))
-> (Object -> Parser (LogConfig -> LogConfig))
-> Value
-> Parser (LogConfig -> LogConfig)
forall a b. (a -> b) -> a -> b
$ \Object
o → LogConfig -> LogConfig
forall a. a -> a
id
        (LogConfig -> LogConfig)
-> Parser (LogConfig -> LogConfig)
-> Parser (LogConfig -> LogConfig)
forall (f :: * -> *) b c a.
Functor f =>
(b -> c) -> f (a -> b) -> f (a -> c)
<$< Lens' LogConfig LoggerConfig
logConfigLogger Lens' LogConfig LoggerConfig
-> Text -> Object -> Parser (LogConfig -> LogConfig)
forall b a.
FromJSON (b -> b) =>
Lens' a b -> Text -> Object -> Parser (a -> a)
%.: Text
"logger" (Object -> Parser (LogConfig -> LogConfig))
-> Object -> Parser (LogConfig -> LogConfig)
forall a b. (a -> b) -> a -> b
% Object
o
        Parser (LogConfig -> LogConfig)
-> Parser (LogConfig -> LogConfig)
-> Parser (LogConfig -> LogConfig)
forall (f :: * -> *) b c a.
Applicative f =>
f (b -> c) -> f (a -> b) -> f (a -> c)
<*< Lens' LogConfig HandleBackendConfig
logConfigBackend Lens' LogConfig HandleBackendConfig
-> Text -> Object -> Parser (LogConfig -> LogConfig)
forall b a.
FromJSON (b -> b) =>
Lens' a b -> Text -> Object -> Parser (a -> a)
%.: Text
"backend" (Object -> Parser (LogConfig -> LogConfig))
-> Object -> Parser (LogConfig -> LogConfig)
forall a b. (a -> b) -> a -> b
% Object
o

pLogConfig ∷ MParser LogConfig
pLogConfig :: MParser LogConfig
pLogConfig = Text -> MParser LogConfig
pLogConfig_ Text
""

-- | A version of 'pLogConfig' that takes a prefix for the command
-- line option.
--
-- @since 0.2
--
pLogConfig_
    ∷ T.Text
        -- ^ prefix for this and all subordinate command line options.
    → MParser LogConfig
pLogConfig_ :: Text -> MParser LogConfig
pLogConfig_ Text
prefix = LogConfig -> LogConfig
forall a. a -> a
id
    (LogConfig -> LogConfig) -> MParser LogConfig -> MParser LogConfig
forall (f :: * -> *) b c a.
Functor f =>
(b -> c) -> f (a -> b) -> f (a -> c)
<$< Lens' LogConfig LoggerConfig
logConfigLogger Lens' LogConfig LoggerConfig
-> Parser (LoggerConfig -> LoggerConfig) -> MParser LogConfig
forall (f :: * -> *) a b.
(Alternative f, Applicative f) =>
Lens' a b -> f (b -> b) -> f (a -> a)
%:: Text -> Parser (LoggerConfig -> LoggerConfig)
pLoggerConfig_ Text
prefix
    MParser LogConfig -> MParser LogConfig -> MParser LogConfig
forall (f :: * -> *) b c a.
Applicative f =>
f (b -> c) -> f (a -> b) -> f (a -> c)
<*< Lens' LogConfig HandleBackendConfig
logConfigBackend Lens' LogConfig HandleBackendConfig
-> Parser (HandleBackendConfig -> HandleBackendConfig)
-> MParser LogConfig
forall (f :: * -> *) a b.
(Alternative f, Applicative f) =>
Lens' a b -> f (b -> b) -> f (a -> a)
%:: Text -> Parser (HandleBackendConfig -> HandleBackendConfig)
pHandleBackendConfig_ Text
prefix