-- Copyright (c) 2016-2020 Lars Kuhtz <lakuhtz@gmail.com>
-- Copyright (c) 2014-2015 PivotCloud, Inc.
--
-- System.Logger.Logger.Internal
--
-- 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.Logger.Internal
-- Description: Yet Another Logger Implementation
-- Copyright:
--     Copyright (c) 2016-2022 Lars Kuhtz <lakuhtz@gmail.com>
--     Copyright (c) 2014-2015 PivotCloud, Inc.
-- License: Apache License, Version 2.0
-- Maintainer: Lars Kuhtz <lakuhtz@gmail.com>
-- Stability: experimental
--
-- This module provides a logger that implements the logger interface
-- that is defined in "System.Logger.Types".
--
-- If you want to roll your own implementation you may use the code in this
-- module as an example and starting point.
--

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnicodeSyntax #-}

module System.Logger.Logger.Internal
(
-- * Logger Configuration
  LoggerConfig(..)
, loggerConfigQueueSize
, loggerConfigThreshold
, loggerConfigScope
, loggerConfigPolicy
, loggerConfigExceptionLimit
, loggerConfigExceptionWait
, loggerConfigExitTimeout
, defaultLoggerConfig
, validateLoggerConfig
, pLoggerConfig
, pLoggerConfig_

-- * Logger
, Logger
, loggerScope
, loggerThreshold
, createLogger
, createLogger_
, releaseLogger
, withLogger
, withLogger_
, loggCtx
, withLogFunction
, withLogFunction_

-- * LoggerT Monad Transformer
, LoggerT
, runLoggerT
, runLogT
) where

import Configuration.Utils hiding (Error, Lens')

import Control.Concurrent (threadDelay)
import Control.Concurrent.Async
import Control.DeepSeq
import Control.Exception.Enclosed
import Control.Exception.Lifted
import Control.Monad.Except
import Control.Monad.Trans.Control
import Control.Monad.Unicode

import Data.IORef
import Data.Monoid.Unicode
import qualified Data.Text as T
import qualified Data.Text.IO as T (hPutStrLn)
import Data.Typeable
import Data.Void

import GHC.Generics
import GHC.IORef

import Lens.Micro

import Numeric.Natural

import Prelude.Unicode

import System.Clock
import System.IO (stderr)
import System.Timeout

-- internal modules

import System.Logger.Internal
import System.Logger.Internal.Queue
import System.Logger.Types

-- -------------------------------------------------------------------------- --
-- Logger Configuration

-- | Logger Configuration
--
data LoggerConfig = LoggerConfig
    { LoggerConfig -> Natural
_loggerConfigQueueSize ∷ !Natural
    , LoggerConfig -> LogLevel
_loggerConfigThreshold ∷ !LogLevel
        -- ^ initial log threshold, can be changed later on
    , LoggerConfig -> LogScope
_loggerConfigScope ∷ !LogScope
        -- ^ initial stack of log labels, can be extended later on
    , LoggerConfig -> LogPolicy
_loggerConfigPolicy ∷ !LogPolicy
        -- ^ how to deal with a congested logging pipeline
    , LoggerConfig -> Maybe Natural
_loggerConfigExceptionLimit ∷ !(Maybe Natural)
        -- ^ number of consecutive backend exception that can occur before the logger
        -- raises an 'BackendTooManyExceptions' exception. If this is 'Nothing'
        -- the logger will discard all exceptions. For instance a value of @1@
        -- means that an exception is raised when the second exception occurs.
        -- A value of @0@ means that an exception is raised for each exception.
        --
        -- @since 0.2

    , LoggerConfig -> Maybe Natural
_loggerConfigExceptionWait ∷ !(Maybe Natural)
        -- ^ number of microseconds to wait after an exception from the backend.
        -- If this is 'Nothing' the logger won't wait at all after an exception.
        --
        -- @since 0.2

    , LoggerConfig -> Maybe Natural
_loggerConfigExitTimeout ∷ !(Maybe Natural)
        -- ^ timeout in microseconds for the logger to flush the queue and
        -- deliver all remaining log messages on termination. If this is 'Nothing'
        -- termination of the logger blogs until all mesages are delivered.
        --
        -- @since 0.2
    }
    deriving (Int -> LoggerConfig -> ShowS
[LoggerConfig] -> ShowS
LoggerConfig -> String
(Int -> LoggerConfig -> ShowS)
-> (LoggerConfig -> String)
-> ([LoggerConfig] -> ShowS)
-> Show LoggerConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LoggerConfig] -> ShowS
$cshowList :: [LoggerConfig] -> ShowS
show :: LoggerConfig -> String
$cshow :: LoggerConfig -> String
showsPrec :: Int -> LoggerConfig -> ShowS
$cshowsPrec :: Int -> LoggerConfig -> ShowS
Show, ReadPrec [LoggerConfig]
ReadPrec LoggerConfig
Int -> ReadS LoggerConfig
ReadS [LoggerConfig]
(Int -> ReadS LoggerConfig)
-> ReadS [LoggerConfig]
-> ReadPrec LoggerConfig
-> ReadPrec [LoggerConfig]
-> Read LoggerConfig
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [LoggerConfig]
$creadListPrec :: ReadPrec [LoggerConfig]
readPrec :: ReadPrec LoggerConfig
$creadPrec :: ReadPrec LoggerConfig
readList :: ReadS [LoggerConfig]
$creadList :: ReadS [LoggerConfig]
readsPrec :: Int -> ReadS LoggerConfig
$creadsPrec :: Int -> ReadS LoggerConfig
Read, LoggerConfig -> LoggerConfig -> Bool
(LoggerConfig -> LoggerConfig -> Bool)
-> (LoggerConfig -> LoggerConfig -> Bool) -> Eq LoggerConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LoggerConfig -> LoggerConfig -> Bool
$c/= :: LoggerConfig -> LoggerConfig -> Bool
== :: LoggerConfig -> LoggerConfig -> Bool
$c== :: LoggerConfig -> LoggerConfig -> Bool
Eq, Eq LoggerConfig
Eq LoggerConfig
-> (LoggerConfig -> LoggerConfig -> Ordering)
-> (LoggerConfig -> LoggerConfig -> Bool)
-> (LoggerConfig -> LoggerConfig -> Bool)
-> (LoggerConfig -> LoggerConfig -> Bool)
-> (LoggerConfig -> LoggerConfig -> Bool)
-> (LoggerConfig -> LoggerConfig -> LoggerConfig)
-> (LoggerConfig -> LoggerConfig -> LoggerConfig)
-> Ord LoggerConfig
LoggerConfig -> LoggerConfig -> Bool
LoggerConfig -> LoggerConfig -> Ordering
LoggerConfig -> LoggerConfig -> LoggerConfig
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 :: LoggerConfig -> LoggerConfig -> LoggerConfig
$cmin :: LoggerConfig -> LoggerConfig -> LoggerConfig
max :: LoggerConfig -> LoggerConfig -> LoggerConfig
$cmax :: LoggerConfig -> LoggerConfig -> LoggerConfig
>= :: LoggerConfig -> LoggerConfig -> Bool
$c>= :: LoggerConfig -> LoggerConfig -> Bool
> :: LoggerConfig -> LoggerConfig -> Bool
$c> :: LoggerConfig -> LoggerConfig -> Bool
<= :: LoggerConfig -> LoggerConfig -> Bool
$c<= :: LoggerConfig -> LoggerConfig -> Bool
< :: LoggerConfig -> LoggerConfig -> Bool
$c< :: LoggerConfig -> LoggerConfig -> Bool
compare :: LoggerConfig -> LoggerConfig -> Ordering
$ccompare :: LoggerConfig -> LoggerConfig -> Ordering
$cp1Ord :: Eq LoggerConfig
Ord, Typeable, (forall x. LoggerConfig -> Rep LoggerConfig x)
-> (forall x. Rep LoggerConfig x -> LoggerConfig)
-> Generic LoggerConfig
forall x. Rep LoggerConfig x -> LoggerConfig
forall x. LoggerConfig -> Rep LoggerConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LoggerConfig x -> LoggerConfig
$cfrom :: forall x. LoggerConfig -> Rep LoggerConfig x
Generic)

loggerConfigQueueSize ∷ Lens' LoggerConfig Natural
loggerConfigQueueSize :: (Natural -> f Natural) -> LoggerConfig -> f LoggerConfig
loggerConfigQueueSize = (LoggerConfig -> Natural)
-> (LoggerConfig -> Natural -> LoggerConfig)
-> Lens LoggerConfig LoggerConfig Natural Natural
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens LoggerConfig -> Natural
_loggerConfigQueueSize ((LoggerConfig -> Natural -> LoggerConfig)
 -> Lens LoggerConfig LoggerConfig Natural Natural)
-> (LoggerConfig -> Natural -> LoggerConfig)
-> Lens LoggerConfig LoggerConfig Natural Natural
forall a b. (a -> b) -> a -> b
$ \LoggerConfig
a Natural
b → LoggerConfig
a { _loggerConfigQueueSize :: Natural
_loggerConfigQueueSize = Natural
b }

loggerConfigThreshold ∷ Lens' LoggerConfig LogLevel
loggerConfigThreshold :: (LogLevel -> f LogLevel) -> LoggerConfig -> f LoggerConfig
loggerConfigThreshold = (LoggerConfig -> LogLevel)
-> (LoggerConfig -> LogLevel -> LoggerConfig)
-> Lens LoggerConfig LoggerConfig LogLevel LogLevel
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens LoggerConfig -> LogLevel
_loggerConfigThreshold ((LoggerConfig -> LogLevel -> LoggerConfig)
 -> Lens LoggerConfig LoggerConfig LogLevel LogLevel)
