-- 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 (void)
import Control.Monad.IO.Class
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
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]
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
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
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
Ord, Typeable, 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 :: Lens' LoggerConfig Natural
loggerConfigQueueSize = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens LoggerConfig -> Natural
_loggerConfigQueueSize forall a b. (a -> b) -> a -> b
$ \LoggerConfig
a Natural
b → LoggerConfig
a { _loggerConfigQueueSize :: Natural
_loggerConfigQueueSize = Natural
b }

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

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

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

loggerConfigExceptionLimit ∷ Lens' LoggerConfig (Maybe Natural)
loggerConfigExceptionLimit :: Lens' LoggerConfig (Maybe Natural)
loggerConfigExceptionLimit = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens LoggerConfig -> Maybe Natural
_loggerConfigExceptionLimit 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 :: Lens' LoggerConfig (Maybe Natural)
loggerConfigExceptionWait = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens LoggerConfig -> Maybe Natural
_loggerConfigExceptionWait 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 :: Lens' LoggerConfig (Maybe Natural)
loggerConfigExitTimeout = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens LoggerConfig -> Maybe Natural
_loggerConfigExitTimeout 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
    { _loggerConfigQueueSize :: Natural
_loggerConfigQueueSize = Natural
1000
    , _loggerConfigThreshold :: LogLevel
_loggerConfigThreshold = LogLevel
Warn
    , _loggerConfigScope :: LogScope
_loggerConfigScope = []
    , _loggerConfigPolicy :: LogPolicy
_loggerConfigPolicy = LogPolicy
LogPolicyDiscard
    , _loggerConfigExceptionLimit :: Maybe Natural
_loggerConfigExceptionLimit = forall a. a -> Maybe a
Just Natural
10
    , _loggerConfigExceptionWait :: Maybe Natural
_loggerConfigExceptionWait = forall a. a -> Maybe a
Just Natural
1000
    , _loggerConfigExitTimeout :: Maybe Natural
_loggerConfigExitTimeout = forall a. a -> Maybe a
Just Natural
1000000
    }

validateLoggerConfig ∷ ConfigValidation LoggerConfig λ
validateLoggerConfig :: forall (λ :: * -> *). ConfigValidation LoggerConfig λ
validateLoggerConfig LoggerConfig
_ = 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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Natural
_loggerConfigQueueSize
        , Key
"log_level" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= LogLevel
_loggerConfigThreshold
        , Key
"scope" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= LogScope
_loggerConfigScope
        , Key
"policy" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= LogPolicy
_loggerConfigPolicy
        , Key
"exception_limit" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Natural
_loggerConfigExceptionLimit
        , Key
"exception_wait" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Natural
_loggerConfigExceptionWait
        , Key
"exit_timeout" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Natural
_loggerConfigExitTimeout
        ]

instance FromJSON (LoggerConfig → LoggerConfig) where
    parseJSON :: Value -> Parser (LoggerConfig -> LoggerConfig)
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"LoggerConfig" 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' LoggerConfig Natural
loggerConfigQueueSize forall b a.
FromJSON b =>
Lens' a b -> Text -> Object -> Parser (a -> a)
..: Text
"queue_size" 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' LoggerConfig LogLevel
loggerConfigThreshold forall b a.
FromJSON b =>
Lens' a b -> Text -> Object -> Parser (a -> a)
..: Text
"log_level" 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' LoggerConfig LogScope
loggerConfigScope forall b a.
FromJSON b =>
Lens' a b -> Text -> Object -> Parser (a -> a)
..: Text
"scope" 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' LoggerConfig LogPolicy
loggerConfigPolicy forall b a.
FromJSON b =>
Lens' a b -> Text -> Object -> Parser (a -> a)
..: Text
"policy" 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' LoggerConfig (Maybe Natural)
loggerConfigExceptionLimit forall b a.
FromJSON b =>
Lens' a b -> Text -> Object -> Parser (a -> a)
..: Text
"exception_limit" 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' LoggerConfig (Maybe Natural)
loggerConfigExceptionWait forall b a.
FromJSON b =>
Lens' a b -> Text -> Object -> Parser (a -> a)
..: Text
"exception_wait" 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' LoggerConfig (Maybe Natural)
loggerConfigExitTimeout forall b a.
FromJSON b =>
Lens' a b -> Text -> Object -> Parser (a -> a)
..: Text
"exit_timeout" 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 = forall a. a -> a
id
    forall (f :: * -> *) b c a.
