-- Copyright (c) 2016-2020 Lars Kuhtz <lakuhtz@gmail.com>
-- Copyright (c) 2014-2015 PivotCloud, Inc.
--
-- System.Logger.Backend.Handle
--
-- 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.Backend.Handle
-- Description: Handle Backend for Yet Another Logger
-- Copyright:
--     Copyright (c) 2016-2020 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
--

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

module System.Logger.Backend.Handle
(
-- * Handle Configuration
  LoggerHandleConfig(..)
, loggerHandleConfigText
, readLoggerHandleConfig
, validateLoggerHandleConfig
, pLoggerHandleConfig
, pLoggerHandleConfig_

-- * Backend Configuration
, HandleBackendConfig(..)
, handleBackendConfigHandle
, handleBackendConfigColor
, defaultHandleBackendConfig
, validateHandleBackendConfig
, pHandleBackendConfig
, pHandleBackendConfig_

-- * Backend Implementation
, withHandleBackend
, withHandleBackend_
, handleBackend
, handleBackend_
) where

import Configuration.Utils hiding (Error, Lens')
import Configuration.Utils.Validation

import Control.DeepSeq
import Control.Monad.Except
import Control.Monad.Trans.Control
import Control.Monad.Writer

import qualified Data.List as L
import Data.Monoid.Unicode
import Data.String
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Typeable

import GHC.Generics

import Lens.Micro

import qualified Options.Applicative as O

import Prelude.Unicode

import qualified System.Console.ANSI as A
import System.IO

-- internal modules

import System.Logger.Backend.ColorOption
import System.Logger.Internal
import System.Logger.Types

-- -------------------------------------------------------------------------- --
-- Handle Logger Backend Configuration

data LoggerHandleConfig
    = StdOut
    | StdErr
    | FileHandle FilePath
    deriving (Int -> LoggerHandleConfig -> ShowS
[LoggerHandleConfig] -> ShowS
LoggerHandleConfig -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [LoggerHandleConfig] -> ShowS
$cshowList :: [LoggerHandleConfig] -> ShowS
show :: LoggerHandleConfig -> FilePath
$cshow :: LoggerHandleConfig -> FilePath
showsPrec :: Int -> LoggerHandleConfig -> ShowS
$cshowsPrec :: Int -> LoggerHandleConfig -> ShowS
Show, ReadPrec [LoggerHandleConfig]
ReadPrec LoggerHandleConfig
Int -> ReadS LoggerHandleConfig
ReadS [LoggerHandleConfig]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [LoggerHandleConfig]
$creadListPrec :: ReadPrec [LoggerHandleConfig]
readPrec :: ReadPrec LoggerHandleConfig
$creadPrec :: ReadPrec LoggerHandleConfig
readList :: ReadS [LoggerHandleConfig]
$creadList :: ReadS [LoggerHandleConfig]
readsPrec :: Int -> ReadS LoggerHandleConfig
$creadsPrec :: Int -> ReadS LoggerHandleConfig
Read, LoggerHandleConfig -> LoggerHandleConfig -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LoggerHandleConfig -> LoggerHandleConfig -> Bool
$c/= :: LoggerHandleConfig -> LoggerHandleConfig -> Bool
== :: LoggerHandleConfig -> LoggerHandleConfig -> Bool
$c== :: LoggerHandleConfig -> LoggerHandleConfig -> Bool
Eq, Eq LoggerHandleConfig
LoggerHandleConfig -> LoggerHandleConfig -> Bool
LoggerHandleConfig -> LoggerHandleConfig -> Ordering
LoggerHandleConfig -> LoggerHandleConfig -> LoggerHandleConfig
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 :: LoggerHandleConfig -> LoggerHandleConfig -> LoggerHandleConfig
$cmin :: LoggerHandleConfig -> LoggerHandleConfig -> LoggerHandleConfig
max :: LoggerHandleConfig -> LoggerHandleConfig -> LoggerHandleConfig
$cmax :: LoggerHandleConfig -> LoggerHandleConfig -> LoggerHandleConfig
>= :: LoggerHandleConfig -> LoggerHandleConfig -> Bool
$c>= :: LoggerHandleConfig -> LoggerHandleConfig -> Bool
> :: LoggerHandleConfig -> LoggerHandleConfig -> Bool
$c> :: LoggerHandleConfig -> LoggerHandleConfig -> Bool
<= :: LoggerHandleConfig -> LoggerHandleConfig -> Bool
$c<= :: LoggerHandleConfig -> LoggerHandleConfig -> Bool
< :: LoggerHandleConfig -> LoggerHandleConfig -> Bool
$c< :: LoggerHandleConfig -> LoggerHandleConfig -> Bool
compare :: LoggerHandleConfig -> LoggerHandleConfig -> Ordering
$ccompare :: LoggerHandleConfig -> LoggerHandleConfig -> Ordering
Ord, Typeable, forall x. Rep LoggerHandleConfig x -> LoggerHandleConfig
forall x. LoggerHandleConfig -> Rep LoggerHandleConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LoggerHandleConfig x -> LoggerHandleConfig
$cfrom :: forall x. LoggerHandleConfig -> Rep LoggerHandleConfig x
Generic)

instance NFData LoggerHandleConfig

readLoggerHandleConfig
    ∷ (MonadError e m, IsString e, Monoid e)
    ⇒ T.Text
    → m LoggerHandleConfig
readLoggerHandleConfig :: forall e (m :: * -> *).
(MonadError e m, IsString e, Monoid e) =>
Text -> m LoggerHandleConfig
readLoggerHandleConfig Text
x = case Text -> Text
T.toLower Text
x of
    Text
"stdout" → forall (m :: * -> *) a. Monad m => a -> m a
return LoggerHandleConfig
StdOut
    Text
"stderr" → forall (m :: * -> *) a. Monad m => a -> m a
return LoggerHandleConfig
StdErr
    Text
tx | Int -> Text -> Text
T.take Int
5 Text
tx forall α. Eq α => α -> α -> Bool
≡ Text
"file:" → forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> LoggerHandleConfig
FileHandle forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop Int
5 Text
tx
    Text
e → forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ e
"unexpected logger handle value: "
        forall α. Monoid α => α -> α -> α
⊕ forall a. IsString a => FilePath -> a
fromString (forall a. Show a => a -> FilePath
show Text
e)
        forall α. Monoid α => α -> α -> α
⊕ e
", expected \"stdout\", \"stderr\", or \"file:<FILENAME>\""

loggerHandleConfigText
    ∷ (IsString a, Monoid a)
    ⇒ LoggerHandleConfig
    → a
loggerHandleConfigText :: forall a. (IsString a, Monoid a) => LoggerHandleConfig -> a
loggerHandleConfigText LoggerHandleConfig
StdOut = a
"stdout"
loggerHandleConfigText LoggerHandleConfig
StdErr = a
"stderr"
loggerHandleConfigText (FileHandle FilePath
f) = a
"file:" forall α. Monoid α => α -> α -> α
⊕ forall a. IsString a => FilePath -> a
fromString FilePath
f

validateLoggerHandleConfig ∷ ConfigValidation LoggerHandleConfig λ
validateLoggerHandleConfig :: forall (λ :: * -> *). ConfigValidation LoggerHandleConfig λ
validateLoggerHandleConfig (FileHandle FilePath
filepath) = forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
Text -> FilePath -> m ()
validateFileWritable Text
"file handle" FilePath
filepath
validateLoggerHandleConfig LoggerHandleConfig
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

instance ToJSON LoggerHandleConfig where
    toJSON :: LoggerHandleConfig -> Value
toJSON = Text -> Value
String forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ forall a. (IsString a, Monoid a) => LoggerHandleConfig -> a
loggerHandleConfigText

instance FromJSON LoggerHandleConfig where
    parseJSON :: Value -> Parser LoggerHandleConfig
parseJSON = forall a. FilePath -> (Text -> Parser a) -> Value -> Parser a
withText FilePath
"LoggerHandleConfig" forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ forall e (m :: * -> *).
(MonadError e m, IsString e, Monoid e) =>
Text -> m LoggerHandleConfig
readLoggerHandleConfig

pLoggerHandleConfig ∷ O.Parser LoggerHandleConfig
pLoggerHandleConfig :: Parser LoggerHandleConfig
pLoggerHandleConfig = Text -> Parser LoggerHandleConfig
pLoggerHandleConfig_ Text
""

-- | A version of 'pLoggerHandleConfig' that takes a prefix for the
-- command line option.
--
-- @since 0.2
--
pLoggerHandleConfig_
    ∷ T.Text
        -- ^ prefix for the command line options.
    → O.Parser LoggerHandleConfig
pLoggerHandleConfig_ :: Text -> Parser LoggerHandleConfig
pLoggerHandleConfig_ Text
prefix = forall a. ReadM a -> Mod OptionFields a -> Parser a
option (forall a. (FilePath -> Either FilePath a) -> ReadM a
eitherReader (forall e (m :: * -> *).
(MonadError e m, IsString e, Monoid e) =>
Text -> m LoggerHandleConfig
readLoggerHandleConfig forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack))
    forall a b. (a -> b) -> a -> b
% forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long (Text -> FilePath
T.unpack Text
prefix forall α. Monoid α => α -> α -> α
⊕ FilePath
"logger-backend-handle")
    forall α. Monoid α => α -> α -> α
⊕ forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"stdout|stderr|file:<FILENAME>"
    forall α. Monoid α => α -> α -> α
⊕ forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"handle where the logs are written"

-- -------------------------------------------------------------------------- --
-- Logger Backend Configuration

-- | HandleBackendConfig
--
data HandleBackendConfig = HandleBackendConfig
    { HandleBackendConfig -> ColorOption
_handleBackendConfigColor ∷ !ColorOption
    , HandleBackendConfig -> LoggerHandleConfig
_handleBackendConfigHandle ∷ !LoggerHandleConfig
    }
    deriving (Int -> HandleBackendConfig -> ShowS
[HandleBackendConfig] -> ShowS
HandleBackendConfig -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [HandleBackendConfig] -> ShowS
$cshowList :: [HandleBackendConfig] -> ShowS
show :: HandleBackendConfig -> FilePath
$cshow :: HandleBackendConfig -> FilePath
showsPrec :: Int -> HandleBackendConfig -> ShowS
$cshowsPrec :: Int -> HandleBackendConfig -> ShowS
Show, ReadPrec [HandleBackendConfig]
ReadPrec HandleBackendConfig
Int -> ReadS HandleBackendConfig
ReadS [HandleBackendConfig]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [HandleBackendConfig]
$creadListPrec :: ReadPrec [HandleBackendConfig]
readPrec :: ReadPrec HandleBackendConfig
$creadPrec :: ReadPrec HandleBackendConfig
readList :: ReadS [HandleBackendConfig]
$creadList :: ReadS [HandleBackendConfig]
readsPrec :: Int -> ReadS HandleBackendConfig
$creadsPrec :: Int -> ReadS HandleBackendConfig
Read, HandleBackendConfig -> HandleBackendConfig -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HandleBackendConfig -> HandleBackendConfig -> Bool
$c/= :: HandleBackendConfig -> HandleBackendConfig -> Bool
== :: HandleBackendConfig -> HandleBackendConfig -> Bool
$c== :: HandleBackendConfig -> HandleBackendConfig -> Bool
Eq, Eq HandleBackendConfig
HandleBackendConfig -> HandleBackendConfig -> Bool
HandleBackendConfig -> HandleBackendConfig -> Ordering
HandleBackendConfig -> HandleBackendConfig -> HandleBackendConfig
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 :: HandleBackendConfig -> HandleBackendConfig -> HandleBackendConfig
$cmin :: HandleBackendConfig -> HandleBackendConfig -> HandleBackendConfig
max :: HandleBackendConfig -> HandleBackendConfig -> HandleBackendConfig
$cmax :: HandleBackendConfig -> HandleBackendConfig -> HandleBackendConfig
>= :: HandleBackendConfig -> HandleBackendConfig -> Bool
$c>= :: HandleBackendConfig -> HandleBackendConfig -> Bool
> :: HandleBackendConfig -> HandleBackendConfig -> Bool
$c> :: HandleBackendConfig -> HandleBackendConfig -> Bool
<= :: HandleBackendConfig -> HandleBackendConfig -> Bool
$c<= :: HandleBackendConfig -> HandleBackendConfig -> Bool
< :: HandleBackendConfig -> HandleBackendConfig -> Bool
$c< :: HandleBackendConfig -> HandleBackendConfig -> Bool
compare :: HandleBackendConfig -> HandleBackendConfig -> Ordering
$ccompare :: HandleBackendConfig -> HandleBackendConfig -> Ordering
Ord, Typeable, forall x. Rep HandleBackendConfig x -> HandleBackendConfig
forall x. HandleBackendConfig -> Rep HandleBackendConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep HandleBackendConfig x -> HandleBackendConfig
$cfrom :: forall x. HandleBackendConfig -> Rep HandleBackendConfig x
Generic)

handleBackendConfigColor ∷ Lens' HandleBackendConfig ColorOption
handleBackendConfigColor :: Lens' HandleBackendConfig ColorOption
handleBackendConfigColor = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens HandleBackendConfig -> ColorOption
_handleBackendConfigColor forall a b. (a -> b) -> a -> b
$ \HandleBackendConfig
a ColorOption
b → HandleBackendConfig
a { _handleBackendConfigColor :: ColorOption
_handleBackendConfigColor = ColorOption
b }

handleBackendConfigHandle ∷ Lens' HandleBackendConfig LoggerHandleConfig
handleBackendConfigHandle :: Lens' HandleBackendConfig LoggerHandleConfig
handleBackendConfigHandle = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens HandleBackendConfig -> LoggerHandleConfig
_handleBackendConfigHandle forall a b. (a -> b) -> a -> b
$ \HandleBackendConfig
a LoggerHandleConfig
b → HandleBackendConfig
a { _handleBackendConfigHandle :: LoggerHandleConfig
_handleBackendConfigHandle = LoggerHandleConfig
b }

instance NFData HandleBackendConfig

defaultHandleBackendConfig ∷ HandleBackendConfig
defaultHandleBackendConfig :: HandleBackendConfig
defaultHandleBackendConfig = HandleBackendConfig
    { _handleBackendConfigColor :: ColorOption
_handleBackendConfigColor = ColorOption
defaultColorOption
    , _handleBackendConfigHandle :: LoggerHandleConfig
_handleBackendConfigHandle = LoggerHandleConfig
StdOut
    }

validateHandleBackendConfig ∷ ConfigValidation HandleBackendConfig []
validateHandleBackendConfig :: ConfigValidation HandleBackendConfig []
validateHandleBackendConfig HandleBackendConfig{ColorOption
LoggerHandleConfig
_handleBackendConfigHandle :: LoggerHandleConfig
_handleBackendConfigColor :: ColorOption
_handleBackendConfigHandle :: HandleBackendConfig -> LoggerHandleConfig
_handleBackendConfigColor :: HandleBackendConfig -> ColorOption
..} = do
        forall (λ :: * -> *). ConfigValidation LoggerHandleConfig λ
validateLoggerHandleConfig LoggerHandleConfig
_handleBackendConfigHandle
        case (LoggerHandleConfig
_handleBackendConfigHandle, ColorOption
_handleBackendConfigColor) of
            (FileHandle FilePath
_, ColorOption
ColorTrue) →
                forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Text
"log messages are formatted using ANSI color escape codes but are written to a file"]
            (LoggerHandleConfig, ColorOption)