-> (LoggerConfig -> LogLevel -> LoggerConfig)
-> Lens LoggerConfig LoggerConfig LogLevel LogLevel
forall a b. (a -> b) -> a -> b
$ \LoggerConfig
a LogLevel
b → LoggerConfig
a { _loggerConfigThreshold :: LogLevel
_loggerConfigThreshold = LogLevel
b }

loggerConfigScope ∷ Lens' LoggerConfig LogScope
loggerConfigScope :: (LogScope -> f LogScope) -> LoggerConfig -> f LoggerConfig
loggerConfigScope = (LoggerConfig -> LogScope)
-> (LoggerConfig -> LogScope -> LoggerConfig)
-> Lens LoggerConfig LoggerConfig LogScope LogScope
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens LoggerConfig -> LogScope
_loggerConfigScope ((LoggerConfig -> LogScope -> LoggerConfig)
 -> Lens LoggerConfig LoggerConfig LogScope LogScope)
-> (LoggerConfig -> LogScope -> LoggerConfig)
-> Lens LoggerConfig LoggerConfig LogScope LogScope
forall a b. (a -> b) -> a -> b
$ \LoggerConfig
a LogScope
b → LoggerConfig
a { _loggerConfigScope :: LogScope
_loggerConfigScope = LogScope
b }

loggerConfigPolicy ∷ Lens' LoggerConfig LogPolicy
loggerConfigPolicy :: (LogPolicy -> f LogPolicy) -> LoggerConfig -> f LoggerConfig
loggerConfigPolicy = (LoggerConfig -> LogPolicy)
-> (LoggerConfig -> LogPolicy -> LoggerConfig)
-> Lens LoggerConfig LoggerConfig LogPolicy LogPolicy
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens LoggerConfig -> LogPolicy
_loggerConfigPolicy ((LoggerConfig -> LogPolicy -> LoggerConfig)
 -> Lens LoggerConfig LoggerConfig LogPolicy LogPolicy)
-> (LoggerConfig -> LogPolicy -> LoggerConfig)
-> Lens LoggerConfig LoggerConfig LogPolicy LogPolicy
forall a b. (a -> b) -> a -> b
$ \LoggerConfig
a LogPolicy
b → LoggerConfig
a { _loggerConfigPolicy :: LogPolicy
_loggerConfigPolicy = LogPolicy
b }

loggerConfigExceptionLimit ∷ Lens' LoggerConfig (Maybe Natural)
loggerConfigExceptionLimit :: (Maybe Natural -> f (Maybe Natural))
-> LoggerConfig -> f LoggerConfig
loggerConfigExceptionLimit = (LoggerConfig -> Maybe Natural)
-> (LoggerConfig -> Maybe Natural -> LoggerConfig)
-> Lens LoggerConfig LoggerConfig (Maybe Natural) (Maybe Natural)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens LoggerConfig -> Maybe Natural
_loggerConfigExceptionLimit ((LoggerConfig -> Maybe Natural -> LoggerConfig)
 -> Lens LoggerConfig LoggerConfig (Maybe Natural) (Maybe Natural))
-> (LoggerConfig -> Maybe Natural -> LoggerConfig)
-> Lens LoggerConfig LoggerConfig (Maybe Natural) (Maybe Natural)
forall a b. (a -> b) -> a -> b
$ \LoggerConfig
a Maybe Natural
b → LoggerConfig
a { _loggerConfigExceptionLimit :: Maybe Natural
_loggerConfigExceptionLimit = Maybe Natural
b }

loggerConfigExceptionWait ∷ Lens' LoggerConfig (Maybe Natural)
loggerConfigExceptionWait :: (Maybe Natural -> f (Maybe Natural))
-> LoggerConfig -> f LoggerConfig
loggerConfigExceptionWait = (LoggerConfig -> Maybe Natural)
-> (LoggerConfig -> Maybe Natural -> LoggerConfig)
-> Lens LoggerConfig LoggerConfig (Maybe Natural) (Maybe Natural)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens LoggerConfig -> Maybe Natural
_loggerConfigExceptionWait ((LoggerConfig -> Maybe Natural -> LoggerConfig)
 -> Lens LoggerConfig LoggerConfig (Maybe Natural) (Maybe Natural))
-> (LoggerConfig -> Maybe Natural -> LoggerConfig)
-> Lens LoggerConfig LoggerConfig (Maybe Natural) (Maybe Natural)
forall a b. (a -> b) -> a -> b
$ \LoggerConfig
a Maybe Natural
b → LoggerConfig
a { _loggerConfigExceptionWait :: Maybe Natural
_loggerConfigExceptionWait = Maybe Natural
b }

loggerConfigExitTimeout ∷ Lens' LoggerConfig (Maybe Natural)
loggerConfigExitTimeout :: (Maybe Natural -> f (Maybe Natural))
-> LoggerConfig -> f LoggerConfig
loggerConfigExitTimeout = (LoggerConfig -> Maybe Natural)
-> (LoggerConfig -> Maybe Natural -> LoggerConfig)
-> Lens LoggerConfig LoggerConfig (Maybe Natural) (Maybe Natural)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens LoggerConfig -> Maybe Natural
_loggerConfigExitTimeout ((LoggerConfig -> Maybe Natural -> LoggerConfig)
 -> Lens LoggerConfig LoggerConfig (Maybe Natural) (Maybe Natural))
-> (LoggerConfig -> Maybe Natural -> LoggerConfig)
-> Lens LoggerConfig LoggerConfig (Maybe Natural) (Maybe Natural)
forall a b. (a -> b) -> a -> b
$ \LoggerConfig
a Maybe Natural
b → LoggerConfig
a { _loggerConfigExitTimeout :: Maybe Natural
_loggerConfigExitTimeout = Maybe Natural
b }

instance NFData LoggerConfig

-- | Default Logger configuration
--
-- The exception limit for backend exceptions is 10 and the wait time between
-- exceptions is 1000. This means that in case of a defunctioned backend the
-- logger will exist by throwing an exception after at least one second.
-- When the logger is terminated it is granted 1 second to flush the queue
-- and deliver all remaining log messages.
--
defaultLoggerConfig ∷ LoggerConfig
defaultLoggerConfig :: LoggerConfig
defaultLoggerConfig = LoggerConfig :: Natural
-> LogLevel
-> LogScope
-> LogPolicy
-> Maybe Natural
-> Maybe Natural
-> Maybe Natural
-> LoggerConfig
LoggerConfig
    { _loggerConfigQueueSize :: Natural
_loggerConfigQueueSize = Natural
1000
    , _loggerConfigThreshold :: LogLevel
_loggerConfigThreshold = LogLevel
Warn
    , _loggerConfigScope :: LogScope
_loggerConfigScope = []
    , _loggerConfigPolicy :: LogPolicy
_loggerConfigPolicy = LogPolicy
LogPolicyDiscard
    , _loggerConfigExceptionLimit :: Maybe Natural
_loggerConfigExceptionLimit = Natural -> Maybe Natural
forall a. a -> Maybe a
Just Natural
10
    , _loggerConfigExceptionWait :: Maybe Natural
_loggerConfigExceptionWait = Natural -> Maybe Natural
forall a. a -> Maybe a
Just Natural
1000
    , _loggerConfigExitTimeout :: Maybe Natural
_loggerConfigExitTimeout = Natural -> Maybe Natural
forall a. a -> Maybe a
Just Natural
1000000
    }

validateLoggerConfig ∷ ConfigValidation LoggerConfig λ
validateLoggerConfig :: LoggerConfig -> m ()
validateLoggerConfig LoggerConfig
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

instance ToJSON LoggerConfig where
    toJSON :: LoggerConfig -> Value
toJSON LoggerConfig{Natural
LogScope
Maybe Natural
LogPolicy
LogLevel
_loggerConfigExitTimeout :: Maybe Natural
_loggerConfigExceptionWait :: Maybe Natural
_loggerConfigExceptionLimit :: Maybe Natural
_loggerConfigPolicy :: LogPolicy
_loggerConfigScope :: LogScope
_loggerConfigThreshold :: LogLevel
_loggerConfigQueueSize :: Natural
_loggerConfigExitTimeout :: LoggerConfig -> Maybe Natural
_loggerConfigExceptionWait :: LoggerConfig -> Maybe Natural
_loggerConfigExceptionLimit :: LoggerConfig -> Maybe Natural
_loggerConfigPolicy :: LoggerConfig -> LogPolicy
_loggerConfigScope :: LoggerConfig -> LogScope
_loggerConfigThreshold :: LoggerConfig -> LogLevel
_loggerConfigQueueSize :: LoggerConfig -> Natural
..} = [Pair] -> Value
object
        [ Key
"queue_size" Key -> Natural -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Natural
_loggerConfigQueueSize
        , Key
"log_level" Key -> LogLevel -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= LogLevel
_loggerConfigThreshold
        , Key
"scope" Key -> LogScope -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= LogScope
_loggerConfigScope
        , Key
"policy" Key -> LogPolicy -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= LogPolicy
_loggerConfigPolicy
        , Key
"exception_limit" Key -> Maybe Natural -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Natural
_loggerConfigExceptionLimit
        , Key
"exception_wait" Key -> Maybe Natural -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Natural
_loggerConfigExceptionWait
        , Key
"exit_timeout" Key -> Maybe Natural -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Natural
_loggerConfigExitTimeout
        ]