Functor f =>
(b -> c) -> f (a -> b) -> f (a -> c)
<$< Lens' LoggerConfig Natural
loggerConfigQueueSize forall (f :: * -> *) a b.
(Alternative f, Applicative f) =>
Lens' a b -> f b -> f (a -> a)
.:: forall a. ReadM a -> Mod OptionFields a -> Parser a
option forall a. Read a => ReadM a
auto
        forall a b. (a -> b) -> a -> b
% forall (f :: * -> *) a. HasName f => String -> Mod f a
long (Text -> String
T.unpack Text
prefix forall α. Monoid α => α -> α -> α
⊕ String
"queue-size")
        forall α. Monoid α => α -> α -> α
⊕ forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"INT"
        forall α. Monoid α => α -> α -> α
⊕ forall (f :: * -> *) a. String -> Mod f a
help String
"size of the internal logger queue"
    forall (f :: * -> *) b c a.
Applicative f =>
f (b -> c) -> f (a -> b) -> f (a -> c)
<*< Lens' LoggerConfig LogLevel
loggerConfigThreshold forall (f :: * -> *) a b.
(Alternative f, Applicative f) =>
Lens' a b -> f b -> f (a -> a)
.:: Text -> Parser LogLevel
pLogLevel_ Text
prefix
    forall (f :: * -> *) b c a.
Applicative f =>
f (b -> c) -> f (a -> b) -> f (a -> c)
<*< Lens' LoggerConfig LogPolicy
loggerConfigPolicy forall (f :: * -> *) a b.
(Alternative f, Applicative f) =>
Lens' a b -> f b -> f (a -> a)
.:: Text -> Parser LogPolicy
pLogPolicy_ Text
prefix
    forall (f :: * -> *) b c a.
Applicative f =>
f (b -> c) -> f (a -> b) -> f (a -> c)
<*< Lens' LoggerConfig (Maybe Natural)
loggerConfigExceptionLimit forall (f :: * -> *) a b.
(Alternative f, Applicative f) =>
Lens' a b -> f b -> f (a -> a)
.:: forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
% forall a. ReadM a -> Mod OptionFields a -> Parser a
option forall a. Read a => ReadM a
auto
        forall a b. (a -> b) -> a -> b
% forall (f :: * -> *) a. HasName f => String -> Mod f a
long (Text -> String
T.unpack Text
prefix forall α. Monoid α => α -> α -> α
⊕ String
"exception-limit")
        forall α. Monoid α => α -> α -> α
⊕ forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"INT"
        forall α. Monoid α => α -> α -> α
⊕ forall (f :: * -> *) a. String -> Mod f a
help String
"maximal number of backend failures before and exception is raised"
    forall (f :: * -> *) b c a.
Applicative f =>
f (b -> c) -> f (a -> b) -> f (a -> c)
<*< Lens' LoggerConfig (Maybe Natural)
loggerConfigExceptionWait forall (f :: * -> *) a b.
(Alternative f, Applicative f) =>
Lens' a b -> f b -> f (a -> a)
.:: forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
% forall a. ReadM a -> Mod OptionFields a -> Parser a
option forall a. Read a => ReadM a
auto
        forall a b. (a -> b) -> a -> b
% forall (f :: * -> *) a. HasName f => String -> Mod f a
long (Text -> String
T.unpack Text
prefix forall α. Monoid α => α -> α -> α
⊕ String
"exception-wait")
        forall α. Monoid α => α -> α -> α
⊕ forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"INT"
        forall α. Monoid α => α -> α -> α
⊕ forall (f :: * -> *) a. String -> Mod f a
help String
"time to wait after an backend failure occured"
    forall (f :: * -> *) b c a.
Applicative f =>
f (b -> c) -> f (a -> b) -> f (a -> c)
<*< Lens' LoggerConfig (Maybe Natural)
loggerConfigExitTimeout forall (f :: * -> *) a b.
(Alternative f, Applicative f) =>
Lens' a b -> f b -> f (a -> a)
.:: forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
% forall a. ReadM a -> Mod OptionFields a -> Parser a
option forall a. Read a => ReadM a
auto
        forall a b. (a -> b) -> a -> b