_ → forall (m :: * -> *) a. Monad m => a -> m a
return ()

instance ToJSON HandleBackendConfig where
    toJSON :: HandleBackendConfig -> Value
toJSON HandleBackendConfig{ColorOption
LoggerHandleConfig
_handleBackendConfigHandle :: LoggerHandleConfig
_handleBackendConfigColor :: ColorOption
_handleBackendConfigHandle :: HandleBackendConfig -> LoggerHandleConfig
_handleBackendConfigColor :: HandleBackendConfig -> ColorOption
..} = [Pair] -> Value
object
        [ Key
"color" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ColorOption
_handleBackendConfigColor
        , Key
"handle" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= LoggerHandleConfig
_handleBackendConfigHandle
        ]

instance FromJSON (HandleBackendConfig → HandleBackendConfig) where
    parseJSON :: Value -> Parser (HandleBackendConfig -> HandleBackendConfig)
parseJSON = forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"HandleBackendConfig" 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' HandleBackendConfig ColorOption
handleBackendConfigColor forall b a.
FromJSON b =>
Lens' a b -> Text -> Object -> Parser (a -> a)
..: Text
"color" 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' HandleBackendConfig LoggerHandleConfig
handleBackendConfigHandle forall b a.
FromJSON b =>
Lens' a b -> Text -> Object -> Parser (a -> a)
..: Text
"handle" forall a b. (a -> b) -> a -> b
% Object
o