instance FromJSON (LoggerConfig → LoggerConfig) where
    parseJSON :: Value -> Parser (LoggerConfig -> LoggerConfig)
parseJSON = String
-> (Object -> Parser (LoggerConfig -> LoggerConfig))
-> Value
-> Parser (LoggerConfig -> LoggerConfig)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"LoggerConfig" ((Object -> Parser (LoggerConfig -> LoggerConfig))
 -> Value -> Parser (LoggerConfig -> LoggerConfig))
-> (Object -> Parser (LoggerConfig -> LoggerConfig))
-> Value
-> Parser (LoggerConfig -> LoggerConfig)
forall a b. (a -> b) -> a -> b
$ \Object
o → LoggerConfig -> LoggerConfig
forall a. a -> a
id
        (LoggerConfig -> LoggerConfig)
-> Parser (LoggerConfig -> LoggerConfig)
-> Parser (LoggerConfig -> LoggerConfig)
forall (f :: * -> *) b c a.
Functor f =>
(b -> c) -> f (a -> b) -> f (a -> c)
<$< Lens LoggerConfig LoggerConfig Natural Natural
loggerConfigQueueSize Lens LoggerConfig LoggerConfig Natural Natural
-> Text -> Object -> Parser (LoggerConfig -> LoggerConfig)
forall b a.
FromJSON b =>
Lens' a b -> Text -> Object -> Parser (a -> a)
..: Text
"queue_size" (Object -> Parser (LoggerConfig -> LoggerConfig))
-> Object -> Parser (LoggerConfig -> LoggerConfig)
forall a b. (a -> b) -> a -> b
% Object
o
        Parser (LoggerConfig -> LoggerConfig)
-> Parser (LoggerConfig -> LoggerConfig)
-> Parser (LoggerConfig -> LoggerConfig)
forall (f :: * -> *) b c a.
Applicative f =>
f (b -> c) -> f (a -> b) -> f (a -> c)
<*< Lens LoggerConfig LoggerConfig LogLevel LogLevel
loggerConfigThreshold Lens LoggerConfig LoggerConfig LogLevel LogLevel
-> Text -> Object -> Parser (LoggerConfig -> LoggerConfig)
forall b a.
FromJSON b =>
Lens' a b -> Text -> Object -> Parser (a -> a)
..: Text
"log_level" (Object -> Parser (LoggerConfig -> LoggerConfig))
-> Object -> Parser (LoggerConfig -> LoggerConfig)
forall a b. (a -> b) -> a -> b
% Object
o
        Parser (LoggerConfig -> LoggerConfig)
-> Parser (LoggerConfig -> LoggerConfig)
-> Parser (LoggerConfig -> LoggerConfig)
forall (f :: * -> *) b c a.
Applicative f =>
f (b -> c) -> f (a -> b) -> f (a -> c)
<*< Lens LoggerConfig LoggerConfig LogScope LogScope
loggerConfigScope Lens LoggerConfig LoggerConfig LogScope LogScope
-> Text -> Object -> Parser (LoggerConfig -> LoggerConfig)
forall b a.
FromJSON b =>
Lens' a b -> Text -> Object -> Parser (a -> a)
..: Text
"scope" (Object -> Parser (LoggerConfig -> LoggerConfig))
-> Object -> Parser (LoggerConfig -> LoggerConfig)
forall a b. (a -> b) -> a -> b
% Object
o
        Parser (LoggerConfig -> LoggerConfig)
-> Parser (LoggerConfig -> LoggerConfig)
-> Parser (LoggerConfig -> LoggerConfig)
forall (f :: * -> *) b c a.
Applicative f =>
f (b -> c) -> f (a -> b) -> f (a -> c)
<*< Lens LoggerConfig LoggerConfig LogPolicy LogPolicy
loggerConfigPolicy Lens LoggerConfig LoggerConfig LogPolicy LogPolicy
-> Text -> Object -> Parser (LoggerConfig -> LoggerConfig)
forall b a.
FromJSON b =>
Lens' a b -> Text -> Object -> Parser (a -> a)
..: Text
"policy" (Object -> Parser (LoggerConfig -> LoggerConfig))
-> Object -> Parser (LoggerConfig -> LoggerConfig)
forall a b. (a -> b) -> a -> b
% Object
o
        Parser (LoggerConfig -> LoggerConfig)
-> Parser (LoggerConfig -> LoggerConfig)
-> Parser (LoggerConfig -> LoggerConfig)
forall (f :: * -> *) b c a.
Applicative f =>
f (b -> c) -> f (a -> b) -> f (a -> c)
<*< Lens LoggerConfig LoggerConfig (Maybe Natural) (Maybe Natural)
loggerConfigExceptionLimit Lens LoggerConfig LoggerConfig (Maybe Natural) (Maybe Natural)
-> Text -> Object -> Parser (LoggerConfig -> LoggerConfig)
forall b a.
FromJSON b =>
Lens' a b -> Text -> Object -> Parser (a -> a)
..: Text
"exception_limit" (Object -> Parser (LoggerConfig -> LoggerConfig))
-> Object -> Parser (LoggerConfig -> LoggerConfig)
forall a b. (a -> b) -> a -> b
% Object
o
        Parser (LoggerConfig -> LoggerConfig)
-> Parser (LoggerConfig -> LoggerConfig)
-> Parser (LoggerConfig -> LoggerConfig)
forall (f :: * -> *) b c a.
Applicative f =>
f (b -> c) -> f (a -> b) -> f (a -> c)
<*< Lens LoggerConfig LoggerConfig (Maybe Natural) (Maybe Natural)
loggerConfigExceptionWait Lens LoggerConfig LoggerConfig (Maybe Natural) (Maybe Natural)
-> Text -> Object -> Parser (LoggerConfig -> LoggerConfig)
forall b a.
FromJSON b =>
Lens' a b -> Text -> Object -> Parser (a -> a)
..: Text
"exception_wait" (Object -> Parser (LoggerConfig -> LoggerConfig))
-> Object -> Parser (LoggerConfig -> LoggerConfig)
forall a b. (a -> b) -> a -> b
% Object
o
        Parser (LoggerConfig -> LoggerConfig)
-> Parser (LoggerConfig -> LoggerConfig)
-> Parser (LoggerConfig -> LoggerConfig)
forall (f :: * -> *) b c a.
Applicative f =>
f (b -> c) -> f (a -> b) -> f (a -> c)
<*< Lens LoggerConfig LoggerConfig (Maybe Natural) (Maybe Natural)
loggerConfigExitTimeout Lens LoggerConfig LoggerConfig (Maybe Natural) (Maybe Natural)
-> Text -> Object -> Parser (LoggerConfig -> LoggerConfig)
forall b a.
FromJSON b =>
Lens' a b -> Text -> Object -> Parser (a -> a)
..: Text
"exit_timeout" (Object -> Parser (LoggerConfig -> LoggerConfig))
-> Object -> Parser (LoggerConfig -> LoggerConfig)
forall a b. (a -> b) -> a -> b
% Object
o

pLoggerConfig ∷ MParser LoggerConfig
pLoggerConfig :: MParser LoggerConfig
pLoggerConfig = Text -> MParser LoggerConfig
pLoggerConfig_ Text
""

-- | A version of 'pLoggerConfig' that takes a prefix for the
-- command line option.
--
-- @since 0.2
--
pLoggerConfig_
    ∷ T.Text
        -- ^ prefix for this and all subordinate command line options.
    → MParser LoggerConfig
pLoggerConfig_ :: Text -> MParser LoggerConfig
pLoggerConfig_ Text
prefix = LoggerConfig -> LoggerConfig
forall a. a -> a
id
    (LoggerConfig -> LoggerConfig)
-> MParser LoggerConfig -> MParser LoggerConfig
forall (f :: * -> *) b c a.
Functor f =>
(b -> c) -> f (a -> b) -> f (a -> c)
<$< Lens LoggerConfig LoggerConfig Natural Natural
loggerConfigQueueSize Lens LoggerConfig LoggerConfig Natural Natural
-> Parser Natural -> MParser LoggerConfig
forall (f :: * -> *) a b.
(Alternative f, Applicative f) =>
Lens' a b -> f b -> f (a -> a)
.:: ReadM Natural -> Mod OptionFields Natural -> Parser Natural
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Natural
forall a. Read a => ReadM a
auto
        (Mod OptionFields Natural -> Parser Natural)
-> Mod OptionFields Natural -> Parser Natural
forall a b. (a -> b) -> a -> b
% String -> Mod OptionFields Natural
forall (f :: * -> *) a. HasName f => String -> Mod f a
long (Text -> String
T.unpack Text
prefix String -> ShowS
forall α. Monoid α => α -> α -> α
⊕ String
"queue-size")
        Mod OptionFields Natural
-> Mod OptionFields Natural -> Mod OptionFields Natural
forall α. Monoid α => α -> α -> α
⊕ String -> Mod OptionFields Natural
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"INT"
        Mod OptionFields Natural
-> Mod OptionFields Natural -> Mod OptionFields Natural
forall α. Monoid α => α -> α -> α
⊕ String -> Mod OptionFields Natural
forall (f :: * -> *) a. String -> Mod f a
help String
"size of the internal logger queue"
    MParser LoggerConfig
-> MParser LoggerConfig -> MParser LoggerConfig
forall (f :: * -> *) b c a.
Applicative f =>
f (b -> c) -> f (a -> b) -> f (a -> c)
<*< Lens LoggerConfig LoggerConfig LogLevel LogLevel
loggerConfigThreshold Lens LoggerConfig LoggerConfig LogLevel LogLevel
-> Parser LogLevel -> MParser LoggerConfig
forall (f :: * -> *) a b.
(Alternative f, Applicative f) =>
Lens' a b -> f b -> f (a -> a)
.:: Text -> Parser LogLevel
pLogLevel_ Text
prefix
    MParser LoggerConfig