% forall (f :: * -> *) a. HasName f => String -> Mod f a
long (Text -> String
T.unpack Text
prefix forall α. Monoid α => α -> α -> α
⊕ String
"exit-timeout")
        forall α. Monoid α => α -> α -> α
⊕ forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"INT"
        forall α. Monoid α => α -> α -> α
⊕ 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
    { forall a. Logger a -> LoggerQueue a
_loggerQueue ∷ !(LoggerQueue a)
    , forall a. Logger a -> Async ()
_loggerWorker ∷ !(Async ())
    , forall a. Logger a -> LogLevel
_loggerThreshold ∷ !LogLevel
    , forall a. Logger a -> LogScope
_loggerScope ∷ !LogScope
    , forall a. Logger a -> LogPolicy
_loggerPolicy ∷ !LogPolicy
    , forall a. Logger a -> IORef Natural
_loggerMissed ∷ !(IORef Natural)
    , forall a. Logger a -> Maybe Natural
_loggerExitTimeout ∷ !(Maybe Natural)
    , forall a. Logger a -> Text -> IO ()
_loggerErrLogFunction ∷ !(T.Text → IO ())
    }
    deriving (Typeable, 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 :: forall a. Lens' (Logger a) LogLevel
loggerThreshold = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall a. Logger a -> LogLevel
_loggerThreshold 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 :: forall a. Lens' (Logger a) LogScope
loggerScope = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall a. Logger a -> LogScope
_loggerScope 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 :: forall a. Lens' (Logger a) LogPolicy
loggerPolicy = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall a. Logger a -> LogPolicy
_loggerPolicy 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 :: forall (μ :: * -> *) a.
MonadIO μ =>
LoggerConfig -> LoggerBackend a -> μ (Logger a)
createLogger = 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_ :: forall (μ :: * -> *) a.
MonadIO μ =>
(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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    LoggerQueue a
queue ← forall q a. BoundedCloseableQueue q a => Natural -> IO q
newQueue (forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
_loggerConfigQueueSize)
    IORef Natural
missed ← forall a. a -> IO (IORef a)
newIORef Natural
0
    Async ()
worker ← 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.
    forall a. Async a -> IO ()
link Async ()
worker
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 :: forall a.
(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 = forall (m :: * -> *) a. MonadBaseControl IO m => m a -> m a
mask_ forall a b. (a -> b) -> a -> b
$
    forall a. ((forall b. IO b -> IO b) -> IO a) -> IO (Async a)
asyncWithUnmask forall a b. (a -> b) -> a -> b
$ \forall b. IO b -> IO b
umask → forall b. IO b -> IO b
umask ([SomeException] -> IO ()
go []) forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(LoggerKilled
_ ∷ LoggerKilled) → 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 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 → 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 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 forall (m :: * -> *) α β. Monad m => m α -> m β -> m β
≫ forall (m :: * -> *) a. Monad m => a -> m a
return []) 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 = forall {a}. TimeSpec -> a -> LogMessage a
backendErrorMsg TimeSpec
t (forall a b. (Show a, IsString b) => a -> b
sshow SomeException
e)
        LoggerBackend a
backend (forall a b. a -> Either a b
Left LogMessage Text
errMsg) 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) forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
_ →
                -- discard exception log
                forall (m :: * -> *) a. Monad m => a -> m a
return ()

        -- decide how to proceed in case of an error
        case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
            Just (BackendTerminatedException SomeException
_ ∷ LoggerException Void) → forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO SomeException
e
            Maybe (LoggerException Void)
_ → do
                forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Int -> IO ()
threadDelay forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ forall a b. (Integral a, Num b) => a -> b
fromIntegral) Maybe Natural
errWait
                let errList' :: [SomeException]
errList' = SomeException
eforall a. a -> [a] -> [a]
:[SomeException]
errList
                case Maybe Natural
errLimit of
                    Maybe Natural
Nothing → forall (m :: * -> *) a. Monad m => a -> m a
return []
                    Just Natural
