{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnicodeSyntax #-}
module System.Logger.Backend.Handle
(
LoggerHandleConfig(..)
, loggerHandleConfigText
, readLoggerHandleConfig
, validateLoggerHandleConfig
, pLoggerHandleConfig
, pLoggerHandleConfig_
, HandleBackendConfig(..)
, handleBackendConfigHandle
, handleBackendConfigColor
, defaultHandleBackendConfig
, validateHandleBackendConfig
, pHandleBackendConfig
, pHandleBackendConfig_
, 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
import System.Logger.Backend.ColorOption
import System.Logger.Internal
import System.Logger.Types
data LoggerHandleConfig
= StdOut
| StdErr
| FileHandle FilePath
deriving (Int -> LoggerHandleConfig -> ShowS
[LoggerHandleConfig] -> ShowS
LoggerHandleConfig -> String
(Int -> LoggerHandleConfig -> ShowS)
-> (LoggerHandleConfig -> String)
-> ([LoggerHandleConfig] -> ShowS)
-> Show LoggerHandleConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LoggerHandleConfig] -> ShowS
$cshowList :: [LoggerHandleConfig] -> ShowS
show :: LoggerHandleConfig -> String
$cshow :: LoggerHandleConfig -> String
showsPrec :: Int -> LoggerHandleConfig -> ShowS
$cshowsPrec :: Int -> LoggerHandleConfig -> ShowS
Show, ReadPrec [LoggerHandleConfig]
ReadPrec LoggerHandleConfig
Int -> ReadS LoggerHandleConfig
ReadS [LoggerHandleConfig]
(Int -> ReadS LoggerHandleConfig)
-> ReadS [LoggerHandleConfig]
-> ReadPrec LoggerHandleConfig
-> ReadPrec [LoggerHandleConfig]
-> Read 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
(LoggerHandleConfig -> LoggerHandleConfig -> Bool)
-> (LoggerHandleConfig -> LoggerHandleConfig -> Bool)
-> Eq LoggerHandleConfig
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
Eq LoggerHandleConfig
-> (LoggerHandleConfig -> LoggerHandleConfig -> Ordering)
-> (LoggerHandleConfig -> LoggerHandleConfig -> Bool)
-> (LoggerHandleConfig -> LoggerHandleConfig -> Bool)
-> (LoggerHandleConfig -> LoggerHandleConfig -> Bool)
-> (LoggerHandleConfig -> LoggerHandleConfig -> Bool)
-> (LoggerHandleConfig -> LoggerHandleConfig -> LoggerHandleConfig)
-> (LoggerHandleConfig -> LoggerHandleConfig -> LoggerHandleConfig)
-> Ord 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
$cp1Ord :: Eq LoggerHandleConfig
Ord, Typeable, (forall x. LoggerHandleConfig -> Rep LoggerHandleConfig x)
-> (forall x. Rep LoggerHandleConfig x -> LoggerHandleConfig)
-> Generic LoggerHandleConfig
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 :: Text -> m LoggerHandleConfig
readLoggerHandleConfig Text
x = case Text -> Text
T.toLower Text
x of
Text
"stdout" → LoggerHandleConfig -> m LoggerHandleConfig
forall (m :: * -> *) a. Monad m => a -> m a
return LoggerHandleConfig
StdOut
Text
"stderr" → LoggerHandleConfig -> m LoggerHandleConfig
forall (m :: * -> *) a. Monad m => a -> m a
return LoggerHandleConfig
StdErr
Text
tx | Int -> Text -> Text
T.take Int
5 Text
tx Text -> Text -> Bool
forall α. Eq α => α -> α -> Bool
≡ Text
"file:" → LoggerHandleConfig -> m LoggerHandleConfig
forall (m :: * -> *) a. Monad m => a -> m a
return (LoggerHandleConfig -> m LoggerHandleConfig)
-> (Text -> LoggerHandleConfig) -> Text -> m LoggerHandleConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> LoggerHandleConfig
FileHandle (String -> LoggerHandleConfig)
-> (Text -> String) -> Text -> LoggerHandleConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> m LoggerHandleConfig) -> Text -> m LoggerHandleConfig
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop Int
5 Text
tx
Text
e → e -> m LoggerHandleConfig
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (e -> m LoggerHandleConfig) -> e -> m LoggerHandleConfig
forall a b. (a -> b) -> a -> b
$ e
"unexpected logger handle value: "
e -> e -> e
forall α. Monoid α => α -> α -> α
⊕ String -> e
forall a. IsString a => String -> a
fromString (Text -> String
forall a. Show a => a -> String
show Text
e)
e -> e -> e
forall α. Monoid α => α -> α -> α
⊕ e
", expected \"stdout\", \"stderr\", or \"file:<FILENAME>\""
loggerHandleConfigText
∷ (IsString a, Monoid a)
⇒ LoggerHandleConfig
→ a
loggerHandleConfigText :: LoggerHandleConfig -> a
loggerHandleConfigText LoggerHandleConfig
StdOut = a
"stdout"
loggerHandleConfigText LoggerHandleConfig
StdErr = a
"stderr"
loggerHandleConfigText (FileHandle String
f) = a
"file:" a -> a -> a
forall α. Monoid α => α -> α -> α
⊕ String -> a
forall a. IsString a => String -> a
fromString String
f
validateLoggerHandleConfig ∷ ConfigValidation LoggerHandleConfig λ
validateLoggerHandleConfig :: LoggerHandleConfig -> m ()
validateLoggerHandleConfig (FileHandle String
filepath) = Text -> String -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
Text -> String -> m ()
validateFileWritable Text
"file handle" String
filepath
validateLoggerHandleConfig LoggerHandleConfig
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
instance ToJSON LoggerHandleConfig where
toJSON :: LoggerHandleConfig -> Value
toJSON = Text -> Value
String (Text -> Value)
-> (LoggerHandleConfig -> Text) -> LoggerHandleConfig -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ LoggerHandleConfig -> Text
forall a. (IsString a, Monoid a) => LoggerHandleConfig -> a
loggerHandleConfigText
instance FromJSON LoggerHandleConfig where
parseJSON :: Value -> Parser LoggerHandleConfig
parseJSON = String
-> (Text -> Parser LoggerHandleConfig)
-> Value
-> Parser LoggerHandleConfig
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"LoggerHandleConfig" ((Text -> Parser LoggerHandleConfig)
-> Value -> Parser LoggerHandleConfig)
-> (Text -> Parser LoggerHandleConfig)
-> Value
-> Parser LoggerHandleConfig
forall a b. (a -> b) -> a -> b
$ (String -> Parser LoggerHandleConfig)
-> (LoggerHandleConfig -> Parser LoggerHandleConfig)
-> Either String LoggerHandleConfig
-> Parser LoggerHandleConfig
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser LoggerHandleConfig
forall (m :: * -> *) a. MonadFail m => String -> m a
fail LoggerHandleConfig -> Parser LoggerHandleConfig
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String LoggerHandleConfig -> Parser LoggerHandleConfig)
-> (Text -> Either String LoggerHandleConfig)
-> Text
-> Parser LoggerHandleConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ Text -> Either String LoggerHandleConfig
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
""
pLoggerHandleConfig_
∷ T.Text
→ O.Parser LoggerHandleConfig
pLoggerHandleConfig_ :: Text -> Parser LoggerHandleConfig
pLoggerHandleConfig_ Text
prefix = ReadM LoggerHandleConfig
-> Mod OptionFields LoggerHandleConfig -> Parser LoggerHandleConfig
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ((String -> Either String LoggerHandleConfig)
-> ReadM LoggerHandleConfig
forall a. (String -> Either String a) -> ReadM a
eitherReader (Text -> Either String LoggerHandleConfig
forall e (m :: * -> *).
(MonadError e m, IsString e, Monoid e) =>
Text -> m LoggerHandleConfig
readLoggerHandleConfig (Text -> Either String LoggerHandleConfig)
-> (String -> Text) -> String -> Either String LoggerHandleConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack))
(Mod OptionFields LoggerHandleConfig -> Parser LoggerHandleConfig)
-> Mod OptionFields LoggerHandleConfig -> Parser LoggerHandleConfig
forall a b. (a -> b) -> a -> b
% String -> Mod OptionFields LoggerHandleConfig
forall (f :: * -> *) a. HasName f => String -> Mod f a
long (Text -> String
T.unpack Text
prefix String -> ShowS
forall α. Monoid α => α -> α -> α
⊕ String
"logger-backend-handle")
Mod OptionFields LoggerHandleConfig
-> Mod OptionFields LoggerHandleConfig
-> Mod OptionFields LoggerHandleConfig
forall α. Monoid α => α -> α -> α
⊕ String -> Mod OptionFields LoggerHandleConfig
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"stdout|stderr|file:<FILENAME>"
Mod OptionFields LoggerHandleConfig
-> Mod OptionFields LoggerHandleConfig
-> Mod OptionFields LoggerHandleConfig
forall α. Monoid α => α -> α -> α
⊕ String -> Mod OptionFields LoggerHandleConfig
forall (f :: * -> *) a. String -> Mod f a
help String
"handle where the logs are written"
data HandleBackendConfig = HandleBackendConfig
{ HandleBackendConfig -> ColorOption
_handleBackendConfigColor ∷ !ColorOption
, HandleBackendConfig -> LoggerHandleConfig
_handleBackendConfigHandle ∷ !LoggerHandleConfig
}
deriving (Int -> HandleBackendConfig -> ShowS
[HandleBackendConfig] -> ShowS
HandleBackendConfig -> String
(Int -> HandleBackendConfig -> ShowS)
-> (HandleBackendConfig -> String)
-> ([HandleBackendConfig] -> ShowS)
-> Show HandleBackendConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HandleBackendConfig] -> ShowS
$cshowList :: [HandleBackendConfig] -> ShowS
show :: HandleBackendConfig -> String
$cshow :: HandleBackendConfig -> String
showsPrec :: Int -> HandleBackendConfig -> ShowS
$cshowsPrec :: Int -> HandleBackendConfig -> ShowS
Show, ReadPrec [HandleBackendConfig]
ReadPrec HandleBackendConfig
Int -> ReadS HandleBackendConfig
ReadS [HandleBackendConfig]
(Int -> ReadS HandleBackendConfig)
-> ReadS [HandleBackendConfig]
-> ReadPrec HandleBackendConfig
-> ReadPrec [HandleBackendConfig]
-> Read 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
(HandleBackendConfig -> HandleBackendConfig -> Bool)
-> (HandleBackendConfig -> HandleBackendConfig -> Bool)
-> Eq HandleBackendConfig
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
Eq HandleBackendConfig
-> (HandleBackendConfig -> HandleBackendConfig -> Ordering)
-> (HandleBackendConfig -> HandleBackendConfig -> Bool)
-> (HandleBackendConfig -> HandleBackendConfig -> Bool)
-> (HandleBackendConfig -> HandleBackendConfig -> Bool)
-> (HandleBackendConfig -> HandleBackendConfig -> Bool)
-> (HandleBackendConfig
-> HandleBackendConfig -> HandleBackendConfig)
-> (HandleBackendConfig
-> HandleBackendConfig -> HandleBackendConfig)
-> Ord 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
$cp1Ord :: Eq HandleBackendConfig
Ord, Typeable, (forall x. HandleBackendConfig -> Rep HandleBackendConfig x)
-> (forall x. Rep HandleBackendConfig x -> HandleBackendConfig)
-> Generic HandleBackendConfig
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 :: (ColorOption -> f ColorOption)
-> HandleBackendConfig -> f HandleBackendConfig
handleBackendConfigColor = (HandleBackendConfig -> ColorOption)
-> (HandleBackendConfig -> ColorOption -> HandleBackendConfig)
-> Lens
HandleBackendConfig HandleBackendConfig ColorOption ColorOption
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens HandleBackendConfig -> ColorOption
_handleBackendConfigColor ((HandleBackendConfig -> ColorOption -> HandleBackendConfig)
-> Lens
HandleBackendConfig HandleBackendConfig ColorOption ColorOption)
-> (HandleBackendConfig -> ColorOption -> HandleBackendConfig)
-> Lens
HandleBackendConfig HandleBackendConfig ColorOption ColorOption
forall a b. (a -> b) -> a -> b
$ \HandleBackendConfig
a ColorOption
b → HandleBackendConfig
a { _handleBackendConfigColor :: ColorOption
_handleBackendConfigColor = ColorOption
b }
handleBackendConfigHandle ∷ Lens' HandleBackendConfig LoggerHandleConfig
handleBackendConfigHandle :: (LoggerHandleConfig -> f LoggerHandleConfig)
-> HandleBackendConfig -> f HandleBackendConfig
handleBackendConfigHandle = (HandleBackendConfig -> LoggerHandleConfig)
-> (HandleBackendConfig
-> LoggerHandleConfig -> HandleBackendConfig)
-> Lens
HandleBackendConfig
HandleBackendConfig
LoggerHandleConfig
LoggerHandleConfig
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens HandleBackendConfig -> LoggerHandleConfig
_handleBackendConfigHandle ((HandleBackendConfig -> LoggerHandleConfig -> HandleBackendConfig)
-> Lens
HandleBackendConfig
HandleBackendConfig
LoggerHandleConfig
LoggerHandleConfig)
-> (HandleBackendConfig
-> LoggerHandleConfig -> HandleBackendConfig)
-> Lens
HandleBackendConfig
HandleBackendConfig
LoggerHandleConfig
LoggerHandleConfig
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 :: ColorOption -> LoggerHandleConfig -> HandleBackendConfig
HandleBackendConfig
{ _handleBackendConfigColor :: ColorOption
_handleBackendConfigColor = ColorOption
defaultColorOption
, _handleBackendConfigHandle :: LoggerHandleConfig
_handleBackendConfigHandle = LoggerHandleConfig
StdOut
}
validateHandleBackendConfig ∷ ConfigValidation HandleBackendConfig []
validateHandleBackendConfig :: HandleBackendConfig -> m ()
validateHandleBackendConfig HandleBackendConfig{ColorOption
LoggerHandleConfig
_handleBackendConfigHandle :: LoggerHandleConfig
_handleBackendConfigColor :: ColorOption
_handleBackendConfigHandle :: HandleBackendConfig -> LoggerHandleConfig
_handleBackendConfigColor :: HandleBackendConfig -> ColorOption
..} = do
LoggerHandleConfig -> m ()
forall (λ :: * -> *). ConfigValidation LoggerHandleConfig λ
validateLoggerHandleConfig LoggerHandleConfig
_handleBackendConfigHandle
case (LoggerHandleConfig
_handleBackendConfigHandle, ColorOption
_handleBackendConfigColor) of
(FileHandle String
_, ColorOption
ColorTrue) →
[Text] -> m ()
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)
_ → () -> m ()
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" Key -> ColorOption -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ColorOption
_handleBackendConfigColor
, Key
"handle" Key -> LoggerHandleConfig -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= LoggerHandleConfig
_handleBackendConfigHandle
]
instance FromJSON (HandleBackendConfig → HandleBackendConfig) where
parseJSON :: Value -> Parser (HandleBackendConfig -> HandleBackendConfig)
parseJSON = String
-> (Object -> Parser (HandleBackendConfig -> HandleBackendConfig))
-> Value
-> Parser (HandleBackendConfig -> HandleBackendConfig)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"HandleBackendConfig" ((Object -> Parser (HandleBackendConfig -> HandleBackendConfig))
-> Value -> Parser (HandleBackendConfig -> HandleBackendConfig))
-> (Object -> Parser (HandleBackendConfig -> HandleBackendConfig))
-> Value
-> Parser (HandleBackendConfig -> HandleBackendConfig)
forall a b. (a -> b) -> a -> b
$ \Object
o → HandleBackendConfig -> HandleBackendConfig
forall a. a -> a
id
(HandleBackendConfig -> HandleBackendConfig)
-> Parser (HandleBackendConfig -> HandleBackendConfig)
-> Parser (HandleBackendConfig -> HandleBackendConfig)
forall (f :: * -> *) b c a.
Functor f =>
(b -> c) -> f (a -> b) -> f (a -> c)
<$< Lens
HandleBackendConfig HandleBackendConfig ColorOption ColorOption
handleBackendConfigColor Lens
HandleBackendConfig HandleBackendConfig ColorOption ColorOption
-> Text
-> Object
-> Parser (HandleBackendConfig -> HandleBackendConfig)
forall b a.
FromJSON b =>
Lens' a b -> Text -> Object -> Parser (a -> a)
..: Text
"color" (Object -> Parser (HandleBackendConfig -> HandleBackendConfig))
-> Object -> Parser (HandleBackendConfig -> HandleBackendConfig)
forall a b. (a -> b) -> a -> b
% Object
o
Parser (HandleBackendConfig -> HandleBackendConfig)
-> Parser (HandleBackendConfig -> HandleBackendConfig)
-> Parser (HandleBackendConfig -> HandleBackendConfig)
forall (f :: * -> *) b c a.
Applicative f =>
f (b -> c) -> f (a -> b) -> f (a -> c)
<*< Lens
HandleBackendConfig
HandleBackendConfig
LoggerHandleConfig
LoggerHandleConfig
handleBackendConfigHandle Lens
HandleBackendConfig
HandleBackendConfig
LoggerHandleConfig
LoggerHandleConfig
-> Text
-> Object
-> Parser (HandleBackendConfig -> HandleBackendConfig)
forall b a.
FromJSON b =>
Lens' a b -> Text -> Object -> Parser (a -> a)
..: Text
"handle" (Object -> Parser (HandleBackendConfig -> HandleBackendConfig))
-> Object -> Parser (HandleBackendConfig -> HandleBackendConfig)
forall a b. (a -> b) -> a -> b
% Object
o
pHandleBackendConfig ∷ MParser HandleBackendConfig
pHandleBackendConfig :: MParser HandleBackendConfig
pHandleBackendConfig = Text -> MParser HandleBackendConfig
pHandleBackendConfig_ Text
""
pHandleBackendConfig_
∷ T.Text
→ MParser HandleBackendConfig
pHandleBackendConfig_ :: Text -> MParser HandleBackendConfig
pHandleBackendConfig_ Text
prefix = HandleBackendConfig -> HandleBackendConfig
forall a. a -> a
id
(HandleBackendConfig -> HandleBackendConfig)
-> MParser HandleBackendConfig -> MParser HandleBackendConfig
forall (f :: * -> *) b c a.
Functor f =>
(b -> c) -> f (a -> b) -> f (a -> c)
<$< Lens
HandleBackendConfig HandleBackendConfig ColorOption ColorOption
handleBackendConfigColor Lens
HandleBackendConfig HandleBackendConfig ColorOption ColorOption
-> Parser ColorOption -> MParser HandleBackendConfig
forall (f :: * -> *) a b.
(Alternative f, Applicative f) =>
Lens' a b -> f b -> f (a -> a)
.:: Text -> Parser ColorOption
pColorOption_ Text
prefix
MParser HandleBackendConfig
-> MParser HandleBackendConfig -> MParser HandleBackendConfig
forall (f :: * -> *) b c a.
Applicative f =>
f (b -> c) -> f (a -> b) -> f (a -> c)
<*< Lens
HandleBackendConfig
HandleBackendConfig
LoggerHandleConfig
LoggerHandleConfig
handleBackendConfigHandle Lens
HandleBackendConfig
HandleBackendConfig
LoggerHandleConfig
LoggerHandleConfig
-> Parser LoggerHandleConfig -> MParser HandleBackendConfig
forall (f :: * -> *) a b.
(Alternative f, Applicative f) =>
Lens' a b -> f b -> f (a -> a)
.:: Text -> Parser LoggerHandleConfig
pLoggerHandleConfig_ Text
prefix
withHandleBackend
∷ (MonadIO m, MonadBaseControl IO m)
⇒ HandleBackendConfig
→ (LoggerBackend T.Text → m α)
→ m α
withHandleBackend :: HandleBackendConfig -> (LoggerBackend Text -> m α) -> m α
withHandleBackend = (Text -> Text)
-> HandleBackendConfig -> (LoggerBackend Text -> m α) -> m α
forall (m :: * -> *) msg α.
(MonadIO m, MonadBaseControl IO m) =>
(msg -> Text)
-> HandleBackendConfig -> (LoggerBackend msg -> m α) -> m α
withHandleBackend_ Text -> Text
forall a. a -> a
id
{-# INLINE withHandleBackend #-}
withHandleBackend_
∷ (MonadIO m, MonadBaseControl IO m)
⇒ (msg → T.Text)
→ HandleBackendConfig
→ (LoggerBackend msg → m α)
→ m α
withHandleBackend_ :: (msg -> Text)
-> HandleBackendConfig -> (LoggerBackend msg -> m α) -> m α
withHandleBackend_ msg -> Text
format HandleBackendConfig
conf LoggerBackend msg -> m α
inner =
case HandleBackendConfig
conf HandleBackendConfig
-> Getting
LoggerHandleConfig HandleBackendConfig LoggerHandleConfig
-> LoggerHandleConfig
forall s a. s -> Getting a s a -> a
^. Getting LoggerHandleConfig HandleBackendConfig LoggerHandleConfig
Lens
HandleBackendConfig
HandleBackendConfig
LoggerHandleConfig
LoggerHandleConfig
handleBackendConfigHandle of
LoggerHandleConfig
StdErr → Handle -> m α
run Handle
stderr
LoggerHandleConfig
StdOut → Handle -> m α
run Handle
stdout
FileHandle String
f → ((Handle -> IO (StM m α)) -> IO (StM m α))
-> (Handle -> m α) -> m α
forall (b :: * -> *) (m :: * -> *) a c d.
MonadBaseControl b m =>
((a -> b (StM m c)) -> b (StM m d)) -> (a -> m c) -> m d
liftBaseOp (String -> IOMode -> (Handle -> IO (StM m α)) -> IO (StM m α)
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
f IOMode
AppendMode) Handle -> m α
run
where
run :: Handle -> m α
run Handle
h = do
Bool
colored ← IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ ColorOption -> Handle -> IO Bool
useColor (HandleBackendConfig
conf HandleBackendConfig
-> Getting ColorOption HandleBackendConfig ColorOption
-> ColorOption
forall s a. s -> Getting a s a -> a
^. Getting ColorOption HandleBackendConfig ColorOption
Lens
HandleBackendConfig HandleBackendConfig ColorOption ColorOption
handleBackendConfigColor) Handle
h
LoggerBackend msg -> m α
inner (LoggerBackend msg -> m α) -> LoggerBackend msg -> m α
forall a b. (a -> b) -> a -> b
$ (msg -> Text) -> Handle -> Bool -> LoggerBackend msg
forall msg. (msg -> Text) -> Handle -> Bool -> LoggerBackend msg
handleBackend_ msg -> Text
format Handle
h Bool
colored
handleBackend
∷ Handle
→ Bool
→ LoggerBackend T.Text
handleBackend :: Handle -> Bool -> LoggerBackend Text
handleBackend = (Text -> Text) -> Handle -> Bool -> LoggerBackend Text
forall msg. (msg -> Text) -> Handle -> Bool -> LoggerBackend msg
handleBackend_ Text -> Text
forall a. a -> a
id
{-# INLINE handleBackend #-}
handleBackend_
∷ (msg → T.Text)
→ Handle
→ Bool
→ LoggerBackend msg
handleBackend_ :: (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
(Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ TimeSpec -> Text
forall a. IsString a => TimeSpec -> a
formatIso8601Milli (LogMessage Text
msg LogMessage Text
-> Getting TimeSpec (LogMessage Text) TimeSpec -> TimeSpec
forall s a. s -> Getting a s a -> a
^. Getting TimeSpec (LogMessage Text) TimeSpec
forall a. Lens' (LogMessage a) TimeSpec
logMsgTime) Text -> Text -> Text
forall α. Monoid α => α -> α -> α
⊕ Text
" "
Text -> Text -> Text
forall α. Monoid α => α -> α -> α
⊕ Bool -> Text -> Text
inLevelColor Bool
colored (Text
"[" Text -> Text -> Text
forall α. Monoid α => α -> α -> α
⊕ LogLevel -> Text
forall a b. (Show a, IsString b) => a -> b
sshow LogLevel
level Text -> Text -> Text
forall α. Monoid α => α -> α -> α
⊕ Text
"] ")
Text -> Text -> Text
forall α. Monoid α => α -> α -> α
⊕ Bool -> Text -> Text
inScopeColor Bool
colored (Text
"[" Text -> Text -> Text
forall α. Monoid α => α -> α -> α
⊕ Text
formatedScope Text -> Text -> Text
forall α. Monoid α => α -> α -> α
⊕ Text
"] ")
Text -> Text -> Text
forall α. Monoid α => α -> α -> α
⊕ (LogMessage Text
msg LogMessage Text -> Getting Text (LogMessage Text) Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text (LogMessage Text) Text
forall a b. Lens (LogMessage a) (LogMessage b) a b
logMsg)
where
msg :: LogMessage Text
msg = (LogMessage Text -> LogMessage Text)
-> (LogMessage msg -> LogMessage Text)
-> Either (LogMessage Text) (LogMessage msg)
-> LogMessage Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either LogMessage Text -> LogMessage Text
forall a. a -> a
id ((msg -> Identity Text)
-> LogMessage msg -> Identity (LogMessage Text)
forall a b. Lens (LogMessage a) (LogMessage b) a b
logMsg ((msg -> Identity Text)
-> LogMessage msg -> Identity (LogMessage Text))
-> (msg -> Text) -> LogMessage msg -> LogMessage Text
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 LogMessage Text
-> Getting LogLevel (LogMessage Text) LogLevel -> LogLevel
forall s a. s -> Getting a s a -> a
^. Getting LogLevel (LogMessage Text) LogLevel
forall a. Lens' (LogMessage a) LogLevel
logMsgLevel
formatedScope :: Text
formatedScope = Text -> [Text] -> Text
T.intercalate Text
"|" ([Text] -> Text)
-> ([(Text, Text)] -> [Text]) -> [(Text, Text)] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
L.map (Text, Text) -> Text
forall α. (Monoid α, IsString α) => (α, α) -> α
formatLabel ([(Text, Text)] -> [Text])
-> ([(Text, Text)] -> [(Text, Text)]) -> [(Text, Text)] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a]
reverse ([(Text, Text)] -> Text) -> [(Text, Text)] -> Text
forall a b. (a -> b) -> a -> b
$ LogMessage Text
msg LogMessage Text
-> Getting [(Text, Text)] (LogMessage Text) [(Text, Text)]
-> [(Text, Text)]
forall s a. s -> Getting a s a -> a
^. Getting [(Text, Text)] (LogMessage Text) [(Text, Text)]
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 = Text -> Text
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
_ → Text -> Text
forall a. a -> a
id
inLevelColor Bool
False = Text -> Text
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 = String -> Text
T.pack ([SGR] -> String
A.setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
A.SetColor ConsoleLayer
A.Foreground ColorIntensity
i Color
c]) Text -> Text -> Text
forall α. Monoid α => α -> α -> α
⊕ Text
t Text -> Text -> Text
forall α. Monoid α => α -> α -> α
⊕ String -> Text
T.pack ([SGR] -> String
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_ #-}