-> MParser LoggerConfig -> MParser LoggerConfig
forall (f :: * -> *) b c a.
Applicative f =>
f (b -> c) -> f (a -> b) -> f (a -> c)
<*< Lens LoggerConfig LoggerConfig LogPolicy LogPolicy
loggerConfigPolicy Lens LoggerConfig LoggerConfig LogPolicy LogPolicy
-> Parser LogPolicy -> MParser LoggerConfig
forall (f :: * -> *) a b.
(Alternative f, Applicative f) =>
Lens' a b -> f b -> f (a -> a)
.:: Text -> Parser LogPolicy
pLogPolicy_ Text
prefix
    MParser LoggerConfig
-> MParser LoggerConfig -> MParser LoggerConfig
forall (f :: * -> *) b c a.
Applicative f =>
f (b -> c) -> f (a -> b) -> f (a -> c)
<*< Lens LoggerConfig LoggerConfig (Maybe Natural) (Maybe Natural)
loggerConfigExceptionLimit Lens LoggerConfig LoggerConfig (Maybe Natural) (Maybe Natural)
-> Parser (Maybe Natural) -> MParser LoggerConfig
forall (f :: * -> *) a b.
(Alternative f, Applicative f) =>
Lens' a b -> f b -> f (a -> a)
.:: (Natural -> Maybe Natural)
-> Parser Natural -> Parser (Maybe Natural)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Natural -> Maybe Natural
forall a. a -> Maybe a
Just (Parser Natural -> Parser (Maybe Natural))
-> Parser Natural -> Parser (Maybe Natural)
forall a b. (a -> b) -> a -> b
% ReadM Natural -> Mod OptionFields Natural -> Parser Natural
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Natural
forall a. Read a => ReadM a
auto
        (Mod OptionFields Natural -> Parser Natural)
-> Mod OptionFields Natural -> Parser Natural
forall a b. (a -> b) -> a -> b
% String -> Mod OptionFields Natural
forall (f :: * -> *) a. HasName f => String -> Mod f a
long (Text -> String
T.unpack Text
prefix String -> ShowS
forall α. Monoid α => α -> α -> α
⊕ String
"exception-limit")
        Mod OptionFields Natural
-> Mod OptionFields Natural -> Mod OptionFields Natural
forall α. Monoid α => α -> α -> α
⊕ String -> Mod OptionFields Natural
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"INT"
        Mod OptionFields Natural
-> Mod OptionFields Natural -> Mod OptionFields Natural
forall α. Monoid α => α -> α -> α
⊕ String -> Mod OptionFields Natural
forall (f :: * -> *) a. String -> Mod f a
help String
"maximal number of backend failures before and exception is raised"
    MParser LoggerConfig
-> MParser LoggerConfig -> MParser LoggerConfig
forall (f :: * -> *) b c a.
Applicative f =>
f (b -> c) -> f (a -> b) -> f (a -> c)
<*< Lens LoggerConfig LoggerConfig (Maybe Natural) (Maybe Natural)
loggerConfigExceptionWait Lens LoggerConfig LoggerConfig (Maybe Natural) (Maybe Natural)
-> Parser (Maybe Natural) -> MParser LoggerConfig
forall (f :: * -> *) a b.
(Alternative f, Applicative f) =>
Lens' a b -> f b -> f (a -> a)
.:: (Natural -> Maybe Natural)
-> Parser Natural -> Parser (Maybe Natural)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Natural -> Maybe Natural
forall a. a -> Maybe a
Just (Parser Natural -> Parser (Maybe Natural))
-> Parser Natural -> Parser (Maybe Natural)
forall a b. (a -> b) -> a -> b
% ReadM Natural -> Mod OptionFields Natural -> Parser Natural
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Natural
forall a. Read a => ReadM a
auto
        (Mod OptionFields Natural -> Parser Natural)
-> Mod OptionFields Natural -> Parser Natural
forall a b. (a -> b) -> a -> b
% String -> Mod OptionFields Natural
forall (f :: * -> *) a. HasName f => String -> Mod f a
long (Text -> String
T.unpack Text
prefix String -> ShowS
forall α. Monoid α => α -> α -> α
⊕ String
"exception-wait")
        Mod OptionFields Natural
-> Mod OptionFields Natural -> Mod OptionFields Natural
forall α. Monoid α => α -> α -> α
⊕ String -> Mod OptionFields Natural
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"INT"
        Mod OptionFields Natural
-> Mod OptionFields Natural -> Mod OptionFields Natural
forall α. Monoid α => α -> α -> α
⊕ String -> Mod OptionFields Natural
forall (f :: * -> *) a. String -> Mod f a
help String
"time to wait after an backend failure occured"
    MParser LoggerConfig
-> MParser LoggerConfig -> MParser LoggerConfig
forall (f :: * -> *) b c a.
Applicative f =>
f (b -> c) -> f (a -> b) -> f (a -> c)
<*< Lens LoggerConfig LoggerConfig (Maybe Natural) (Maybe Natural)
loggerConfigExitTimeout Lens LoggerConfig LoggerConfig (Maybe Natural) (Maybe Natural)
-> Parser (Maybe Natural) -> MParser LoggerConfig
forall (f :: * -> *) a b.
(Alternative f, Applicative f) =>
Lens' a b -> f b -> f (a -> a)
.:: (Natural -> Maybe Natural)
-> Parser Natural -> Parser (Maybe Natural)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Natural -> Maybe Natural
forall a. a -> Maybe a
Just (Parser Natural -> Parser (Maybe Natural))
-> Parser Natural -> Parser (Maybe Natural)
forall a b. (a -> b) -> a -> b
% ReadM Natural -> Mod OptionFields Natural -> Parser Natural
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Natural
forall a. Read a => ReadM a
auto
        (Mod OptionFields Natural -> Parser Natural)
-> Mod OptionFields Natural -> Parser Natural
forall a b. (a -> b) -> a -> b
% String -> Mod OptionFields Natural
forall (f :: * -> *) a. HasName f => String -> Mod f a
long (Text -> String
T.unpack Text
prefix String -> ShowS
forall α. Monoid α => α -> α -> α
⊕ String
"exit-timeout")
        Mod OptionFields Natural
-> Mod OptionFields Natural -> Mod OptionFields Natural
forall α. Monoid α => α -> α -> α
⊕ String -> Mod OptionFields Natural
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"INT"
        Mod OptionFields Natural
-> Mod OptionFields Natural -> Mod OptionFields Natural
forall α. Monoid α => α -> α -> α
⊕ String -> Mod OptionFields Natural
forall (f :: * -> *) a. String -> Mod f a
help String
"timeout for flushing the log message queue on exit"

-- -------------------------------------------------------------------------- --
-- Logger
--
-- The logger encapsulates a queue and a background worker that dequeues
-- log-messages and delivers them to a backend action. The opaque logger
-- context is thread safe. But it contains references to mutable state and
-- no copy or derivation of it must be used out-side of it's allocation scope.
--

-- | Interal log message queue.
--
-- The backend function formats and delivers log messages synchronously. In
-- order to not slow down the processing of the main program logic log messages
-- are enqueued and processed asynchronously by a background worker that takes
-- the message from queue and calls the backend function for each log message.
--
#ifdef USE_TBMQUEUE
type LoggerQueue a = TBMQueue (LogMessage a)
#else
type LoggerQueue a = TBMChan (LogMessage a)
#endif
-- type LoggerQueue a = FairTBMQueue (LogMessage a)

data Logger a = Logger
    { Logger a -> LoggerQueue a
_loggerQueue ∷ !(LoggerQueue a)
    , Logger a -> Async ()
_loggerWorker ∷ !(Async ())
    , Logger a -> LogLevel
_loggerThreshold ∷ !LogLevel
    , Logger a -> LogScope
_loggerScope ∷ !LogScope
    , Logger a -> LogPolicy
_loggerPolicy ∷ !LogPolicy
    , Logger a -> IORef Natural
_loggerMissed ∷ !(IORef Natural)
    , Logger a -> Maybe Natural
_loggerExitTimeout ∷ !(Maybe Natural)
    , Logger a -> Text -> IO ()
_loggerErrLogFunction ∷ !(T.Text → IO ())
    }
    deriving (Typeable, (forall x. Logger a -> Rep (Logger a) x)
-> (forall x. Rep (Logger a) x -> Logger a) -> Generic (Logger a)
forall x. Rep (Logger a) x -> Logger a
forall x. Logger a -> Rep (Logger a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Logger a) x -> Logger a
forall a x. Logger a -> Rep (Logger a) x
$cto :: forall a x. Rep (Logger a) x -> Logger a
$cfrom :: forall a x. Logger a -> Rep (Logger a) x
Generic)

loggerThreshold ∷ Lens' (Logger a) LogLevel
loggerThreshold :: (LogLevel -> f LogLevel) -> Logger a -> f (Logger a)
loggerThreshold = (Logger a -> LogLevel)
-> (Logger a -> LogLevel -> Logger a)
-> Lens (Logger a) (Logger a) LogLevel LogLevel
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Logger a -> LogLevel
forall a. Logger a -> LogLevel
_loggerThreshold ((Logger a -> LogLevel -> Logger a)
 -> Lens (Logger a) (Logger a) LogLevel LogLevel)