n
                        | forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [SomeException]
errList') forall a. Ord a => a -> a -> Bool
> Natural
n → forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ [SomeException] -> LoggerException Void
BackendTooManyExceptions (forall a. [a] -> [a]
reverse [SomeException]
errList')
                        | Bool
otherwise → 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 ← forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Natural
missed Natural
0
        if Natural
n forall a. Ord a => a -> a -> Bool
> Natural
0
          then do
            forall (m :: * -> *) a. Monad m => a -> m a
return forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ forall a. a -> Maybe a
Just forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall {a} {a}.
(Monoid a, IsString a, Show a) =>
TimeSpec -> a -> LogMessage a
discardMsg TimeSpec
t Natural
n
          else
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
        { _logMsg :: a
_logMsg = a
"discarded " forall α. Monoid α => α -> α -> α
⊕ forall a b. (Show a, IsString b) => a -> b
sshow a
n 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
        { _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
        [ forall a. IsString a => TimeSpec -> a
formatIso8601Milli TimeSpec
_logMsgTime
        , Text
"[" forall α. Monoid α => α -> α -> α
⊕ forall a. IsString a => LogLevel -> a
logLevelText LogLevel
_logMsgLevel forall α. Monoid α => α -> α -> α
⊕ Text
"]"
        , LogScope -> Text
formatScope LogScope
_logMsgScope
        , Text
_logMsg
        ]

    formatScope :: LogScope -> Text
formatScope LogScope
scope = Text
"[" forall α. Monoid α => α -> α -> α
⊕ Text -> [Text] -> Text
T.intercalate Text
"," (forall a b. (a -> b) -> [a] -> [b]
map forall {α}. (Monoid α, IsString α) => (α, α) -> α
formatLabel LogScope
scope) 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
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 :: forall (μ :: * -> *) a. MonadIO μ => 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
..} = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    forall q a. BoundedCloseableQueue q a => q -> IO ()
closeQueue LoggerQueue a
_loggerQueue
    Maybe ()
complete ← forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just) (forall a. Int -> IO a -> IO (Maybe a)
timeout forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ forall a b. (Integral a, Num b) => a -> b
fromIntegral) Maybe Natural
_loggerExitTimeout forall a b. (a -> b) -> a -> b
$ 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 ()
_ → forall (m :: * -> *) a. Monad m => a -> m a
return ()
    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 :: forall (μ :: * -> *) a α.
(MonadIO μ, MonadBaseControl IO μ) =>
LoggerConfig -> LoggerBackend a -> (Logger a -> μ α) -> μ α
withLogger = 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_ :: forall (μ :: * -> *) a α.
(MonadIO μ, MonadBaseControl IO μ) =>
(Text -> IO ())
-> LoggerConfig -> LoggerBackend a -> (Logger a -> μ α) -> μ α
withLogger_ Text -> IO ()
errLogFun LoggerConfig
config LoggerBackend a
backend =
    forall (m :: * -> *) a b c.
MonadBaseControl IO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (forall (μ :: * -> *) a.
MonadIO μ =>
(Text -> IO ()) -> LoggerConfig -> LoggerBackend a -> μ (Logger a)
createLogger_ Text -> IO ()
errLogFun LoggerConfig
config LoggerBackend a
backend) 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 :: forall a (μ :: * -> *) α.
(Show a, Typeable a, NFData a, MonadIO μ, MonadBaseControl IO μ) =>
LoggerConfig -> LoggerBackend a -> (LogFunctionIO a -> μ α) -> μ α
withLogFunction = 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_ :: forall a (μ :: * -> *) α.
(Show a, Typeable a, NFData a, MonadIO μ, MonadBaseControl IO μ) =>
(Text -> IO ())
-> LoggerConfig
-> LoggerBackend a
-> (LogFunctionIO a -> μ α)
-> μ α
withLogFunction_ Text -> IO ()
errLogFun LoggerConfig
config LoggerBackend a
backend LogFunctionIO a -> μ α
f =
    forall (μ :: * -> *) a α.
(MonadIO μ, MonadBaseControl IO μ) =>
(Text -> IO ())
-> LoggerConfig -> LoggerBackend a -> (Logger a -> μ α) -> μ α
withLogger_ Text -> IO ()
errLogFun LoggerConfig
config LoggerBackend a
backend forall a b. (a -> b) -> a -> b
$ LogFunctionIO a -> μ α
f forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ 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 :: forall a.
(Show a, Typeable a, NFData a) =>
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 → forall (m :: * -> *) a. Monad m => a -> m a
return ()
        LogLevel
threshold
            | LogLevel
level forall a. Ord a => a -> a -> Bool
≤ LogLevel
threshold → forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
                TimeSpec
t ← Clock -> IO TimeSpec
getTime Clock
Realtime
                LogMessage a -> IO ()
writeWithLogPolicy forall a b. NFData a => (a -> b) -> a -> b
$!! LogMessage
                    { _logMsg :: a
_logMsg = a
msg
                    , _logMsgLevel :: LogLevel
_logMsgLevel = LogLevel
level
                    , _logMsgScope :: LogScope
_logMsgScope = LogScope
_loggerScope
                    , _logMsgTime :: TimeSpec
_logMsgTime = TimeSpec
t
                    }
            | Bool
otherwise → forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    writeWithLogPolicy :: LogMessage a -> IO ()
writeWithLogPolicy !LogMessage a
lmsg
        | LogPolicy
_loggerPolicy forall α. Eq α => α -> α -> Bool
≡ LogPolicy
LogPolicyBlock = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall q a. BoundedCloseableQueue q a => q -> a -> IO Bool
writeQueue LoggerQueue a
_loggerQueue LogMessage a
lmsg
        | Bool
otherwise = forall q a. BoundedCloseableQueue q a => q -> a -> IO (Maybe Bool)
tryWriteQueue LoggerQueue a
_loggerQueue LogMessage a
lmsg forall (m :: * -> *) α β. Monad m => m α -> (α -> m β) -> m β
≫= \case
            -- Success
            Just Bool
True → forall (m :: * -> *) a. Monad m => a -> m a
return ()
            -- Queue is closed
            Just Bool
False → forall (m :: * -> *) a. Monad m => a -> m a
return ()
            -- Queue is full
            Maybe Bool
Nothing
                | LogPolicy
_loggerPolicy forall α. Eq α => α -> α -> Bool
≡ LogPolicy
LogPolicyDiscard → forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Natural
_loggerMissed (\Natural
x → (Natural
x forall a. Num a => a -> a -> a
+ Natural
1, ()))
                | LogPolicy
_loggerPolicy forall α. Eq α => α -> α -> Bool
≡ LogPolicy
LogPolicyRaise → forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ forall a. LogMessage a -> LoggerException a
QueueFullException LogMessage a
lmsg
                | Bool
otherwise → 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 :: (Show a, Typeable a, NFData a) => Logger a -> LogFunctionIO a
loggerFunIO = forall a.
(Show a, Typeable a, NFData a) =>
Logger a -> LogFunctionIO a
loggCtx
    setLoggerLevel :: Lens' (Logger a) LogLevel
setLoggerLevel = forall a. Lens' (Logger a) LogLevel
loggerThreshold
    setLoggerScope :: Lens' (Logger a) LogScope
setLoggerScope = forall a. Lens' (Logger a) LogScope
loggerScope
    setLoggerPolicy :: Lens' (Logger a) LogPolicy
setLoggerPolicy = forall a. Lens' (Logger a) LogPolicy
loggerPolicy

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

type LoggerT a = LoggerCtxT (Logger a)

runLoggerT ∷ LoggerT a m α → Logger a → m α
runLoggerT :: forall a (m :: * -> *) α. LoggerT a m α -> Logger a -> m α
runLoggerT = 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 :: forall (m :: * -> *) msg α.
(MonadBaseControl IO m, MonadIO m) =>
LoggerConfig -> LoggerBackend msg -> LoggerT msg m α -> m α
runLogT LoggerConfig
config LoggerBackend msg
backend = forall (μ :: * -> *) a α.
(MonadIO μ, MonadBaseControl IO μ) =>
LoggerConfig -> LoggerBackend a -> (Logger a -> μ α) -> μ α
withLogger LoggerConfig
config LoggerBackend msg
backend forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ 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"]
-}