pHandleBackendConfig ∷ MParser HandleBackendConfig
pHandleBackendConfig :: MParser HandleBackendConfig
pHandleBackendConfig = Text -> MParser HandleBackendConfig
pHandleBackendConfig_ Text
""

-- | A version of 'pLoggerHandleBackendConfig' that takes a prefix for the
-- command line option.
--
-- @since 0.2
--
pHandleBackendConfig_
    ∷ T.Text
        -- ^ prefix for this and all subordinate command line options.
    → MParser HandleBackendConfig
pHandleBackendConfig_ :: Text -> MParser HandleBackendConfig
pHandleBackendConfig_ Text
prefix = forall a. a -> a
id
    forall (f :: * -> *) b c a.
Functor f =>
(b -> c) -> f (a -> b) -> f (a -> c)
<$< Lens' HandleBackendConfig ColorOption
handleBackendConfigColor forall (f :: * -> *) a b.
(Alternative f, Applicative f) =>
Lens' a b -> f b -> f (a -> a)
.:: Text -> Parser ColorOption
pColorOption_ Text
prefix
    forall (f :: * -> *) b c a.
Applicative f =>
f (b -> c) -> f (a -> b) -> f (a -> c)
<*< Lens' HandleBackendConfig LoggerHandleConfig
handleBackendConfigHandle forall (f :: * -> *) a b.
(Alternative f, Applicative f) =>
Lens' a b -> f b -> f (a -> a)
.:: Text -> Parser LoggerHandleConfig
pLoggerHandleConfig_ Text
prefix