-> (Logger a -> LogLevel -> Logger a)
-> Lens (Logger a) (Logger a) LogLevel LogLevel
forall a b. (a -> b) -> a -> b
$ \Logger a
a LogLevel
b → Logger a
a { _loggerThreshold :: LogLevel
_loggerThreshold = LogLevel
b }
{-# INLINE loggerThreshold #-}

loggerScope ∷ Lens' (Logger a) LogScope
loggerScope :: (LogScope -> f LogScope) -> Logger a -> f (Logger a)
loggerScope = (Logger a -> LogScope)
-> (Logger a -> LogScope -> Logger a)
-> Lens (Logger a) (Logger a) LogScope LogScope
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Logger a -> LogScope
forall a. Logger a -> LogScope
_loggerScope ((Logger a -> LogScope -> Logger a)
 -> Lens (Logger a) (Logger a) LogScope LogScope)
-> (Logger a -> LogScope -> Logger a)
-> Lens (Logger a) (Logger a) LogScope LogScope
forall a b. (a -> b) -> a -> b
$ \Logger a
a LogScope
b → Logger a
a { _loggerScope :: LogScope
_loggerScope = LogScope
b }
{-# INLINE loggerScope #-}

loggerPolicy ∷ Lens' (Logger a) LogPolicy
loggerPolicy :: (LogPolicy -> f LogPolicy) -> Logger a -> f (Logger a)
loggerPolicy = (Logger a -> LogPolicy)
-> (Logger a -> LogPolicy -> Logger a)
-> Lens (Logger a) (Logger a) LogPolicy LogPolicy
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Logger a -> LogPolicy
forall a. Logger a -> LogPolicy
_loggerPolicy ((Logger a -> LogPolicy -> Logger a)
 -> Lens (Logger a) (Logger a) LogPolicy LogPolicy)
-> (Logger a -> LogPolicy -> Logger a)
-> Lens (Logger a) (Logger a) LogPolicy LogPolicy
forall a b. (a -> b) -> a -> b
$ \Logger a
a LogPolicy
b → Logger a
a { _loggerPolicy :: LogPolicy
_loggerPolicy = LogPolicy
b }
{-# INLINE loggerPolicy #-}

-- | Create a new logger. A logger created with this function must be released
-- with a call to 'releaseLogger' and must not be used after it is released.
--
-- The logger calls the backend function exactly once for each log message. If
-- the backend throws an exception, the message is discarded and the exception
-- is dealt with as follows:
--
-- 1. The exception is logged. First it is attempt to log to the backend itself.
--    If that fails, due to another exception, the incident is logged to an
--    alternate log sink, usually @T.putStrLn@ or just @const (return ())@.
--
-- 2. The message is discarded. If the backend exception is of type
--    'BackendTerminatedException' the exception is rethrown by the logger which
--    causes the logger to exit. Otherwise the exception is appended to the
--    exception list.
--
-- 3. If the length of the exception list exceeds a configurable threshold
--    a 'BackendTooManyExceptions' exception is thrown (which causes the logger
--    to terminate).
--
-- 4. Otherwise the logger waits for a configurable amount of time before
--    proceeding.
--
-- 5. The next time the backend returns without throwing an exception the
--    exception list is reset to @[]@.
--
-- Backends are expected to implement there own retry logic if required.
-- Backends may base their behavoir on the 'LogPolicy' that is effective for a
-- given message. Please refer to the documentation of 'LoggerBackend' for
-- more details about how to implement and backend.
--
-- Backends are called synchronously. Backends authors must thus ensure that a
-- backend returns promptly in accordance with the 'LogPolicy' and the size of
-- the logger queue. For more elaborate failover strategies, such as batching
-- retried messages with the delivery of new messages, backends may implement
-- there only internal queue.
--
-- Exceptions of type 'BlockedIndefinitelyOnSTM' and 'NestedAtomically' are
-- rethrown immediately. Those exceptions indicate a bug in the code due to
-- unsafe usage of 'createLogger'. This exceptions shouldn't be possible when
-- 'withLogger' is used to provide the logger and the reference to the
-- logger isn't used outside the scope of the bracket.
--
createLogger
    ∷ MonadIO μ
    ⇒ LoggerConfig
    → LoggerBackend a
    → μ (Logger a)
createLogger :: LoggerConfig -> LoggerBackend a -> μ (Logger a)
createLogger = (Text -> IO ()) -> LoggerConfig -> LoggerBackend a -> μ (Logger a)
forall (μ :: * -> *) a.
MonadIO μ =>
(Text -> IO ()) -> LoggerConfig -> LoggerBackend a -> μ (Logger a)
createLogger_ (Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr)

-- | A version of 'createLogger' that takes as an extra argument
-- a function for logging errors in the logging system.
--
-- @since 0.2
--
createLogger_
    ∷ MonadIO μ
    ⇒ (T.Text → IO ())
        -- ^ alternate sink for logging exceptions in the logger itself.
    → LoggerConfig
    → LoggerBackend a
    → μ (Logger a)
createLogger_ :: (Text -> IO ()) -> LoggerConfig -> LoggerBackend a -> μ (Logger a)
createLogger_ Text -> IO ()
errLogFun LoggerConfig{Natural
LogScope
Maybe Natural
LogPolicy
LogLevel
_loggerConfigExitTimeout :: Maybe Natural
_loggerConfigExceptionWait :: Maybe Natural
_loggerConfigExceptionLimit :: Maybe Natural
_loggerConfigPolicy :: LogPolicy
_loggerConfigScope :: LogScope
_loggerConfigThreshold :: LogLevel
_loggerConfigQueueSize :: Natural
_loggerConfigExitTimeout :: LoggerConfig -> Maybe Natural
_loggerConfigExceptionWait :: LoggerConfig -> Maybe Natural
_loggerConfigExceptionLimit :: LoggerConfig -> Maybe Natural
_loggerConfigPolicy :: LoggerConfig -> LogPolicy
_loggerConfigScope :: LoggerConfig -> LogScope
_loggerConfigThreshold :: LoggerConfig -> LogLevel
_loggerConfigQueueSize :: LoggerConfig -> Natural
..} LoggerBackend a
backend = IO (Logger a) -> μ (Logger a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Logger a) -> μ (Logger a)) -> IO (Logger a) -> μ (Logger a)
forall a b. (a -> b) -> a -> b
$ do
    LoggerQueue a
queue ← Natural -> IO (LoggerQueue a)
forall q a. BoundedCloseableQueue q a => Natural -> IO q
newQueue (Natural -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
_loggerConfigQueueSize)
    IORef Natural
missed ← Natural -> IO (IORef Natural)
forall a. a -> IO (IORef a)
newIORef Natural
0
    Async ()
worker ← (Text -> IO ())
-> Maybe Natural
-> Maybe Natural
-> LoggerBackend a
-> LoggerQueue a
-> IORef Natural
-> IO (Async ())
forall a.
(Text -> IO ())
-> Maybe Natural
-> Maybe Natural
-> LoggerBackend a
-> LoggerQueue a
-> IORef Natural
-> IO (Async ())
backendWorker Text -> IO ()
errLogFun Maybe Natural
_loggerConfigExceptionLimit Maybe Natural
_loggerConfigExceptionWait LoggerBackend a
backend LoggerQueue a
queue IORef Natural
missed
    -- we link the worker to the calling thread. This way all exception from
    -- the logger are rethrown. This includes asynchronous exceptions, but
    -- since the constructors of 'Logger' are not exported no external
    -- code could throw an asynchronous exception to this thread.
    Async () -> IO ()
forall a. Async a -> IO ()
link Async ()
worker
    Logger a -> IO (Logger a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Logger a -> IO (Logger a)) -> Logger a -> IO (Logger a)
forall a b. (a -> b) -> a -> b
$ Logger :: forall a.
LoggerQueue a
-> Async ()
-> LogLevel
-> LogScope
-> LogPolicy
-> IORef Natural
-> Maybe Natural
-> (Text -> IO ())
-> Logger a
Logger
        { _loggerQueue :: LoggerQueue a
_loggerQueue = LoggerQueue a
queue
        , _loggerWorker :: Async ()
_loggerWorker = Async ()
worker
        , _loggerThreshold :: LogLevel
_loggerThreshold = LogLevel
_loggerConfigThreshold
        , _loggerScope :: LogScope
_loggerScope = LogScope
_loggerConfigScope
        , _loggerPolicy :: LogPolicy
_loggerPolicy = LogPolicy
_loggerConfigPolicy
        , _loggerMissed :: IORef Natural
_loggerMissed = IORef Natural
missed
        , _loggerExitTimeout :: Maybe Natural
_loggerExitTimeout = Maybe Natural
_loggerConfigExitTimeout
        , _loggerErrLogFunction :: Text -> IO ()
_loggerErrLogFunction = Text -> IO ()
errLogFun
        }

-- | A backend worker.
--
-- The only way for this function to exit without an exception is when
-- the internal logger queue is closed through a call to 'releaseLogger'.
--
backendWorker
    ∷ (T.Text → IO ())
        -- ^ alternate sink for logging exceptions in the logger itself.
    → Maybe Natural
        -- ^ number of consecutive backend exception that can occur before the logger
        -- raises an 'BackendTooManyExceptions' exception. If this is 'Nothing'
        -- the logger will discard all exceptions. For instance a value of @1@
        -- means that an exception is raised when the second exception occurs.
        -- A value of @0@ means that an exception is raised for each exception.
    → Maybe Natural
        -- ^ number of microseconds to wait after an exception from the backend.
        -- If this is 'Nothing' the logger won't wait at all after an exception.
    → LoggerBackend a
    → LoggerQueue a
    → IORef Natural
    → IO (Async ())
backendWorker :: (Text -> IO ())
-> Maybe Natural
-> Maybe Natural
-> LoggerBackend a
-> LoggerQueue a
-> IORef Natural
-> IO (Async ())
backendWorker Text -> IO ()
errLogFun Maybe Natural
errLimit Maybe Natural
errWait LoggerBackend a
backend LoggerQueue a
queue IORef Natural
missed = IO (Async ()) -> IO (Async ())
forall (m :: * -> *) a. MonadBaseControl IO m => m a -> m a
mask_ (IO (Async ()) -> IO (Async ())) -> IO (Async ()) -> IO (Async ())
forall a b. (a -> b) -> a -> b
$
    ((forall b. IO b -> IO b) -> IO ()) -> IO (Async ())
forall a. ((forall b. IO b -> IO b) -> IO a) -> IO (Async a)
asyncWithUnmask (((forall b. IO b -> IO b) -> IO ()) -> IO (Async ()))
-> ((forall b. IO b -> IO b) -> IO ()) -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ \forall b. IO b -> IO b
umask → IO () -> IO ()
forall b. IO b -> IO b
umask ([SomeException] -> IO ()
go []) IO () -> (LoggerKilled -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(LoggerKilled
_ ∷ LoggerKilled) → () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where

    -- we assume that 'BlockedIndefinitelyOnSTM' and 'NestedAtomically' are the
    -- only exceptions beside asynchronous exceptions that can be thrown by
    -- @atomically readMsg@.
    --
    go :: [SomeException] -> IO ()
go [SomeException]
errList = do
        -- That's not ideal since we generally don't know how long we have to wait.
        -- But here it's OK, since the time is used in case there are discarded
        -- messages. We don't expect to wait long in that case.
        TimeSpec
t ← Clock -> IO TimeSpec
getTime Clock
Realtime
        TimeSpec -> IO (Maybe (Either (LogMessage Text) (LogMessage a)))
readMsg TimeSpec
t IO (Maybe (Either (LogMessage Text) (LogMessage a)))
-> (Maybe (Either (LogMessage Text) (LogMessage a)) -> IO ())
-> IO ()
forall (m :: * -> *) α β. Monad m => m α -> (α -> m β) -> m β
≫= \case

            -- When the queue is closed and empty the backendWorker returns.
            -- This is the only way for backendWorker to exit without an exception.
            Maybe (Either (LogMessage Text) (LogMessage a))
Nothing → () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

            -- call backend for the message and loop
            Just Either (LogMessage Text) (LogMessage a)
msg → [SomeException]
-> Either (LogMessage Text) (LogMessage a) -> IO [SomeException]
runBackend [SomeException]
errList Either (LogMessage Text) (LogMessage a)
msg IO [SomeException] -> ([SomeException] -> IO ()) -> IO ()
forall (m :: * -> *) α β. Monad m => m α -> (α -> m β) -> m β
≫= [SomeException] -> IO ()
go

    runBackend :: [SomeException]
-> Either (LogMessage Text) (LogMessage a) -> IO [SomeException]
runBackend [SomeException]
errList Either (LogMessage Text) (LogMessage a)
msg = (LoggerBackend a
backend Either (LogMessage Text) (LogMessage a)
msg IO () -> IO [SomeException] -> IO [SomeException]
forall (m :: * -> *) α β. Monad m => m α -> m β -> m β
≫ [SomeException] -> IO [SomeException]
forall (m :: * -> *) a. Monad m => a -> m a
return []) IO [SomeException]
-> (SomeException -> IO [SomeException]) -> IO [SomeException]
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
e → do

        -- try to log exception to backend
        TimeSpec
t ← Clock -> IO TimeSpec
getTime Clock
Realtime
        let errMsg :: LogMessage Text
errMsg = TimeSpec -> Text -> LogMessage Text
forall a. TimeSpec -> a -> LogMessage a
backendErrorMsg TimeSpec
t (SomeException -> Text
forall a b. (Show a, IsString b) => a -> b
sshow SomeException
e)
        LoggerBackend a
backend (LogMessage Text -> Either (LogMessage Text) (LogMessage a)
forall a b. a -> Either a b
Left LogMessage Text
errMsg) IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
_ →
            -- log exception to alternate sink
            Text -> IO ()
errLogFun (LogMessage Text -> Text
errLogMsg LogMessage Text
errMsg) IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
_ →
                -- discard exception log
                () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        -- decide how to proceed in case of an error
        case SomeException -> Maybe (LoggerException Void)
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
            Just (BackendTerminatedException SomeException
_ ∷ LoggerException Void) → SomeException -> IO [SomeException]
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO SomeException
e
            Maybe (LoggerException Void)
_ → do
                IO () -> (Natural -> IO ()) -> Maybe Natural -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Int -> IO ()
threadDelay (Int -> IO ()) -> (Natural -> Int) -> Natural -> IO ()
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) Maybe Natural
errWait
                let errList' :: [SomeException]
errList' = SomeException
eSomeException -> [SomeException] -> [SomeException]
forall a. a -> [a] -> [a]
:[SomeException]
errList
                case Maybe Natural
errLimit of
                    Maybe Natural
Nothing → [SomeException] -> IO [SomeException]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                    Just Natural
n
                        | Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([SomeException] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SomeException]
errList') Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
n → LoggerException Void -> IO [SomeException]
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO (LoggerException Void -> IO [SomeException])
-> LoggerException Void -> IO [SomeException]
forall a b. (a -> b) -> a -> b
$ [SomeException] -> LoggerException Void
BackendTooManyExceptions ([SomeException] -> [SomeException]
forall a. [a] -> [a]
reverse [SomeException]
errList')
                        | Bool
otherwise → [SomeException] -> IO [SomeException]
forall (m :: * -> *) a. Monad m => a -> m a
return [SomeException]
errList'

    -- As long as the queue is not closed and empty this retries until
    -- a new message arrives
    --
    readMsg :: TimeSpec -> IO (Maybe (Either (LogMessage Text) (LogMessage a)))
readMsg TimeSpec
t = do
        Natural
n ← IORef Natural -> Natural -> IO Natural
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Natural
missed Natural
0
        if Natural
n Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
0
          then do
            Maybe (Either (LogMessage Text) (LogMessage a))
-> IO (Maybe (Either (LogMessage Text) (LogMessage a)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either (LogMessage Text) (LogMessage a))
 -> IO (Maybe (Either (LogMessage Text) (LogMessage a))))
-> (LogMessage Text
    -> Maybe (Either (LogMessage Text) (LogMessage a)))
-> LogMessage Text
-> IO (Maybe (Either (LogMessage Text) (LogMessage a)))
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ Either (LogMessage Text) (LogMessage a)
-> Maybe (Either (LogMessage Text) (LogMessage a))
forall a. a -> Maybe a
Just (Either (LogMessage Text) (LogMessage a)
 -> Maybe (Either (LogMessage Text) (LogMessage a)))
-> (LogMessage Text -> Either (LogMessage Text) (LogMessage a))
-> LogMessage Text
-> Maybe (Either (LogMessage Text) (LogMessage a))
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ LogMessage Text -> Either (LogMessage Text) (LogMessage a)
forall a b. a -> Either a b
Left (LogMessage Text
 -> IO (Maybe (Either (LogMessage Text) (LogMessage a))))
-> LogMessage Text
-> IO (Maybe (Either (LogMessage Text) (LogMessage a)))
forall a b. (a -> b) -> a -> b
$ TimeSpec -> Natural -> LogMessage Text
forall a a.
(Monoid a, IsString a, Show a) =>
TimeSpec -> a -> LogMessage a
discardMsg TimeSpec
t Natural
n
          else
            (LogMessage a -> Either (LogMessage Text) (LogMessage a))
-> Maybe (LogMessage a)
-> Maybe (Either (LogMessage Text) (LogMessage a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LogMessage a -> Either (LogMessage Text) (LogMessage a)
forall a b. b -> Either a b
Right (Maybe (LogMessage a)
 -> Maybe (Either (LogMessage Text) (LogMessage a)))
-> IO (Maybe (LogMessage a))
-> IO (Maybe (Either (LogMessage Text) (LogMessage a)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LoggerQueue a -> IO (Maybe (LogMessage a))
forall q a. BoundedCloseableQueue q a => q -> IO (Maybe a)
readQueue LoggerQueue a
queue

    -- A log message that informs about discarded log messages
    discardMsg :: TimeSpec -> a -> LogMessage a
discardMsg TimeSpec
t a
n = LogMessage :: forall a. a -> LogLevel -> LogScope -> TimeSpec -> LogMessage a
LogMessage
        { _logMsg :: a
_logMsg = a
"discarded " a -> a -> a
forall α. Monoid α => α -> α -> α
⊕ a -> a
forall a b. (Show a, IsString b) => a -> b
sshow a
n a -> a -> a
forall α. Monoid α => α -> α -> α
⊕ a
" log messages"
        , _logMsgLevel :: LogLevel
_logMsgLevel = LogLevel
Warn
        , _logMsgScope :: LogScope
_logMsgScope = [(Text
"system", Text
"logger")]
        , _logMsgTime :: TimeSpec
_logMsgTime = TimeSpec
t
        }

    -- A log message that informs about an error in the backend
    backendErrorMsg :: TimeSpec -> a -> LogMessage a
backendErrorMsg TimeSpec
t a
e = LogMessage :: forall a. a -> LogLevel -> LogScope -> TimeSpec -> LogMessage a
LogMessage
        { _logMsg :: a
_logMsg = a
e
        , _logMsgLevel :: LogLevel
_logMsgLevel = LogLevel
Error
        , _logMsgScope :: LogScope
_logMsgScope = [(Text
"system", Text
"logger"), (Text
"component", Text
"backend")]
        , _logMsgTime :: TimeSpec
_logMsgTime = TimeSpec
t
        }

    -- format a log message that is written to the error sink
    errLogMsg :: LogMessage Text -> Text
errLogMsg LogMessage{LogScope
Text
TimeSpec
LogLevel
_logMsgTime :: TimeSpec
_logMsgScope :: LogScope
_logMsgLevel :: LogLevel
_logMsg :: Text
_logMsgTime :: forall a. LogMessage a -> TimeSpec
_logMsgScope :: forall a. LogMessage a -> LogScope
_logMsgLevel :: forall a. LogMessage a -> LogLevel
_logMsg :: forall a. LogMessage a -> a
..} = [Text] -> Text
T.unwords
        [ TimeSpec -> Text
forall a. IsString a => TimeSpec -> a
formatIso8601Milli TimeSpec
_logMsgTime
        , Text
"[" Text -> Text -> Text
forall α. Monoid α => α -> α -> α
⊕ LogLevel -> Text
forall a. IsString a => LogLevel -> a
logLevelText LogLevel
_logMsgLevel Text -> Text -> Text
forall α. Monoid α => α -> α -> α
⊕ Text
"]"
        , LogScope -> Text
formatScope LogScope
_logMsgScope
        , Text
_logMsg
        ]

    formatScope :: LogScope -> Text
formatScope LogScope
scope = Text
"[" Text -> Text -> Text
forall α. Monoid α => α -> α -> α
⊕ Text -> [Text] -> Text
T.intercalate Text
"," (((Text, Text) -> Text) -> LogScope -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Text
forall α. (Monoid α, IsString α) => (α, α) -> α
formatLabel LogScope
scope) Text -> Text -> Text
forall α. Monoid α => α -> α -> α
⊕ Text
"]"
    formatLabel :: (α, α) -> α
formatLabel (α
k,α
v) = α
"(" α -> α -> α
forall α. Monoid α => α -> α -> α
⊕ α
k α -> α -> α
forall α. Monoid α => α -> α -> α
⊕ α
"," α -> α -> α
forall α. Monoid α => α -> α -> α
⊕ α
v α -> α -> α
forall α. Monoid α => α -> α -> α
⊕ α
")"

-- | An Exception that is used internally to kill the logger without killing
-- the calling thread.
--
-- In 'createLogger' the worker 'Async' is 'link'ed to the calling
-- thread. Thus, when 'releaseLogger' calls 'cancel' on that 'Async'
-- the 'ThreadKilled' exception would be rethrown and kill the thread that
-- called 'cancel'.
--
data LoggerKilled = LoggerKilled deriving (Int -> LoggerKilled -> ShowS
[LoggerKilled] -> ShowS
LoggerKilled -> String
(Int -> LoggerKilled -> ShowS)
-> (LoggerKilled -> String)
-> ([LoggerKilled] -> ShowS)
-> Show LoggerKilled
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LoggerKilled] -> ShowS
$cshowList :: [LoggerKilled] -> ShowS
show :: LoggerKilled -> String
$cshow :: LoggerKilled -> String
showsPrec :: Int -> LoggerKilled -> ShowS
$cshowsPrec :: Int -> LoggerKilled -> ShowS
Show, Typeable)
instance Exception LoggerKilled

releaseLogger
    ∷ MonadIO μ
    ⇒ Logger a
    → μ ()
releaseLogger :: Logger a -> μ ()
releaseLogger Logger{LogScope
Maybe Natural
Async ()
IORef Natural
LoggerQueue a
LogPolicy
LogLevel
Text -> IO ()
_loggerErrLogFunction :: Text -> IO ()
_loggerExitTimeout :: Maybe Natural
_loggerMissed :: IORef Natural
_loggerPolicy :: LogPolicy
_loggerScope :: LogScope
_loggerThreshold :: LogLevel
_loggerWorker :: Async ()
_loggerQueue :: LoggerQueue a
_loggerErrLogFunction :: forall a. Logger a -> Text -> IO ()
_loggerExitTimeout :: forall a. Logger a -> Maybe Natural
_loggerMissed :: forall a. Logger a -> IORef Natural
_loggerPolicy :: forall a. Logger a -> LogPolicy
_loggerScope :: forall a. Logger a -> LogScope
_loggerThreshold :: forall a. Logger a -> LogLevel
_loggerWorker :: forall a. Logger a -> Async ()
_loggerQueue :: forall a. Logger a -> LoggerQueue a
..} = IO () -> μ ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> μ ()) -> IO () -> μ ()
forall a b. (a -> b) -> a -> b
$ do
    LoggerQueue a -> IO ()
forall q a. BoundedCloseableQueue q a => q -> IO ()
closeQueue LoggerQueue a
_loggerQueue
    Maybe ()
complete ← (IO () -> IO (Maybe ()))
-> (Natural -> IO () -> IO (Maybe ()))
-> Maybe Natural
-> IO ()
-> IO (Maybe ())
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((() -> Maybe ()) -> IO () -> IO (Maybe ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap () -> Maybe ()
forall a. a -> Maybe a
Just) (Int -> IO () -> IO (Maybe ())
forall a. Int -> IO a -> IO (Maybe a)
timeout (Int -> IO () -> IO (Maybe ()))
-> (Natural -> Int) -> Natural -> IO () -> IO (Maybe ())
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) Maybe Natural
_loggerExitTimeout (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ Async () -> IO ()
forall a. Async a -> IO a
wait Async ()
_loggerWorker
    case Maybe ()
complete of
        Maybe ()
Nothing → Text -> IO ()
_loggerErrLogFunction Text
"logger: timeout while flushing queue; remaining messages are discarded"
        Just ()
_ → () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Async () -> LoggerKilled -> IO ()
forall e a. Exception e => Async a -> e -> IO ()
cancelWith Async ()
_loggerWorker LoggerKilled
LoggerKilled

-- | Provide a computation with a 'Logger'.
--
-- Here is an example how this can be used to run a computation
-- with a 'MonadLog' constraint:
--
-- > withConsoleLogger
-- >     ∷ (MonadIO m, MonadBaseControl IO m)
-- >     ⇒ LogLevel
-- >     → LoggerT T.Text m α
-- >     → m α
-- > withConsoleLogger level inner = do
-- >    withHandleBackend (config ^. logConfigBackend) $ \backend →
-- >        withLogger (config ^. logConfigLogger) backend $ runLoggerT inner
-- >  where
-- >    config = defaultLogConfig
-- >        & logConfigLogger ∘ loggerConfigThreshold .~ level
--
-- For detailed information about how backends are executed refer
-- to the documentation of 'createLogger'.
--
withLogger
    ∷ (MonadIO μ, MonadBaseControl IO μ)
    ⇒ LoggerConfig
    → LoggerBackend a
    → (Logger a → μ α)
    → μ α
withLogger :: LoggerConfig -> LoggerBackend a -> (Logger a -> μ α) -> μ α
withLogger = (Text -> IO ())
-> LoggerConfig -> LoggerBackend a -> (Logger a -> μ α) -> μ α
forall (μ :: * -> *) a α.
(MonadIO μ, MonadBaseControl IO μ) =>
(Text -> IO ())
-> LoggerConfig -> LoggerBackend a -> (Logger a -> μ α) -> μ α
withLogger_ (Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr)

-- | A version of 'withLogger' that takes as an extra argument
-- a function for logging errors in the logging system.
--
-- @since 0.2
--
withLogger_
    ∷ (MonadIO μ, MonadBaseControl IO μ)
    ⇒ (T.Text → IO ())
        -- ^ alternate sink for logging exceptions in the logger itself.
    → LoggerConfig
    → LoggerBackend a
    → (Logger a → μ α)
    → μ α
withLogger_ :: (Text -> IO ())
-> LoggerConfig -> LoggerBackend a -> (Logger a -> μ α) -> μ α
withLogger_ Text -> IO ()
errLogFun LoggerConfig
config LoggerBackend a
backend =
    μ (Logger a) -> (Logger a -> μ ()) -> (Logger a -> μ α) -> μ α
forall (m :: * -> *) a b c.
MonadBaseControl IO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket ((Text -> IO ()) -> LoggerConfig -> LoggerBackend a -> μ (Logger a)
forall (μ :: * -> *) a.
MonadIO μ =>
(Text -> IO ()) -> LoggerConfig -> LoggerBackend a -> μ (Logger a)
createLogger_ Text -> IO ()
errLogFun LoggerConfig
config LoggerBackend a
backend) Logger a -> μ ()
forall (μ :: * -> *) a. MonadIO μ => Logger a -> μ ()
releaseLogger

-- | For simple cases, when the logger threshold and the logger scope is
-- constant this function can be used to directly initialize a log function.
--
withLogFunction
    ∷ (Show a, Typeable a, NFData a, MonadIO μ, MonadBaseControl IO μ)
    ⇒ LoggerConfig
    → LoggerBackend a
    → (LogFunctionIO a → μ α)
    → μ α
withLogFunction :: LoggerConfig -> LoggerBackend a -> (LogFunctionIO a -> μ α) -> μ α
withLogFunction = (Text -> IO ())
-> LoggerConfig
-> LoggerBackend a
-> (LogFunctionIO a -> μ α)
-> μ α
forall a (μ :: * -> *) α.
(Show a, Typeable a, NFData a, MonadIO μ, MonadBaseControl IO μ) =>
(Text -> IO ())
-> LoggerConfig
-> LoggerBackend a
-> (LogFunctionIO a -> μ α)
-> μ α
withLogFunction_ (Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr)

-- | For simple cases, when the logger threshold and the logger scope is
-- constant this function can be used to directly initialize a log function.
--
-- @since 0.2
--
withLogFunction_
    ∷ (Show a, Typeable a, NFData a, MonadIO μ, MonadBaseControl IO μ)
    ⇒ (T.Text → IO ())
        -- ^ alternate sink for logging exceptions in the logger itself.
    → LoggerConfig
    → LoggerBackend a
    → (LogFunctionIO a → μ α)
    → μ α
withLogFunction_ :: (Text -> IO ())
-> LoggerConfig
-> LoggerBackend a
-> (LogFunctionIO a -> μ α)
-> μ α
withLogFunction_ Text -> IO ()
errLogFun LoggerConfig
config LoggerBackend a
backend LogFunctionIO a -> μ α
f =
    (Text -> IO ())
-> LoggerConfig -> LoggerBackend a -> (Logger a -> μ α) -> μ α
forall (μ :: * -> *) a α.
(MonadIO μ, MonadBaseControl IO μ) =>
(Text -> IO ())
-> LoggerConfig -> LoggerBackend a -> (Logger a -> μ α) -> μ α
withLogger_ Text -> IO ()
errLogFun LoggerConfig
config LoggerBackend a
backend ((Logger a -> μ α) -> μ α) -> (Logger a -> μ α) -> μ α
forall a b. (a -> b) -> a -> b
$ LogFunctionIO a -> μ α
f (LogFunctionIO a -> μ α)
-> (Logger a -> LogFunctionIO a) -> Logger a -> μ α
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ Logger a -> LogFunctionIO a
forall a.
(Show a, Typeable a, NFData a) =>
Logger a -> LogFunctionIO a
loggCtx

-- -------------------------------------------------------------------------- --
-- Log Function

-- Log a message with the given logger context
--
-- If the logger context has been released (by closing the queue)
-- this function has not effect.
--
loggCtx
    ∷ (Show a, Typeable a, NFData a)
    ⇒ Logger a
    → LogFunctionIO a
loggCtx :: Logger a -> LogFunctionIO a
loggCtx Logger{LogScope
Maybe Natural
Async ()
IORef Natural
LoggerQueue a
LogPolicy
LogLevel
Text -> IO ()
_loggerErrLogFunction :: Text -> IO ()
_loggerExitTimeout :: Maybe Natural
_loggerMissed :: IORef Natural
_loggerPolicy :: LogPolicy
_loggerScope :: LogScope
_loggerThreshold :: LogLevel
_loggerWorker :: Async ()
_loggerQueue :: LoggerQueue a
_loggerErrLogFunction :: forall a. Logger a -> Text -> IO ()
_loggerExitTimeout :: forall a. Logger a -> Maybe Natural
_loggerMissed :: forall a. Logger a -> IORef Natural
_loggerPolicy :: forall a. Logger a -> LogPolicy
_loggerScope :: forall a. Logger a -> LogScope
_loggerThreshold :: forall a. Logger a -> LogLevel
_loggerWorker :: forall a. Logger a -> Async ()
_loggerQueue :: forall a. Logger a -> LoggerQueue a
..} LogLevel
level a
msg = do
    case LogLevel
_loggerThreshold of
        LogLevel
Quiet → () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        LogLevel
threshold
            | LogLevel
level LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
≤ LogLevel
threshold → IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                TimeSpec
t ← Clock -> IO TimeSpec
getTime Clock
Realtime
                LogMessage a -> IO ()
writeWithLogPolicy (LogMessage a -> IO ()) -> LogMessage a -> IO ()
forall a b. NFData a => (a -> b) -> a -> b
$!! LogMessage :: forall a. a -> LogLevel -> LogScope -> TimeSpec -> LogMessage a
LogMessage
                    { _logMsg :: a
_logMsg = a
msg
                    , _logMsgLevel :: LogLevel
_logMsgLevel = LogLevel
level
                    , _logMsgScope :: LogScope
_logMsgScope = LogScope
_loggerScope
                    , _logMsgTime :: TimeSpec
_logMsgTime = TimeSpec
t
                    }
            | Bool
otherwise → () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    writeWithLogPolicy :: LogMessage a -> IO ()
writeWithLogPolicy !LogMessage a
lmsg
        | LogPolicy
_loggerPolicy LogPolicy -> LogPolicy -> Bool
forall α. Eq α => α -> α -> Bool
≡ LogPolicy
LogPolicyBlock = IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ LoggerQueue a -> LogMessage a -> IO Bool
forall q a. BoundedCloseableQueue q a => q -> a -> IO Bool
writeQueue LoggerQueue a
_loggerQueue LogMessage a
lmsg
        | Bool
otherwise = LoggerQueue a -> LogMessage a -> IO (Maybe Bool)
forall q a. BoundedCloseableQueue q a => q -> a -> IO (Maybe Bool)
tryWriteQueue LoggerQueue a
_loggerQueue LogMessage a
lmsg IO (Maybe Bool) -> (Maybe Bool -> IO ()) -> IO ()
forall (m :: * -> *) α β. Monad m => m α -> (α -> m β) -> m β
≫= \case
            -- Success
            Just Bool
True → () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            -- Queue is closed
            Just Bool
False → () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            -- Queue is full
            Maybe Bool
Nothing
                | LogPolicy
_loggerPolicy LogPolicy -> LogPolicy -> Bool
forall α. Eq α => α -> α -> Bool
≡ LogPolicy
LogPolicyDiscard → IORef Natural -> (Natural -> (Natural, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Natural
_loggerMissed (\Natural
x → (Natural
x Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1, ()))
                | LogPolicy
_loggerPolicy LogPolicy -> LogPolicy -> Bool
forall α. Eq α => α -> α -> Bool
≡ LogPolicy
LogPolicyRaise → LoggerException a -> IO ()
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO (LoggerException a -> IO ()) -> LoggerException a -> IO ()
forall a b. (a -> b) -> a -> b
$ LogMessage a -> LoggerException a
forall a. LogMessage a -> LoggerException a
QueueFullException LogMessage a
lmsg
                | Bool
otherwise → () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- won't happen, covered above.
{-# INLINEABLE loggCtx #-}

-- -------------------------------------------------------------------------- --
-- Logger Instance

instance LoggerCtx (Logger a) a where
    loggerFunIO :: Logger a -> LogFunctionIO a
loggerFunIO = Logger a -> LogFunctionIO a
forall a.
(Show a, Typeable a, NFData a) =>
Logger a -> LogFunctionIO a
loggCtx
    setLoggerLevel :: (LogLevel -> f LogLevel) -> Logger a -> f (Logger a)
setLoggerLevel = (LogLevel -> f LogLevel) -> Logger a -> f (Logger a)
forall a. Lens' (Logger a) LogLevel
loggerThreshold
    setLoggerScope :: (LogScope -> f LogScope) -> Logger a -> f (Logger a)
setLoggerScope = (LogScope -> f LogScope) -> Logger a -> f (Logger a)
forall a. Lens' (Logger a) LogScope
loggerScope
    setLoggerPolicy :: (LogPolicy -> f LogPolicy) -> Logger a -> f (Logger a)
setLoggerPolicy = (LogPolicy -> f LogPolicy) -> Logger a -> f (Logger a)
forall a. Lens' (Logger a) LogPolicy
loggerPolicy

-- -------------------------------------------------------------------------- --
-- LoggerT

type LoggerT a = LoggerCtxT (Logger a)

runLoggerT ∷ LoggerT a m α → Logger a → m α
runLoggerT :: LoggerT a m α -> Logger a -> m α
runLoggerT = LoggerT a m α -> Logger a -> m α
forall ctx (m :: * -> *) α. LoggerCtxT ctx m α -> ctx -> m α
runLoggerCtxT
{-# INLINE runLoggerT #-}

-- | Convenience function that unwraps a 'MonadLog' computation over
-- a newly created 'Logger'
--
runLogT
    ∷ (MonadBaseControl IO m, MonadIO m)
    ⇒ LoggerConfig
    → LoggerBackend msg
    → LoggerT msg m α
    → m α
runLogT :: LoggerConfig -> LoggerBackend msg -> LoggerT msg m α -> m α
runLogT LoggerConfig
config LoggerBackend msg
backend = LoggerConfig -> LoggerBackend msg -> (Logger msg -> m α) -> m α
forall (μ :: * -> *) a α.
(MonadIO μ, MonadBaseControl IO μ) =>
LoggerConfig -> LoggerBackend a -> (Logger a -> μ α) -> μ α
withLogger LoggerConfig
config LoggerBackend msg
backend ((Logger msg -> m α) -> m α)
-> (LoggerT msg m α -> Logger msg -> m α) -> LoggerT msg m α -> m α
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ LoggerT msg m α -> Logger msg -> m α
forall a (m :: * -> *) α. LoggerT a m α -> Logger a -> m α
runLoggerT

-- -------------------------------------------------------------------------- --
-- Tools

{-
-- | Log all errors that are in current error trace and reset the trace
-- to a single short summary message.
--
logErrorsG
    ∷ MonadIO μ
    ⇒ LogLevel
    → T.Text
    → ExceptT [T.Text] μ α
    → ExceptT [T.Text] μ α
logErrorsG level label p = p `catchError` \e → do
    loggG level $ label ⊕ " failed: "  ⊕ T.intercalate " <|> " e
    throwError [label ⊕ " failed"]
-}