-- 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 :: forall (m :: * -> *) α.
(MonadIO m, MonadBaseControl IO m) =>
LogLevel -> LoggerT Text m α -> m α
withConsoleLogger LogLevel
level LoggerT Text m α
inner =
    forall (m :: * -> *) α.
(MonadIO m, MonadBaseControl IO m) =>
HandleBackendConfig -> (LoggerBackend Text -> m α) -> m α
withHandleBackend (LogConfig
config forall s a. s -> Getting a s a -> a
^. Lens' LogConfig HandleBackendConfig
logConfigBackend) forall a b. (a -> b) -> a -> b
$ \LoggerBackend Text
backend →
        forall (μ :: * -> *) a α.
(MonadIO μ, MonadBaseControl IO μ) =>
LoggerConfig -> LoggerBackend a -> (Logger a -> μ α) -> μ α
withLogger (LogConfig
config forall s a. s -> Getting a s a -> a
^. Lens' LogConfig LoggerConfig
logConfigLogger) LoggerBackend Text
backend forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *) α. LoggerT a m α -> Logger a -> m α
runLoggerT LoggerT Text m α
inner
  where
    config :: LogConfig
config = LogConfig
defaultLogConfig
        forall a b. a -> (a -> b) -> b
& Lens' LogConfig LoggerConfig
logConfigLogger forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ Lens' LoggerConfig LogLevel
loggerConfigThreshold 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 :: forall (m :: * -> *) α.
(MonadIO m, MonadBaseControl IO m) =>
FilePath -> LogLevel -> LoggerT Text m α -> m α
withFileLogger FilePath
f LogLevel
level LoggerT Text m α
inner =
    forall (m :: * -> *) α.
(MonadIO m, MonadBaseControl IO m) =>
HandleBackendConfig -> (LoggerBackend Text -> m α) -> m α
withHandleBackend (LogConfig
config forall s a. s -> Getting a s a -> a
^. Lens' LogConfig HandleBackendConfig
logConfigBackend) forall a b. (a -> b) -> a -> b
$ \LoggerBackend Text
backend →
        forall (μ :: * -> *) a α.
(MonadIO μ, MonadBaseControl IO μ) =>
LoggerConfig -> LoggerBackend a -> (Logger a -> μ α) -> μ α
withLogger (LogConfig
config forall s a. s -> Getting a s a -> a
^. Lens' LogConfig LoggerConfig
logConfigLogger) LoggerBackend Text
backend forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *) α. LoggerT a m α -> Logger a -> m α
runLoggerT LoggerT Text m α
inner
  where
    config :: LogConfig
config = LogConfig
defaultLogConfig
        forall a b. a -> (a -> b) -> b
& Lens' LogConfig LoggerConfig
logConfigLogger forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ Lens' LoggerConfig LogLevel
loggerConfigThreshold forall s t a b. ASetter s t a b -> b -> s -> t
.~ LogLevel
level
        forall a b. a -> (a -> b) -> b
& Lens' LogConfig HandleBackendConfig
logConfigBackend forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ Lens' HandleBackendConfig ColorOption
handleBackendConfigColor forall s t a b. ASetter s t a b -> b -> s -> t
.~ ColorOption
ColorFalse
        forall a b. a -> (a -> b) -> b
& Lens' LogConfig HandleBackendConfig
logConfigBackend forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ Lens' HandleBackendConfig LoggerHandleConfig
handleBackendConfigHandle 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
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]
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
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
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
Ord, Typeable, 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 :: Lens' LogConfig LoggerConfig
logConfigLogger = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens LogConfig -> LoggerConfig
_logConfigLogger forall a b. (a -> b) -> a -> b
$ \LogConfig
a LoggerConfig
b → LogConfig
a { _logConfigLogger :: LoggerConfig
_logConfigLogger = LoggerConfig
b }

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

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

validateLogConfig ∷ ConfigValidation LogConfig []
validateLogConfig :: ConfigValidation LogConfig []
validateLogConfig LogConfig{LoggerConfig
HandleBackendConfig
_logConfigBackend :: HandleBackendConfig
_logConfigLogger :: LoggerConfig
_logConfigBackend :: LogConfig -> HandleBackendConfig
_logConfigLogger :: LogConfig -> LoggerConfig
..} = do
    forall (λ :: * -> *). ConfigValidation LoggerConfig λ
validateLoggerConfig LoggerConfig
_logConfigLogger
    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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= LoggerConfig
_logConfigLogger
        , Key
"backend" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= HandleBackendConfig
_logConfigBackend
        ]

instance FromJSON (LogConfig → LogConfig) where
    parseJSON :: Value -> Parser (LogConfig -> LogConfig)
parseJSON = forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"LogConfig" forall a b. (a -> b) -> a -> b
$ \Object
o → forall a. a -> a
id
        forall (f :: * -> *) b c a.
Functor f =>
(b -> c) -> f (a -> b) -> f (a -> c)
<$< Lens' LogConfig LoggerConfig
logConfigLogger forall b a.
FromJSON (b -> b) =>
Lens' a b -> Text -> Object -> Parser (a -> a)
%.: Text
"logger" forall a b. (a -> b) -> a -> b
% Object
o
        forall (f :: * -> *) b c a.
Applicative f =>
f (b -> c) -> f (a -> b) -> f (a -> c)
<*< Lens' LogConfig HandleBackendConfig
logConfigBackend forall b a.
FromJSON (b -> b) =>
Lens' a b -> Text -> Object -> Parser (a -> a)
%.: Text
"backend" 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 = forall a. a -> a
id
    forall (f :: * -> *) b c a.
Functor f =>
(b -> c) -> f (a -> b) -> f (a -> c)
<$< Lens' LogConfig LoggerConfig
logConfigLogger forall (f :: * -> *) a b.
(Alternative f, Applicative f) =>
Lens' a b -> f (b -> b) -> f (a -> a)
%:: Text -> MParser LoggerConfig
pLoggerConfig_ Text
prefix
    forall (f :: * -> *) b c a.
Applicative f =>
f (b -> c) -> f (a -> b) -> f (a -> c)
<*< Lens' LogConfig HandleBackendConfig
logConfigBackend forall (f :: * -> *) a b.
(Alternative f, Applicative f) =>
Lens' a b -> f (b -> b) -> f (a -> a)
%:: Text -> MParser HandleBackendConfig
pHandleBackendConfig_ Text
prefix