-- -------------------------------------------------------------------------- --
-- Backend Implementation

withHandleBackend
    ∷ (MonadIO m, MonadBaseControl IO m)
    ⇒ HandleBackendConfig
    → (LoggerBackend T.Text → m α)
    → m α
withHandleBackend :: forall (m :: * -> *) α.
(MonadIO m, MonadBaseControl IO m) =>
HandleBackendConfig -> (LoggerBackend Text -> m α) -> m α
withHandleBackend = forall (m :: * -> *) msg α.
(MonadIO m, MonadBaseControl IO m) =>
(msg -> Text)
-> HandleBackendConfig -> (LoggerBackend msg -> m α) -> m α
withHandleBackend_ forall a. a -> a
id
{-# INLINE withHandleBackend #-}

-- | A version of 'withHandleBackend' that is generic in the type
-- of the log message.
--
-- @since 0.2.2
--
withHandleBackend_
    ∷ (MonadIO m, MonadBaseControl IO m)
    ⇒ (msg → T.Text)
        -- ^ formatting function for the log message
    → HandleBackendConfig
    → (LoggerBackend msg → m α)
    → m α
withHandleBackend_ :: forall (m :: * -> *) msg α.
(MonadIO m, MonadBaseControl IO m) =>
(msg -> Text)
-> HandleBackendConfig -> (LoggerBackend msg -> m α) -> m α
withHandleBackend_ msg -> Text
format HandleBackendConfig
conf LoggerBackend msg -> m α
inner =
    case HandleBackendConfig
conf forall s a. s -> Getting a s a -> a
^. Lens' HandleBackendConfig LoggerHandleConfig
handleBackendConfigHandle of
        LoggerHandleConfig
StdErr → Handle -> m α
run Handle
stderr
        LoggerHandleConfig
StdOut → Handle -> m α
run Handle
stdout
        FileHandle FilePath
f → forall (b :: * -> *) (m :: * -> *) a c d.
MonadBaseControl b m =>
((a -> b (StM m c)) -> b (StM m d)) -> (a -> m c) -> m d
liftBaseOp (forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
f IOMode
AppendMode) Handle -> m α
run
  where
    run :: Handle -> m α
run Handle
h = do
        Bool
colored ← forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ColorOption -> Handle -> IO Bool
useColor (HandleBackendConfig
conf forall s a. s -> Getting a s a -> a
^. Lens' HandleBackendConfig ColorOption
handleBackendConfigColor) Handle
h
        LoggerBackend msg -> m α
inner forall a b. (a -> b) -> a -> b
$ forall msg. (msg -> Text) -> Handle -> Bool -> LoggerBackend msg
handleBackend_ msg -> Text
format Handle
h Bool
colored

handleBackend
    ∷ Handle
    → Bool
        -- ^ whether to use ANSI color escape codes
    → LoggerBackend T.Text
handleBackend :: Handle -> Bool -> LoggerBackend Text
handleBackend = forall msg. (msg -> Text) -> Handle -> Bool -> LoggerBackend msg
handleBackend_ forall a. a -> a
id
{-# INLINE handleBackend #-}

-- | A version of 'handleBackend' that is generic in the type of
-- the log message.
--
-- @since 0.2.2
--
handleBackend_
    ∷ (msg → T.Text)
        -- ^ formatting function for the log message
    → Handle
    → Bool
        -- ^ whether to use ANSI color escape codes
    → LoggerBackend msg
handleBackend_ :: forall msg. (msg -> Text) -> Handle -> Bool -> LoggerBackend msg
handleBackend_ msg -> Text
format Handle
h Bool
colored Either (LogMessage Text) (LogMessage msg)
eitherMsg = do
    Handle -> Text -> IO ()
T.hPutStrLn Handle
h
        forall a b. (a -> b) -> a -> b
$ forall a. IsString a => TimeSpec -> a
formatIso8601Milli (LogMessage Text
msg forall s a. s -> Getting a s a -> a
^. forall a. Lens' (LogMessage a) TimeSpec
logMsgTime) forall α. Monoid α => α -> α -> α
⊕ Text
" "
        forall α. Monoid α => α -> α -> α
⊕ Bool -> Text -> Text
inLevelColor Bool
colored (Text
"[" forall α. Monoid α => α -> α -> α
⊕ forall a b. (Show a, IsString b) => a -> b
sshow LogLevel
level forall α. Monoid α => α -> α -> α
⊕ Text
"] ")
        forall α. Monoid α => α -> α -> α
⊕ Bool -> Text -> Text
inScopeColor Bool
colored (Text
"[" forall α. Monoid α => α -> α -> α
⊕ Text
formatedScope forall α. Monoid α => α -> α -> α
⊕ Text
"] ")
        forall α. Monoid α => α -> α -> α
⊕ (LogMessage Text
msg forall s a. s -> Getting a s a -> a
^. forall a b. Lens (LogMessage a) (LogMessage b) a b
logMsg)
  where
    msg :: LogMessage Text
msg = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id (forall a b. Lens (LogMessage a) (LogMessage b) a b
logMsg forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ msg -> Text
format) Either (LogMessage Text) (LogMessage msg)
eitherMsg
    level :: LogLevel
level = LogMessage Text
msg forall s a. s -> Getting a s a -> a
^. forall a. Lens' (LogMessage a) LogLevel
logMsgLevel

    formatedScope :: Text
formatedScope = Text -> [Text] -> Text
T.intercalate Text
"|" forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ forall a b. (a -> b) -> [a] -> [b]
L.map forall {α}. (Monoid α, IsString α) => (α, α) -> α
formatLabel forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ LogMessage Text
msg forall s a. s -> Getting a s a -> a
^. forall a. Lens' (LogMessage a) [(Text, Text)]
logMsgScope
    formatLabel :: (α, α) -> α
formatLabel (α
key, α
val) = α
key forall α. Monoid α => α -> α -> α
⊕ α
"=" forall α. Monoid α => α -> α -> α
⊕ α
val

    inScopeColor :: Bool -> Text -> Text
inScopeColor Bool
True = Text -> Text
inBlue
    inScopeColor Bool
False = forall a. a -> a
id

    inLevelColor :: Bool -> Text -> Text
inLevelColor Bool
True = case LogLevel
level of
        LogLevel
Error → Text -> Text
inRed
        LogLevel
Warn → Text -> Text
inOrange
        LogLevel
Info → Text -> Text
inGreen
        LogLevel
_ → forall a. a -> a
id
    inLevelColor Bool
False = forall a. a -> a
id

    inColor ∷ A.ColorIntensity → A.Color → T.Text → T.Text
    inColor :: ColorIntensity -> Color -> Text -> Text
inColor ColorIntensity
i Color
c Text
t = FilePath -> Text
T.pack ([SGR] -> FilePath
A.setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
A.SetColor ConsoleLayer
A.Foreground ColorIntensity
i Color
c]) forall α. Monoid α => α -> α -> α
⊕ Text
t forall α. Monoid α => α -> α -> α
⊕ FilePath -> Text
T.pack ([SGR] -> FilePath
A.setSGRCode [SGR
A.Reset])

    inRed ∷ T.Text → T.Text
    inRed :: Text -> Text
inRed = ColorIntensity -> Color -> Text -> Text
inColor ColorIntensity
A.Vivid Color
A.Red

    inOrange ∷ T.Text → T.Text
    inOrange :: Text -> Text
inOrange = ColorIntensity -> Color -> Text -> Text
inColor ColorIntensity
A.Dull Color
A.Red

    inGreen ∷ T.Text → T.Text
    inGreen :: Text -> Text
inGreen = ColorIntensity -> Color -> Text -> Text
inColor ColorIntensity
A.Dull Color
A.Green

    inBlue ∷ T.Text → T.Text
    inBlue :: Text -> Text
inBlue = ColorIntensity -> Color -> Text -> Text
inColor ColorIntensity
A.Dull Color
A.Blue
{-# INLINEABLE handleBackend_ #-}