\subsection{Cardano.BM.Backend.Log}
\label{code:Cardano.BM.Backend.Log}

%if style == newcode
\begin{code}
{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Cardano.BM.Backend.Log
    (
      Log
    , effectuate
    , realize
    , unrealize
    , registerScribe
    , sev2klog
    -- * re-exports
    , K.Scribe
    ) where

import           Control.AutoUpdate (UpdateSettings (..), defaultUpdateSettings,
                     mkAutoUpdate)
import           Control.Concurrent.MVar (MVar, modifyMVar_, readMVar,
                     newMVar, withMVar)
import           Control.Exception.Safe (catchIO)
import           Control.Monad (foldM, forM_, unless, when, void)
import           Data.Aeson (FromJSON, ToJSON, Result (Success), Value (..),
                     encode, fromJSON, toJSON)
import           Data.Aeson.Text (encodeToLazyText)
import qualified Data.HashMap.Strict as HM
import qualified Data.Map as Map
import           Data.List (find)
import           Data.Maybe (isNothing)
import           Data.String (fromString)
import           Data.Text (Text, isPrefixOf, pack, unpack)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import           Data.Text.Lazy.Builder (Builder, fromText, toLazyText)
import qualified Data.Text.Lazy.IO as TIO
import           Data.Time (diffUTCTime)
import           Data.Time.Clock (UTCTime, getCurrentTime)
import           Data.Time.Format (defaultTimeLocale, formatTime)
import           GHC.Conc (atomically)
import           GHC.IO.Handle (hDuplicate)
import           System.Directory (createDirectoryIfMissing)
import           System.FilePath (takeDirectory)
import           System.IO (BufferMode (LineBuffering), Handle, hClose,
                     hSetBuffering, stderr, stdout, openFile, IOMode (WriteMode))

import qualified Katip as K
import qualified Katip.Core as KC
import           Katip.Scribes.Handle (brackets)

import qualified Cardano.BM.Configuration as Config
import           Cardano.BM.Configuration.Model (getScribes, getSetupScribes)
import           Cardano.BM.Data.Aggregated
import           Cardano.BM.Data.Backend
import           Cardano.BM.Data.LogItem
import           Cardano.BM.Data.Output
import           Cardano.BM.Data.Rotation (RotationParameters (..))
import           Cardano.BM.Data.Severity
import           Cardano.BM.Rotator (cleanupRotator, evalRotator,
                     initializeRotator, prtoutException)

\end{code}
%endif

\subsubsection{Internal representation}\label{code:Log}\index{Log}
\begin{code}
type LogMVar = MVar LogInternal
newtype Log a = Log
    { Log a -> LogMVar
getK :: LogMVar }

data LogInternal = LogInternal
    { LogInternal -> LogEnv
kLogEnv       :: K.LogEnv
    , LogInternal -> Configuration
configuration :: Config.Configuration }

\end{code}

\subsubsection{Log implements |effectuate|}\index{Log!instance of IsEffectuator}
\begin{code}
instance ToJSON a => IsEffectuator Log a where
    effectuate :: Log a -> LogObject a -> IO ()
effectuate Log a
katip LogObject a
item = do
        let logMVar :: LogMVar
logMVar = Log a -> LogMVar
forall a. Log a -> LogMVar
getK Log a
katip
        -- TODO cache scribe lists, update every n minutes
        Configuration
c <- LogInternal -> Configuration
configuration (LogInternal -> Configuration)
-> IO LogInternal -> IO Configuration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LogMVar -> IO LogInternal
forall a. MVar a -> IO a
readMVar LogMVar
logMVar
        [ScribeDefinition]
setupScribes <- Configuration -> IO [ScribeDefinition]
getSetupScribes Configuration
c
        [ScribeId]
selscribes <- Configuration -> ScribeId -> IO [ScribeId]
getScribes Configuration
c (LogObject a -> ScribeId
forall a. LogObject a -> ScribeId
loName LogObject a
item)
        let selscribesFiltered :: [ScribeId]
selscribesFiltered =
                case LogObject a
item of
                    LogObject ScribeId
_ (LOMeta UTCTime
_ ScribeId
_ ScribeId
_ Severity
_ PrivacyAnnotation
Confidential) (LogMessage a
_)
                        -> [ScribeDefinition] -> [ScribeId] -> [ScribeId]
forall (t :: * -> *).
Foldable t =>
t ScribeDefinition -> [ScribeId] -> [ScribeId]
removePublicScribes [ScribeDefinition]
setupScribes [ScribeId]
selscribes
                    LogObject a
_   -> [ScribeId]
selscribes
            sev :: Severity
            sev :: Severity
sev = LOMeta -> Severity
severity (LogObject a -> LOMeta
forall a. LogObject a -> LOMeta
loMeta LogObject a
item)
        [ScribeId] -> (ScribeId -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ScribeFormat
-> Severity -> [ScribeDefinition] -> [ScribeId] -> [ScribeId]
onlyScribes ScribeFormat
ScText Severity
sev [ScribeDefinition]
setupScribes [ScribeId]
selscribesFiltered) ((ScribeId -> IO ()) -> IO ()) -> (ScribeId -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ScribeId
sc -> ScribeId -> Log a -> LogObject a -> IO ()
forall a. ToJSON a => ScribeId -> Log a -> LogObject a -> IO ()
passText ScribeId
sc Log a
katip LogObject a
item
        [ScribeId] -> (ScribeId -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ScribeFormat
-> Severity -> [ScribeDefinition] -> [ScribeId] -> [ScribeId]
onlyScribes ScribeFormat
ScJson Severity
sev [ScribeDefinition]
setupScribes [ScribeId]
selscribesFiltered) ((ScribeId -> IO ()) -> IO ()) -> (ScribeId -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ScribeId
sc -> ScribeId -> Log a -> LogObject a -> IO ()
forall a. ToJSON a => ScribeId -> Log a -> LogObject a -> IO ()
passStrx ScribeId
sc Log a
katip LogObject a
item
      where
        removePublicScribes :: t ScribeDefinition -> [ScribeId] -> [ScribeId]
removePublicScribes t ScribeDefinition
allScribes = (ScribeId -> Bool) -> [ScribeId] -> [ScribeId]
forall a. (a -> Bool) -> [a] -> [a]
filter ((ScribeId -> Bool) -> [ScribeId] -> [ScribeId])
-> (ScribeId -> Bool) -> [ScribeId] -> [ScribeId]
forall a b. (a -> b) -> a -> b
$ \ScribeId
scn ->
            let (ScribeId
_, ScribeId
nameD) = ScribeId -> ScribeId -> (ScribeId, ScribeId)
T.breakOn ScribeId
"::" ScribeId
scn
                name :: ScribeId
name = Int -> ScribeId -> ScribeId
T.drop Int
2 ScribeId
nameD -- drop "::" from the start of name
            in
            case (ScribeDefinition -> Bool)
-> t ScribeDefinition -> Maybe ScribeDefinition
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\ScribeDefinition
scd -> ScribeDefinition -> ScribeId
scName ScribeDefinition
scd ScribeId -> ScribeId -> Bool
forall a. Eq a => a -> a -> Bool
== ScribeId
name) t ScribeDefinition
allScribes of
                Maybe ScribeDefinition
Nothing     -> Bool
False
                Just ScribeDefinition
scribe -> ScribeDefinition -> ScribePrivacy
scPrivacy ScribeDefinition
scribe ScribePrivacy -> ScribePrivacy -> Bool
forall a. Eq a => a -> a -> Bool
== ScribePrivacy
ScPrivate
        onlyScribes :: ScribeFormat -> Severity -> [ScribeDefinition] -> [Text] -> [Text]
        onlyScribes :: ScribeFormat
-> Severity -> [ScribeDefinition] -> [ScribeId] -> [ScribeId]
onlyScribes ScribeFormat
form Severity
sev [ScribeDefinition]
allScribes = (ScribeId -> Bool) -> [ScribeId] -> [ScribeId]
forall a. (a -> Bool) -> [a] -> [a]
filter ((ScribeId -> Bool) -> [ScribeId] -> [ScribeId])
-> (ScribeId -> Bool) -> [ScribeId] -> [ScribeId]
forall a b. (a -> b) -> a -> b
$ \ScribeId
scn ->
            case (ScribeDefinition -> Bool)
-> [ScribeDefinition] -> Maybe ScribeDefinition
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\ScribeDefinition
scd -> String -> ScribeId
pack (ScribeKind -> String
forall a. Show a => a -> String
show (ScribeKind -> String) -> ScribeKind -> String
forall a b. (a -> b) -> a -> b
$ ScribeDefinition -> ScribeKind
scKind ScribeDefinition
scd) ScribeId -> ScribeId -> ScribeId
forall a. Semigroup a => a -> a -> a
<> ScribeId
"::" ScribeId -> ScribeId -> ScribeId
forall a. Semigroup a => a -> a -> a
<> ScribeDefinition -> ScribeId
scName ScribeDefinition
scd ScribeId -> ScribeId -> Bool
forall a. Eq a => a -> a -> Bool
== ScribeId
scn) [ScribeDefinition]
allScribes of
                Maybe ScribeDefinition
Nothing     -> Bool
False
                Just ScribeDefinition
scribe -> ScribeDefinition -> ScribeFormat
scFormat ScribeDefinition
scribe ScribeFormat -> ScribeFormat -> Bool
forall a. Eq a => a -> a -> Bool
== ScribeFormat
form Bool -> Bool -> Bool
&& ScribeDefinition -> Severity
scMinSev ScribeDefinition
scribe Severity -> Severity -> Bool
forall a. Ord a => a -> a -> Bool
<= Severity
sev Bool -> Bool -> Bool
&& ScribeDefinition -> Severity
scMaxSev ScribeDefinition
scribe Severity -> Severity -> Bool
forall a. Ord a => a -> a -> Bool
>= Severity
sev

    handleOverflow :: Log a -> IO ()
handleOverflow Log a
_ = Handle -> Text -> IO ()
TIO.hPutStrLn Handle
stderr Text
"Notice: Katip's queue full, dropping log items!"

\end{code}

\subsubsection{Log implements backend functions}\index{Log!instance of IsBackend}
\begin{code}
instance (ToJSON a, FromJSON a) => IsBackend Log a where
    bekind :: Log a -> BackendKind
bekind Log a
_ = BackendKind
KatipBK

    realize :: Configuration -> IO (Log a)
realize Configuration
config = do
        let updateEnv :: K.LogEnv -> IO UTCTime -> K.LogEnv
            updateEnv :: LogEnv -> IO UTCTime -> LogEnv
updateEnv LogEnv
le IO UTCTime
timer =
                LogEnv
le { _logEnvTimer :: IO UTCTime
K._logEnvTimer = IO UTCTime
timer, _logEnvHost :: String
K._logEnvHost = String
"hostname" }
        ScribeId
ver <- Configuration -> ScribeId -> ScribeId -> IO ScribeId
Config.getTextOptionOrDefault Configuration
config ScribeId
"appversion" ScribeId
"<unknown>"
        ScribeId
commit <- Configuration -> ScribeId -> ScribeId -> IO ScribeId
Config.getTextOptionOrDefault Configuration
config ScribeId
"appcommit" ScribeId
"00000"
        LogEnv
le0 <- Namespace -> Environment -> IO LogEnv
K.initLogEnv
                    ([ScribeId] -> Namespace
K.Namespace [ScribeId]
forall a. Monoid a => a
mempty)
                    (String -> Environment
forall a. IsString a => String -> a
fromString (String -> Environment) -> String -> Environment
forall a b. (a -> b) -> a -> b
$ ScribeId -> String
unpack ScribeId
ver String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
5 (ScribeId -> String
unpack ScribeId
commit))
        -- request a new time 'getCurrentTime' at most 100 times a second
        IO UTCTime
timer <- UpdateSettings UTCTime -> IO (IO UTCTime)
forall a. UpdateSettings a -> IO (IO a)
mkAutoUpdate UpdateSettings ()
defaultUpdateSettings { updateAction :: IO UTCTime
updateAction = IO UTCTime
getCurrentTime, updateFreq :: Int
updateFreq = Int
10000 }
        let le1 :: LogEnv
le1 = LogEnv -> IO UTCTime -> LogEnv
updateEnv LogEnv
le0 IO UTCTime
timer
        [ScribeDefinition]
scribes <- Configuration -> IO [ScribeDefinition]
getSetupScribes Configuration
config
        LogEnv
le <- [ScribeDefinition] -> LogEnv -> IO LogEnv
registerScribes [ScribeDefinition]
scribes LogEnv
le1

        LogMVar
kref <- LogInternal -> IO LogMVar
forall a. a -> IO (MVar a)
newMVar (LogInternal -> IO LogMVar) -> LogInternal -> IO LogMVar
forall a b. (a -> b) -> a -> b
$ LogEnv -> Configuration -> LogInternal
LogInternal LogEnv
le Configuration
config

        Log a -> IO (Log a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Log a -> IO (Log a)) -> Log a -> IO (Log a)
forall a b. (a -> b) -> a -> b
$ LogMVar -> Log a
forall a. LogMVar -> Log a
Log LogMVar
kref

    unrealize :: Log a -> IO ()
unrealize Log a
katip = do
        LogEnv
le <- LogMVar -> (LogInternal -> IO LogEnv) -> IO LogEnv
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (Log a -> LogMVar
forall a. Log a -> LogMVar
getK Log a
katip) ((LogInternal -> IO LogEnv) -> IO LogEnv)
-> (LogInternal -> IO LogEnv) -> IO LogEnv
forall a b. (a -> b) -> a -> b
$ \LogInternal
k -> LogEnv -> IO LogEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (LogInternal -> LogEnv
kLogEnv LogInternal
k)
        IO LogEnv -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO LogEnv -> IO ()) -> IO LogEnv -> IO ()
forall a b. (a -> b) -> a -> b
$ LogEnv -> IO LogEnv
K.closeScribes LogEnv
le

\end{code}

\subsubsection{Create and register \emph{katip} scribes}
\begin{code}
registerScribe :: Log a -> K.Scribe -> ScribeId -> IO ()
registerScribe :: Log a -> Scribe -> ScribeId -> IO ()
registerScribe Log a
katip Scribe
scr ScribeId
name =
    LogMVar -> (LogInternal -> IO LogInternal) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (Log a -> LogMVar
forall a. Log a -> LogMVar
getK Log a
katip) ((LogInternal -> IO LogInternal) -> IO ())
-> (LogInternal -> IO LogInternal) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LogInternal
k -> do
        LogEnv
newenv <- ScribeId -> Scribe -> ScribeSettings -> LogEnv -> IO LogEnv
K.registerScribe ScribeId
name Scribe
scr ScribeSettings
scribeSettings (LogInternal -> LogEnv
kLogEnv LogInternal
k)

        LogInternal -> IO LogInternal
forall (m :: * -> *) a. Monad m => a -> m a
return (LogInternal -> IO LogInternal) -> LogInternal -> IO LogInternal
forall a b. (a -> b) -> a -> b
$ LogInternal
k { kLogEnv :: LogEnv
kLogEnv = LogEnv
newenv }


scribeSettings :: KC.ScribeSettings
scribeSettings :: ScribeSettings
scribeSettings =
    let bufferSize :: Int
bufferSize = Int
5000  -- size of the queue (in log items)
    in
    Int -> ScribeSettings
KC.ScribeSettings Int
bufferSize

registerScribes :: [ScribeDefinition] -> K.LogEnv -> IO K.LogEnv
registerScribes :: [ScribeDefinition] -> LogEnv -> IO LogEnv
registerScribes [ScribeDefinition]
defscs LogEnv
le =
    (LogEnv -> ScribeDefinition -> IO LogEnv)
-> LogEnv -> [ScribeDefinition] -> IO LogEnv
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM LogEnv -> ScribeDefinition -> IO LogEnv
withScribeInEnv LogEnv
le [ScribeDefinition]
defscs
  where
    withScribeInEnv :: K.LogEnv -> ScribeDefinition -> IO K.LogEnv
    withScribeInEnv :: LogEnv -> ScribeDefinition -> IO LogEnv
withScribeInEnv LogEnv
le' ScribeDefinition
defsc = do
            let kind :: ScribeKind
kind = ScribeDefinition -> ScribeKind
scKind ScribeDefinition
defsc
                sctype :: ScribeFormat
sctype = ScribeDefinition -> ScribeFormat
scFormat ScribeDefinition
defsc
                name :: ScribeId
name = ScribeDefinition -> ScribeId
scName ScribeDefinition
defsc
                rotParams :: Maybe RotationParameters
rotParams = ScribeDefinition -> Maybe RotationParameters
scRotation ScribeDefinition
defsc
                name' :: ScribeId
name' = String -> ScribeId
pack (ScribeKind -> String
forall a. Show a => a -> String
show ScribeKind
kind) ScribeId -> ScribeId -> ScribeId
forall a. Semigroup a => a -> a -> a
<> ScribeId
"::" ScribeId -> ScribeId -> ScribeId
forall a. Semigroup a => a -> a -> a
<> ScribeId
name
            Maybe Scribe
scribe <- ScribeKind
-> ScribeFormat
-> ScribeId
-> Maybe RotationParameters
-> IO (Maybe Scribe)
createScribe ScribeKind
kind ScribeFormat
sctype ScribeId
name Maybe RotationParameters
rotParams
            case Maybe Scribe
scribe of
                Just Scribe
scr -> ScribeId -> Scribe -> ScribeSettings -> LogEnv -> IO LogEnv
K.registerScribe ScribeId
name' Scribe
scr ScribeSettings
scribeSettings LogEnv
le'
                Maybe Scribe
Nothing -> LogEnv -> IO LogEnv
forall (m :: * -> *) a. Monad m => a -> m a
return LogEnv
le'

    createScribe :: ScribeKind
-> ScribeFormat
-> ScribeId
-> Maybe RotationParameters
-> IO (Maybe Scribe)
createScribe ScribeKind
FileSK ScribeFormat
ScText ScribeId
name Maybe RotationParameters
rotParams = Scribe -> Maybe Scribe
forall a. a -> Maybe a
Just (Scribe -> Maybe Scribe) -> IO Scribe -> IO (Maybe Scribe)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RotationParameters -> FileDescription -> Bool -> IO Scribe
mkTextFileScribe
                                                    Maybe RotationParameters
rotParams
                                                    (String -> FileDescription
FileDescription (String -> FileDescription) -> String -> FileDescription
forall a b. (a -> b) -> a -> b
$ ScribeId -> String
unpack ScribeId
name)
                                                    Bool
False
    createScribe ScribeKind
FileSK ScribeFormat
ScJson ScribeId
name Maybe RotationParameters
rotParams = Scribe -> Maybe Scribe
forall a. a -> Maybe a
Just (Scribe -> Maybe Scribe) -> IO Scribe -> IO (Maybe Scribe)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RotationParameters -> FileDescription -> Bool -> IO Scribe
mkJsonFileScribe
                                                    Maybe RotationParameters
rotParams
                                                    (String -> FileDescription
FileDescription (String -> FileDescription) -> String -> FileDescription
forall a b. (a -> b) -> a -> b
$ ScribeId -> String
unpack ScribeId
name)
                                                    Bool
False
    createScribe ScribeKind
StdoutSK ScribeFormat
sctype ScribeId
_ Maybe RotationParameters
_ = Scribe -> Maybe Scribe
forall a. a -> Maybe a
Just (Scribe -> Maybe Scribe) -> IO Scribe -> IO (Maybe Scribe)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScribeFormat -> IO Scribe
mkStdoutScribe ScribeFormat
sctype
    createScribe ScribeKind
StderrSK ScribeFormat
sctype ScribeId
_ Maybe RotationParameters
_ = Scribe -> Maybe Scribe
forall a. a -> Maybe a
Just (Scribe -> Maybe Scribe) -> IO Scribe -> IO (Maybe Scribe)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScribeFormat -> IO Scribe
mkStderrScribe ScribeFormat
sctype
    createScribe ScribeKind
DevNullSK ScribeFormat
_ ScribeId
_ Maybe RotationParameters
_ = Scribe -> Maybe Scribe
forall a. a -> Maybe a
Just (Scribe -> Maybe Scribe) -> IO Scribe -> IO (Maybe Scribe)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Scribe
mkDevNullScribe
    createScribe ScribeKind
JournalSK ScribeFormat
_ ScribeId
_ Maybe RotationParameters
_ = Maybe Scribe -> IO (Maybe Scribe)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Scribe
forall a. Maybe a
Nothing
    createScribe ScribeKind
UserDefinedSK ScribeFormat
ty ScribeId
nm Maybe RotationParameters
rot = ScribeKind
-> ScribeFormat
-> ScribeId
-> Maybe RotationParameters
-> IO (Maybe Scribe)
createScribe ScribeKind
FileSK ScribeFormat
ty ScribeId
nm Maybe RotationParameters
rot

\end{code}


\begin{spec}
example :: IO ()
example = do
    config <- Config.setup "from_some_path.yaml"
    k <- setup config
    meta <- mkLOMeta Info Public
    passText (pack (show StdoutSK)) k $ LogObject
                                            { loName = ["test"]
                                            , loMeta = meta
                                            , loContent = LogMessage "Hello!"
                                            }
    meta' <- mkLOMeta Info Public
    passStrx (pack (show StdoutSK)) k $ LogObject
                                            { loName = ["test"]
                                            , loMeta = meta'
                                            , loContent = LogValue "cpu-no" 1
                                            }

\end{spec}

Needed instances for |katip|:
\begin{code}
deriving instance ToJSON a => K.ToObject (LogObject a)
deriving instance K.ToObject Text
deriving instance ToJSON a => K.ToObject (LOContent a)
deriving instance K.ToObject Value
deriving instance ToJSON a => K.ToObject (Maybe (LOContent a))
instance (ToJSON a, ToJSON b, K.ToObject a, K.ToObject b) => K.ToObject (Maybe (Either a b)) where
  toObject :: Maybe (Either a b) -> Object
toObject Maybe (Either a b)
Nothing = Object
forall a. Monoid a => a
mempty
  toObject (Just (Left  a
x)) = a -> Object
forall a. ToObject a => a -> Object
KC.toObject a
x
  toObject (Just (Right b
x)) = b -> Object
forall a. ToObject a => a -> Object
KC.toObject b
x

instance (ToJSON a, ToJSON b, K.ToObject a, K.ToObject b) => KC.LogItem (Maybe (Either a b)) where
    payloadKeys :: Verbosity -> Maybe (Either a b) -> PayloadSelection
payloadKeys Verbosity
_ Maybe (Either a b)
_ = PayloadSelection
KC.AllKeys
instance ToJSON a => KC.LogItem (LogObject a) where
    payloadKeys :: Verbosity -> LogObject a -> PayloadSelection
payloadKeys Verbosity
_ LogObject a
_ = PayloadSelection
KC.AllKeys
instance KC.LogItem Text where
    payloadKeys :: Verbosity -> ScribeId -> PayloadSelection
payloadKeys Verbosity
_ ScribeId
_ = PayloadSelection
KC.AllKeys
instance ToJSON a => KC.LogItem (Maybe (LOContent a)) where
    payloadKeys :: Verbosity -> Maybe (LOContent a) -> PayloadSelection
payloadKeys Verbosity
_ Maybe (LOContent a)
_ = PayloadSelection
KC.AllKeys

\end{code}

\subsubsection{Entering structured log item into katip's queue}\label{code:passStrx}
\begin{code}
passStrx :: forall a. ToJSON a => ScribeId -> Log a -> LogObject a -> IO ()
passStrx :: ScribeId -> Log a -> LogObject a -> IO ()
passStrx ScribeId
backend Log a
katip (LogObject ScribeId
loname LOMeta
lometa LOContent a
loitem) = do
    LogEnv
env <- LogInternal -> LogEnv
kLogEnv (LogInternal -> LogEnv) -> IO LogInternal -> IO LogEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LogMVar -> IO LogInternal
forall a. MVar a -> IO a
readMVar (Log a -> LogMVar
forall a. Log a -> LogMVar
getK Log a
katip)
    [(ScribeId, ScribeHandle)]
-> ((ScribeId, ScribeHandle) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map ScribeId ScribeHandle -> [(ScribeId, ScribeHandle)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map ScribeId ScribeHandle -> [(ScribeId, ScribeHandle)])
-> Map ScribeId ScribeHandle -> [(ScribeId, ScribeHandle)]
forall a b. (a -> b) -> a -> b
$ LogEnv -> Map ScribeId ScribeHandle
K._logEnvScribes LogEnv
env) (((ScribeId, ScribeHandle) -> IO ()) -> IO ())
-> ((ScribeId, ScribeHandle) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
          \(ScribeId
scName, (KC.ScribeHandle Scribe
_ TBQueue WorkerMessage
shChan)) ->
              -- check start of name to match |ScribeKind|
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ScribeId
backend ScribeId -> ScribeId -> Bool
`isPrefixOf` ScribeId
scName) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    let sev :: Severity
sev = LOMeta -> Severity
severity LOMeta
lometa
                        payload :: Maybe (Either (LOContent a) Value)
                        payload :: Maybe (Either (LOContent a) Value)
payload = case LOContent a
loitem of
                                (LogMessage a
_) -> Either (LOContent a) Value -> Maybe (Either (LOContent a) Value)
forall a. a -> Maybe a
Just (Either (LOContent a) Value -> Maybe (Either (LOContent a) Value))
-> Either (LOContent a) Value -> Maybe (Either (LOContent a) Value)
forall a b. (a -> b) -> a -> b
$ LOContent a -> Either (LOContent a) Value
forall a b. a -> Either a b
Left LOContent a
loitem
                                (LogError ScribeId
_) -> Either (LOContent a) Value -> Maybe (Either (LOContent a) Value)
forall a. a -> Maybe a
Just (Either (LOContent a) Value -> Maybe (Either (LOContent a) Value))
-> Either (LOContent a) Value -> Maybe (Either (LOContent a) Value)
forall a b. (a -> b) -> a -> b
$ LOContent a -> Either (LOContent a) Value
forall a b. a -> Either a b
Left LOContent a
loitem
                                (LogStructured Object
s) -> Either (LOContent a) Value -> Maybe (Either (LOContent a) Value)
forall a. a -> Maybe a
Just (Either (LOContent a) Value -> Maybe (Either (LOContent a) Value))
-> Either (LOContent a) Value -> Maybe (Either (LOContent a) Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either (LOContent a) Value
forall a b. b -> Either a b
Right (Object -> Value
Object Object
s)
                                (LogStructuredText Object
s ScribeId
_t) -> Either (LOContent a) Value -> Maybe (Either (LOContent a) Value)
forall a. a -> Maybe a
Just (Either (LOContent a) Value -> Maybe (Either (LOContent a) Value))
-> Either (LOContent a) Value -> Maybe (Either (LOContent a) Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either (LOContent a) Value
forall a b. b -> Either a b
Right (Object -> Value
Object Object
s)
                                (LogValue ScribeId
_ Measurable
_) -> Either (LOContent a) Value -> Maybe (Either (LOContent a) Value)
forall a. a -> Maybe a
Just (Either (LOContent a) Value -> Maybe (Either (LOContent a) Value))
-> Either (LOContent a) Value -> Maybe (Either (LOContent a) Value)
forall a b. (a -> b) -> a -> b
$ LOContent a -> Either (LOContent a) Value
forall a b. a -> Either a b
Left LOContent a
loitem
                                (ObserveDiff CounterState
_) -> Either (LOContent a) Value -> Maybe (Either (LOContent a) Value)
forall a. a -> Maybe a
Just (Either (LOContent a) Value -> Maybe (Either (LOContent a) Value))
-> Either (LOContent a) Value -> Maybe (Either (LOContent a) Value)
forall a b. (a -> b) -> a -> b
$ LOContent a -> Either (LOContent a) Value
forall a b. a -> Either a b
Left LOContent a
loitem
                                (ObserveOpen CounterState
_) -> Either (LOContent a) Value -> Maybe (Either (LOContent a) Value)
forall a. a -> Maybe a
Just (Either (LOContent a) Value -> Maybe (Either (LOContent a) Value))
-> Either (LOContent a) Value -> Maybe (Either (LOContent a) Value)
forall a b. (a -> b) -> a -> b
$ LOContent a -> Either (LOContent a) Value
forall a b. a -> Either a b
Left LOContent a
loitem
                                (ObserveClose CounterState
_) -> Either (LOContent a) Value -> Maybe (Either (LOContent a) Value)
forall a. a -> Maybe a
Just (Either (LOContent a) Value -> Maybe (Either (LOContent a) Value))
-> Either (LOContent a) Value -> Maybe (Either (LOContent a) Value)
forall a b. (a -> b) -> a -> b
$ LOContent a -> Either (LOContent a) Value
forall a b. a -> Either a b
Left LOContent a
loitem
                                (AggregatedMessage [(ScribeId, Aggregated)]
_) ->Either (LOContent a) Value -> Maybe (Either (LOContent a) Value)
forall a. a -> Maybe a
Just (Either (LOContent a) Value -> Maybe (Either (LOContent a) Value))
-> Either (LOContent a) Value -> Maybe (Either (LOContent a) Value)
forall a b. (a -> b) -> a -> b
$ LOContent a -> Either (LOContent a) Value
forall a b. a -> Either a b
Left LOContent a
loitem
                                (MonitoringEffect MonitorAction
_) ->Either (LOContent a) Value -> Maybe (Either (LOContent a) Value)
forall a. a -> Maybe a
Just (Either (LOContent a) Value -> Maybe (Either (LOContent a) Value))
-> Either (LOContent a) Value -> Maybe (Either (LOContent a) Value)
forall a b. (a -> b) -> a -> b
$ LOContent a -> Either (LOContent a) Value
forall a b. a -> Either a b
Left LOContent a
loitem
                                LOContent a
KillPill -> Maybe (Either (LOContent a) Value)
forall a. Maybe a
Nothing
                                Command CommandValue
_ -> Maybe (Either (LOContent a) Value)
forall a. Maybe a
Nothing
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe (Either (LOContent a) Value) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Either (LOContent a) Value)
payload) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                        let threadIdText :: ThreadIdText
threadIdText = ScribeId -> ThreadIdText
KC.ThreadIdText (ScribeId -> ThreadIdText) -> ScribeId -> ThreadIdText
forall a b. (a -> b) -> a -> b
$ LOMeta -> ScribeId
tid LOMeta
lometa
                        let itemTime :: UTCTime
itemTime = LOMeta -> UTCTime
tstamp LOMeta
lometa
                        let localname :: [ScribeId]
localname = [ScribeId
loname]
                        let itemKatip :: Item (Maybe (Either (LOContent a) Value))
itemKatip = Item :: forall a.
Namespace
-> Environment
-> Severity
-> ThreadIdText
-> String
-> ProcessID
-> a
-> LogStr
-> UTCTime
-> Namespace
-> Maybe Loc
-> Item a
K.Item {
                                  _itemApp :: Namespace
_itemApp       = LogEnv -> Namespace
KC._logEnvApp LogEnv
env
                                , _itemEnv :: Environment
_itemEnv       = LogEnv -> Environment
KC._logEnvEnv LogEnv
env
                                , _itemSeverity :: Severity
_itemSeverity  = Severity -> Severity
sev2klog Severity
sev
                                , _itemThread :: ThreadIdText
_itemThread    = ThreadIdText
threadIdText
                                , _itemHost :: String
_itemHost      = ScribeId -> String
unpack (ScribeId -> String) -> ScribeId -> String
forall a b. (a -> b) -> a -> b
$ LOMeta -> ScribeId
hostname LOMeta
lometa
                                , _itemProcess :: ProcessID
_itemProcess   = LogEnv -> ProcessID
KC._logEnvPid LogEnv
env
                                , _itemPayload :: Maybe (Either (LOContent a) Value)
_itemPayload   = Maybe (Either (LOContent a) Value)
payload
                                , _itemMessage :: LogStr
_itemMessage   = LogStr
""
                                , _itemTime :: UTCTime
_itemTime      = UTCTime
itemTime
                                , _itemNamespace :: Namespace
_itemNamespace = LogEnv -> Namespace
KC._logEnvApp LogEnv
env Namespace -> Namespace -> Namespace
forall a. Semigroup a => a -> a -> a
<> [ScribeId] -> Namespace
K.Namespace [ScribeId]
localname
                                , _itemLoc :: Maybe Loc
_itemLoc       = Maybe Loc
forall a. Maybe a
Nothing
                                }
                        IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TBQueue WorkerMessage -> WorkerMessage -> STM Bool
forall a. TBQueue a -> a -> STM Bool
KC.tryWriteTBQueue TBQueue WorkerMessage
shChan (Item (Maybe (Either (LOContent a) Value)) -> WorkerMessage
forall a. LogItem a => Item a -> WorkerMessage
KC.NewItem Item (Maybe (Either (LOContent a) Value))
itemKatip)
\end{code}

\subsubsection{Entering textual log item into katip's queue}\label{code:passText}
\begin{code}
passText :: forall a. ToJSON a => ScribeId -> Log a -> LogObject a -> IO ()
passText :: ScribeId -> Log a -> LogObject a -> IO ()
passText ScribeId
backend Log a
katip (LogObject ScribeId
loname LOMeta
lometa LOContent a
loitem) = do
    LogEnv
env <- LogInternal -> LogEnv
kLogEnv (LogInternal -> LogEnv) -> IO LogInternal -> IO LogEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LogMVar -> IO LogInternal
forall a. MVar a -> IO a
readMVar (Log a -> LogMVar
forall a. Log a -> LogMVar
getK Log a
katip)
    [(ScribeId, ScribeHandle)]
-> ((ScribeId, ScribeHandle) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map ScribeId ScribeHandle -> [(ScribeId, ScribeHandle)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map ScribeId ScribeHandle -> [(ScribeId, ScribeHandle)])
-> Map ScribeId ScribeHandle -> [(ScribeId, ScribeHandle)]
forall a b. (a -> b) -> a -> b
$ LogEnv -> Map ScribeId ScribeHandle
K._logEnvScribes LogEnv
env) (((ScribeId, ScribeHandle) -> IO ()) -> IO ())
-> ((ScribeId, ScribeHandle) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
          \(ScribeId
scName, (KC.ScribeHandle Scribe
_ TBQueue WorkerMessage
shChan)) ->
              -- check start of name to match |ScribeKind|
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ScribeId
backend ScribeId -> ScribeId -> Bool
`isPrefixOf` ScribeId
scName) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    let sev :: Severity
sev = LOMeta -> Severity
severity LOMeta
lometa
                        msg :: Text
                        msg :: ScribeId
msg = case LOContent a
loitem of
                                (LogMessage a
logItem) -> case a -> Value
forall a. ToJSON a => a -> Value
toJSON a
logItem of
                                            (String ScribeId
m)  -> ScribeId
m
                                            Value
m           -> Text -> ScribeId
TL.toStrict (Text -> ScribeId) -> Text -> ScribeId
forall a b. (a -> b) -> a -> b
$ Value -> Text
forall a. ToJSON a => a -> Text
encodeToLazyText Value
m
                                (LogError ScribeId
m) -> ScribeId
m
                                (LogStructured Object
o) -> Text -> ScribeId
TL.toStrict (Object -> Text
forall a. ToJSON a => a -> Text
encodeToLazyText Object
o)
                                (LogStructuredText Object
_o ScribeId
m) -> ScribeId
m
                                (LogValue ScribeId
name Measurable
value) ->
                                    if ScribeId
name ScribeId -> ScribeId -> Bool
forall a. Eq a => a -> a -> Bool
== ScribeId
""
                                    then String -> ScribeId
pack (Measurable -> String
showSI Measurable
value)
                                    else ScribeId
name ScribeId -> ScribeId -> ScribeId
forall a. Semigroup a => a -> a -> a
<> ScribeId
" = " ScribeId -> ScribeId -> ScribeId
forall a. Semigroup a => a -> a -> a
<> String -> ScribeId
pack (Measurable -> String
showSI Measurable
value)
                                (ObserveDiff CounterState
_) -> Text -> ScribeId
TL.toStrict (LOContent a -> Text
forall a. ToJSON a => a -> Text
encodeToLazyText LOContent a
loitem)
                                (ObserveOpen CounterState
_) -> Text -> ScribeId
TL.toStrict (LOContent a -> Text
forall a. ToJSON a => a -> Text
encodeToLazyText LOContent a
loitem)
                                (ObserveClose CounterState
_) -> Text -> ScribeId
TL.toStrict (LOContent a -> Text
forall a. ToJSON a => a -> Text
encodeToLazyText LOContent a
loitem)
                                (AggregatedMessage [(ScribeId, Aggregated)]
aggregated) ->
                                    [ScribeId] -> ScribeId
T.concat ([ScribeId] -> ScribeId) -> [ScribeId] -> ScribeId
forall a b. (a -> b) -> a -> b
$ (((ScribeId, Aggregated) -> ScribeId)
 -> [(ScribeId, Aggregated)] -> [ScribeId])
-> [(ScribeId, Aggregated)]
-> ((ScribeId, Aggregated) -> ScribeId)
-> [ScribeId]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((ScribeId, Aggregated) -> ScribeId)
-> [(ScribeId, Aggregated)] -> [ScribeId]
forall a b. (a -> b) -> [a] -> [b]
map [(ScribeId, Aggregated)]
aggregated (((ScribeId, Aggregated) -> ScribeId) -> [ScribeId])
-> ((ScribeId, Aggregated) -> ScribeId) -> [ScribeId]
forall a b. (a -> b) -> a -> b
$ \(ScribeId
name, Aggregated
agg) ->
                                        ScribeId
"\n" ScribeId -> ScribeId -> ScribeId
forall a. Semigroup a => a -> a -> a
<> ScribeId
name ScribeId -> ScribeId -> ScribeId
forall a. Semigroup a => a -> a -> a
<> ScribeId
": " ScribeId -> ScribeId -> ScribeId
forall a. Semigroup a => a -> a -> a
<> String -> ScribeId
pack (Aggregated -> String
forall a. Show a => a -> String
show Aggregated
agg)
                                (MonitoringEffect MonitorAction
_) ->
                                    Text -> ScribeId
TL.toStrict (LOContent a -> Text
forall a. ToJSON a => a -> Text
encodeToLazyText LOContent a
loitem)
                                LOContent a
KillPill -> ScribeId
""
                                Command CommandValue
_ -> ScribeId
""
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ScribeId
msg ScribeId -> ScribeId -> Bool
forall a. Eq a => a -> a -> Bool
== ScribeId
"") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                        let threadIdText :: ThreadIdText
threadIdText = ScribeId -> ThreadIdText
KC.ThreadIdText (ScribeId -> ThreadIdText) -> ScribeId -> ThreadIdText
forall a b. (a -> b) -> a -> b
$ LOMeta -> ScribeId
tid LOMeta
lometa
                        let itemTime :: UTCTime
itemTime = LOMeta -> UTCTime
tstamp LOMeta
lometa
                        let localname :: [ScribeId]
localname = [ScribeId
loname]
                        let itemKatip :: Item ()
itemKatip = Item :: forall a.
Namespace
-> Environment
-> Severity
-> ThreadIdText
-> String
-> ProcessID
-> a
-> LogStr
-> UTCTime
-> Namespace
-> Maybe Loc
-> Item a
K.Item {
                                  _itemApp :: Namespace
_itemApp       = LogEnv -> Namespace
KC._logEnvApp LogEnv
env
                                , _itemEnv :: Environment
_itemEnv       = LogEnv -> Environment
KC._logEnvEnv LogEnv
env
                                , _itemSeverity :: Severity
_itemSeverity  = Severity -> Severity
sev2klog Severity
sev
                                , _itemThread :: ThreadIdText
_itemThread    = ThreadIdText
threadIdText
                                , _itemHost :: String
_itemHost      = ScribeId -> String
unpack (ScribeId -> String) -> ScribeId -> String
forall a b. (a -> b) -> a -> b
$ LOMeta -> ScribeId
hostname LOMeta
lometa
                                , _itemProcess :: ProcessID
_itemProcess   = LogEnv -> ProcessID
KC._logEnvPid LogEnv
env
                                , _itemPayload :: ()
_itemPayload   = ()
                                , _itemMessage :: LogStr
_itemMessage   = ScribeId -> LogStr
forall a. StringConv a ScribeId => a -> LogStr
K.logStr ScribeId
msg
                                , _itemTime :: UTCTime
_itemTime      = UTCTime
itemTime
                                , _itemNamespace :: Namespace
_itemNamespace = LogEnv -> Namespace
KC._logEnvApp LogEnv
env Namespace -> Namespace -> Namespace
forall a. Semigroup a => a -> a -> a
<> [ScribeId] -> Namespace
K.Namespace [ScribeId]
localname
                                , _itemLoc :: Maybe Loc
_itemLoc       = Maybe Loc
forall a. Maybe a
Nothing
                                }
                        IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TBQueue WorkerMessage -> WorkerMessage -> STM Bool
forall a. TBQueue a -> a -> STM Bool
KC.tryWriteTBQueue TBQueue WorkerMessage
shChan (Item () -> WorkerMessage
forall a. LogItem a => Item a -> WorkerMessage
KC.NewItem Item ()
itemKatip)
\end{code}

\subsubsection{Scribes}
The handles to \emph{stdout} and \emph{stderr} will be duplicated
because on exit \emph{katip} will close them otherwise.

\begin{code}
mkStdoutScribe :: ScribeFormat -> IO K.Scribe
mkStdoutScribe :: ScribeFormat -> IO Scribe
mkStdoutScribe ScribeFormat
ScText = do
    Handle
stdout' <- Handle -> IO Handle
hDuplicate Handle
stdout
    Handle -> Bool -> IO Scribe
mkTextFileScribeH Handle
stdout' Bool
True
mkStdoutScribe ScribeFormat
ScJson = do
    Handle
stdout' <- Handle -> IO Handle
hDuplicate Handle
stdout
    Handle -> Bool -> IO Scribe
mkJsonFileScribeH Handle
stdout' Bool
True

mkStderrScribe :: ScribeFormat -> IO K.Scribe
mkStderrScribe :: ScribeFormat -> IO Scribe
mkStderrScribe ScribeFormat
ScText = do
    Handle
stderr' <- Handle -> IO Handle
hDuplicate Handle
stderr
    Handle -> Bool -> IO Scribe
mkTextFileScribeH Handle
stderr' Bool
True
mkStderrScribe ScribeFormat
ScJson = do
    Handle
stderr' <- Handle -> IO Handle
hDuplicate Handle
stderr
    Handle -> Bool -> IO Scribe
mkJsonFileScribeH Handle
stderr' Bool
True

mkDevNullScribe :: IO K.Scribe
mkDevNullScribe :: IO Scribe
mkDevNullScribe = do
    let logger :: p -> f ()
logger p
_ = () -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Scribe -> IO Scribe
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Scribe -> IO Scribe) -> Scribe -> IO Scribe
forall a b. (a -> b) -> a -> b
$ (forall a. LogItem a => Item a -> IO ())
-> IO () -> PermitFunc -> Scribe
K.Scribe forall a. LogItem a => Item a -> IO ()
forall (f :: * -> *) p. Applicative f => p -> f ()
logger (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> (Item a -> Bool) -> Item a -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Item a -> Bool
forall a b. a -> b -> a
const Bool
True)

type Formatter a = K.LogItem a => Handle -> Rendering a -> IO Int

textFormatter, jsonFormatter :: Formatter a
textFormatter :: Handle -> Rendering a -> IO Int
textFormatter Handle
h Rendering a
r =
  let (Int
len, Text
msg) = Rendering a -> (Int, Text)
forall a. LogItem a => Rendering a -> (Int, Text)
renderTextMsg Rendering a
r
  in (Handle -> Text -> IO ()
TIO.hPutStrLn Handle
h (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$! Text
msg) IO () -> IO Int -> IO Int
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
len
jsonFormatter :: Handle -> Rendering a -> IO Int
jsonFormatter Handle
h Rendering a
r =
  let (Int
len, Text
msg) = Rendering a -> (Int, Text)
forall a. LogItem a => Rendering a -> (Int, Text)
renderJsonMsg Rendering a
r
  in (Handle -> Text -> IO ()
TIO.hPutStrLn Handle
h (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$! Text
msg) IO () -> IO Int -> IO Int
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
len

mkTextFileScribeH, mkJsonFileScribeH :: Handle -> Bool -> IO K.Scribe
mkTextFileScribeH :: Handle -> Bool -> IO Scribe
mkTextFileScribeH = (forall a. Formatter a) -> Handle -> Bool -> IO Scribe
mkFileScribeH forall a. Formatter a
textFormatter
mkJsonFileScribeH :: Handle -> Bool -> IO Scribe
mkJsonFileScribeH = (forall a. Formatter a) -> Handle -> Bool -> IO Scribe
mkFileScribeH forall a. Formatter a
jsonFormatter

mkTextFileScribe, mkJsonFileScribe :: Maybe RotationParameters -> FileDescription -> Bool -> IO K.Scribe
mkTextFileScribe :: Maybe RotationParameters -> FileDescription -> Bool -> IO Scribe
mkTextFileScribe = (forall a. Formatter a)
-> Maybe RotationParameters -> FileDescription -> Bool -> IO Scribe
mkFileScribe forall a. Formatter a
textFormatter
mkJsonFileScribe :: Maybe RotationParameters -> FileDescription -> Bool -> IO Scribe
mkJsonFileScribe = (forall a. Formatter a)
-> Maybe RotationParameters -> FileDescription -> Bool -> IO Scribe
mkFileScribe forall a. Formatter a
jsonFormatter

mkFileScribeH
    :: (forall a. Formatter a)
    -> Handle
    -> Bool
    -> IO K.Scribe
mkFileScribeH :: (forall a. Formatter a) -> Handle -> Bool -> IO Scribe
mkFileScribeH forall a. Formatter a
formatter Handle
h Bool
colorize = do
    Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
LineBuffering
    MVar ()
locklocal <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
    let logger :: forall a. K.LogItem a =>  K.Item a -> IO ()
        logger :: Item a -> IO ()
logger Item a
item = MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
locklocal ((() -> IO ()) -> IO ()) -> (() -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \()
_ ->
                        IO Int -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int -> IO ()) -> IO Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> Rendering a -> IO Int
forall a. Formatter a
formatter Handle
h (Bool -> Verbosity -> Item a -> Rendering a
forall a. Bool -> Verbosity -> Item a -> Rendering a
Rendering Bool
colorize Verbosity
K.V0 Item a
item)
    Scribe -> IO Scribe
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Scribe -> IO Scribe) -> Scribe -> IO Scribe
forall a b. (a -> b) -> a -> b
$ (forall a. LogItem a => Item a -> IO ())
-> IO () -> PermitFunc -> Scribe
K.Scribe forall a. LogItem a => Item a -> IO ()
logger (Handle -> IO ()
hClose Handle
h) (Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> (Item a -> Bool) -> Item a -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Item a -> Bool
forall a b. a -> b -> a
const Bool
True)

data Rendering a = Rendering { Rendering a -> Bool
colorize  :: Bool
                             , Rendering a -> Verbosity
verbosity :: K.Verbosity
                             , Rendering a -> Item a
logitem   :: K.Item a
                             }

renderTextMsg :: (K.LogItem a) => Rendering a -> (Int, TL.Text)
renderTextMsg :: Rendering a -> (Int, Text)
renderTextMsg Rendering a
r =
    let li :: Item a
li = Rendering a -> Item a
forall a. Rendering a -> Item a
logitem Rendering a
r
        m :: Text
m = Builder -> Text
toLazyText (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ Bool -> Verbosity -> Item a -> Builder
forall a. Bool -> Verbosity -> Item a -> Builder
formatItem (Rendering a -> Bool
forall a. Rendering a -> Bool
colorize Rendering a
r) (Rendering a -> Verbosity
forall a. Rendering a -> Verbosity
verbosity Rendering a
r) (Item a -> Builder) -> Item a -> Builder
forall a b. (a -> b) -> a -> b
$
            case Item a -> LogStr
forall a. Item a -> LogStr
KC._itemMessage Item a
li of
              K.LogStr Builder
""  -> Item a
li { _itemMessage :: LogStr
KC._itemMessage = ByteString -> LogStr
forall a. StringConv a ScribeId => a -> LogStr
K.logStr (ByteString -> LogStr) -> (a -> ByteString) -> a -> LogStr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Object -> ByteString) -> (a -> Object) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Object
forall a. ToObject a => a -> Object
K.toObject (a -> LogStr) -> a -> LogStr
forall a b. (a -> b) -> a -> b
$ Item a -> a
forall a. Item a -> a
KC._itemPayload Item a
li }
              LogStr
_ -> Item a
li
    in (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> Int64 -> Int
forall a b. (a -> b) -> a -> b
$ Text -> Int64
TL.length Text
m, Text
m)

renderJsonMsg :: (K.LogItem a) => Rendering a -> (Int, TL.Text)
renderJsonMsg :: Rendering a -> (Int, Text)
renderJsonMsg Rendering a
r =
    let li :: Item a
li = Rendering a -> Item a
forall a. Rendering a -> Item a
logitem Rendering a
r
        li' :: Item a
li' = Item a
li { _itemMessage :: LogStr
KC._itemMessage = LogStr
"" }
        m' :: Text
m' = Value -> Text
forall a. ToJSON a => a -> Text
encodeToLazyText (Value -> Text) -> Value -> Text
forall a b. (a -> b) -> a -> b
$ Value -> Value
trimTime (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ Verbosity -> Item a -> Value
forall a. LogItem a => Verbosity -> Item a -> Value
K.itemJson (Rendering a -> Verbosity
forall a. Rendering a -> Verbosity
verbosity Rendering a
r) Item a
li'
    in (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> Int64 -> Int
forall a b. (a -> b) -> a -> b
$ Text -> Int64
TL.length Text
m', Text
m')

-- keep only two digits for the fraction of seconds
trimTime :: Value -> Value
trimTime :: Value -> Value
trimTime (Object Object
o) = Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ (Value -> Value) -> ScribeId -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
(v -> v) -> k -> HashMap k v -> HashMap k v
HM.adjust
                                Value -> Value
keep2Decimals
                                ScribeId
"at"
                                Object
o
  where
    keep2Decimals :: Value -> Value
    keep2Decimals :: Value -> Value
keep2Decimals Value
v = case Value -> Result UTCTime
forall a. FromJSON a => Value -> Result a
fromJSON Value
v of
                        Success (UTCTime
utct :: UTCTime) ->
                            ScribeId -> Value
String (ScribeId -> Value) -> ScribeId -> Value
forall a b. (a -> b) -> a -> b
$ String -> ScribeId
pack (String -> ScribeId) -> String -> ScribeId
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
jformat UTCTime
utct
                        Result UTCTime
_ -> Value
v
    jformat :: String
    jformat :: String
jformat = String
"%FT%T%2QZ"
trimTime Value
v = Value
v

mkFileScribe
    :: (forall a . K.LogItem a => Handle -> Rendering a -> IO Int)
    -> Maybe RotationParameters
    -> FileDescription
    -> Bool
    -> IO K.Scribe
mkFileScribe :: (forall a. Formatter a)
-> Maybe RotationParameters -> FileDescription -> Bool -> IO Scribe
mkFileScribe forall a. Formatter a
formatter (Just RotationParameters
rotParams) FileDescription
fdesc Bool
colorize = do
    let prefixDir :: String
prefixDir = FileDescription -> String
prefixPath FileDescription
fdesc
    Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
prefixDir
        IO () -> (IOException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (IOException -> m a) -> m a
`catchIO` String -> IOException -> IO ()
forall e. Exception e => String -> e -> IO ()
prtoutException (String
"cannot log prefix directory: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
prefixDir)
    let fpath :: String
fpath = FileDescription -> String
filePath FileDescription
fdesc
    (Handle, Integer, UTCTime)
trp <- RotationParameters -> String -> IO (Handle, Integer, UTCTime)
initializeRotator RotationParameters
rotParams String
fpath
    MVar (Handle, Integer, UTCTime)
scribestate <- (Handle, Integer, UTCTime) -> IO (MVar (Handle, Integer, UTCTime))
forall a. a -> IO (MVar a)
newMVar (Handle, Integer, UTCTime)
trp  -- triple of (handle), (bytes remaining), (rotate time)
    -- sporadically remove old log files - every 10 seconds
    IO ()
cleanup <- UpdateSettings () -> IO (IO ())
forall a. UpdateSettings a -> IO (IO a)
mkAutoUpdate UpdateSettings ()
defaultUpdateSettings {
                                updateAction :: IO ()
updateAction = RotationParameters -> String -> IO ()
cleanupRotator RotationParameters
rotParams String
fpath
                              , updateFreq :: Int
updateFreq = Int
10000000
                              }
    let finalizer :: IO ()
        finalizer :: IO ()
finalizer = MVar (Handle, Integer, UTCTime)
-> ((Handle, Integer, UTCTime) -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar (Handle, Integer, UTCTime)
scribestate (((Handle, Integer, UTCTime) -> IO ()) -> IO ())
-> ((Handle, Integer, UTCTime) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
                                \(Handle
h, Integer
_, UTCTime
_) -> Handle -> IO ()
hClose Handle
h
    let logger :: forall a. K.LogItem a => K.Item a -> IO ()
        logger :: Item a -> IO ()
logger Item a
item =
            MVar (Handle, Integer, UTCTime)
-> ((Handle, Integer, UTCTime) -> IO (Handle, Integer, UTCTime))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Handle, Integer, UTCTime)
scribestate (((Handle, Integer, UTCTime) -> IO (Handle, Integer, UTCTime))
 -> IO ())
-> ((Handle, Integer, UTCTime) -> IO (Handle, Integer, UTCTime))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(Handle
h, Integer
bytes, UTCTime
rottime) -> do
                Int
byteswritten <- Handle -> Rendering a -> IO Int
forall a. Formatter a
formatter Handle
h (Bool -> Verbosity -> Item a -> Rendering a
forall a. Bool -> Verbosity -> Item a -> Rendering a
Rendering Bool
colorize Verbosity
K.V0 Item a
item)
                -- remove old files
                IO ()
cleanup
                -- detect log file rotation
                let bytes' :: Integer
bytes' = Integer
bytes Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
byteswritten
                let tdiff' :: Integer
tdiff' = NominalDiffTime -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime -> Integer) -> NominalDiffTime -> Integer
forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
rottime (Item a -> UTCTime
forall a. Item a -> UTCTime
K._itemTime Item a
item)
                if Integer
bytes' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 Bool -> Bool -> Bool
|| Integer
tdiff' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< (Integer
0 :: Integer)
                    then do   -- log file rotation
                        Handle -> IO ()
hClose Handle
h
                        (Handle
h2, Integer
bytes2, UTCTime
rottime2) <- RotationParameters -> String -> IO (Handle, Integer, UTCTime)
evalRotator RotationParameters
rotParams String
fpath
                        (Handle, Integer, UTCTime) -> IO (Handle, Integer, UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle
h2, Integer
bytes2, UTCTime
rottime2)
                    else
                        (Handle, Integer, UTCTime) -> IO (Handle, Integer, UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle
h, Integer
bytes', UTCTime
rottime)
    Scribe -> IO Scribe
forall (m :: * -> *) a. Monad m => a -> m a
return (Scribe -> IO Scribe) -> Scribe -> IO Scribe
forall a b. (a -> b) -> a -> b
$ (forall a. LogItem a => Item a -> IO ())
-> IO () -> PermitFunc -> Scribe
K.Scribe forall a. LogItem a => Item a -> IO ()
logger IO ()
finalizer (Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> (Item a -> Bool) -> Item a -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Item a -> Bool
forall a b. a -> b -> a
const Bool
True)
-- log rotation disabled.
mkFileScribe forall a. Formatter a
formatter Maybe RotationParameters
Nothing FileDescription
fdesc Bool
colorize = do
    let prefixDir :: String
prefixDir = FileDescription -> String
prefixPath FileDescription
fdesc
    Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
prefixDir
        IO () -> (IOException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (IOException -> m a) -> m a
`catchIO` String -> IOException -> IO ()
forall e. Exception e => String -> e -> IO ()
prtoutException (String
"cannot create prefix directory: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
prefixDir)
    let fpath :: String
fpath = FileDescription -> String
filePath FileDescription
fdesc
    Handle
h <- IO Handle -> (IOException -> IO Handle) -> IO Handle
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (IOException -> m a) -> m a
catchIO (String -> IOMode -> IO Handle
openFile String
fpath IOMode
WriteMode) ((IOException -> IO Handle) -> IO Handle)
-> (IOException -> IO Handle) -> IO Handle
forall a b. (a -> b) -> a -> b
$
                        \IOException
e -> do
                            String -> IOException -> IO ()
forall e. Exception e => String -> e -> IO ()
prtoutException (String
"error while opening log: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fpath) IOException
e
                            -- fallback to standard output in case of exception
                            Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdout
    Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
LineBuffering
    MVar Handle
scribestate <- Handle -> IO (MVar Handle)
forall a. a -> IO (MVar a)
newMVar Handle
h
    let finalizer :: IO ()
        finalizer :: IO ()
finalizer = MVar Handle -> (Handle -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Handle
scribestate Handle -> IO ()
hClose
    let logger :: forall a. K.LogItem a => K.Item a -> IO ()
        logger :: Item a -> IO ()
logger Item a
item =
            MVar Handle -> (Handle -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Handle
scribestate ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
handler ->
                IO Int -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int -> IO ()) -> IO Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> Rendering a -> IO Int
forall a. Formatter a
formatter Handle
handler (Bool -> Verbosity -> Item a -> Rendering a
forall a. Bool -> Verbosity -> Item a -> Rendering a
Rendering Bool
colorize Verbosity
K.V0 Item a
item)
    Scribe -> IO Scribe
forall (m :: * -> *) a. Monad m => a -> m a
return (Scribe -> IO Scribe) -> Scribe -> IO Scribe
forall a b. (a -> b) -> a -> b
$ (forall a. LogItem a => Item a -> IO ())
-> IO () -> PermitFunc -> Scribe
K.Scribe forall a. LogItem a => Item a -> IO ()
logger IO ()
finalizer (Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> (Item a -> Bool) -> Item a -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Item a -> Bool
forall a b. a -> b -> a
const Bool
True)

\end{code}

\begin{code}
formatItem :: Bool -> K.Verbosity -> K.Item a -> Builder
formatItem :: Bool -> Verbosity -> Item a -> Builder
formatItem Bool
withColor Verbosity
_verb K.Item{a
String
Maybe Loc
UTCTime
ProcessID
Namespace
Environment
Severity
LogStr
ThreadIdText
_itemLoc :: Maybe Loc
_itemNamespace :: Namespace
_itemTime :: UTCTime
_itemMessage :: LogStr
_itemPayload :: a
_itemProcess :: ProcessID
_itemHost :: String
_itemThread :: ThreadIdText
_itemSeverity :: Severity
_itemEnv :: Environment
_itemApp :: Namespace
_itemLoc :: forall a. Item a -> Maybe Loc
_itemNamespace :: forall a. Item a -> Namespace
_itemTime :: forall a. Item a -> UTCTime
_itemMessage :: forall a. Item a -> LogStr
_itemPayload :: forall a. Item a -> a
_itemProcess :: forall a. Item a -> ProcessID
_itemHost :: forall a. Item a -> String
_itemThread :: forall a. Item a -> ThreadIdText
_itemSeverity :: forall a. Item a -> Severity
_itemEnv :: forall a. Item a -> Environment
_itemApp :: forall a. Item a -> Namespace
..} =
    ScribeId -> Builder
fromText ScribeId
header Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    ScribeId -> Builder
fromText ScribeId
" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    Builder -> Builder
brackets (ScribeId -> Builder
fromText ScribeId
timestamp) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    ScribeId -> Builder
fromText ScribeId
" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    LogStr -> Builder
KC.unLogStr LogStr
_itemMessage
  where
    header :: ScribeId
header = Severity -> ScribeId -> ScribeId
colorBySeverity Severity
_itemSeverity (ScribeId -> ScribeId) -> ScribeId -> ScribeId
forall a b. (a -> b) -> a -> b
$
             ScribeId
"[" ScribeId -> ScribeId -> ScribeId
forall a. Semigroup a => a -> a -> a
<> ScribeId
hostname ScribeId -> ScribeId -> ScribeId
forall a. Semigroup a => a -> a -> a
<> [ScribeId] -> ScribeId
forall a. Monoid a => [a] -> a
mconcat [ScribeId]
namedcontext ScribeId -> ScribeId -> ScribeId
forall a. Semigroup a => a -> a -> a
<> ScribeId
":" ScribeId -> ScribeId -> ScribeId
forall a. Semigroup a => a -> a -> a
<> ScribeId
severity ScribeId -> ScribeId -> ScribeId
forall a. Semigroup a => a -> a -> a
<> ScribeId
":" ScribeId -> ScribeId -> ScribeId
forall a. Semigroup a => a -> a -> a
<> ScribeId
threadid ScribeId -> ScribeId -> ScribeId
forall a. Semigroup a => a -> a -> a
<> ScribeId
"]"
    hostname :: ScribeId
hostname | String
_itemHost String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" = ScribeId
""
             | Bool
otherwise = String -> ScribeId
pack String
_itemHost ScribeId -> ScribeId -> ScribeId
forall a. Semigroup a => a -> a -> a
<> ScribeId
":"
    namedcontext :: [ScribeId]
namedcontext = Namespace -> [ScribeId]
KC.intercalateNs Namespace
_itemNamespace
    severity :: ScribeId
severity = Severity -> ScribeId
KC.renderSeverity Severity
_itemSeverity
    threadid :: ScribeId
threadid = ThreadIdText -> ScribeId
KC.getThreadIdText ThreadIdText
_itemThread
    timestamp :: ScribeId
timestamp = String -> ScribeId
pack (String -> ScribeId) -> String -> ScribeId
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
tsformat UTCTime
_itemTime
    tsformat :: String
    tsformat :: String
tsformat = String
"%F %T%2Q %Z"
    colorBySeverity :: Severity -> ScribeId -> ScribeId
colorBySeverity Severity
s ScribeId
m = case Severity
s of
      Severity
K.EmergencyS -> ScribeId -> ScribeId
red ScribeId
m
      Severity
K.AlertS     -> ScribeId -> ScribeId
red ScribeId
m
      Severity
K.CriticalS  -> ScribeId -> ScribeId
red ScribeId
m
      Severity
K.ErrorS     -> ScribeId -> ScribeId
red ScribeId
m
      Severity
K.NoticeS    -> ScribeId -> ScribeId
magenta ScribeId
m
      Severity
K.WarningS   -> ScribeId -> ScribeId
yellow ScribeId
m
      Severity
K.InfoS      -> ScribeId -> ScribeId
blue ScribeId
m
      Severity
_          -> ScribeId
m
    red :: ScribeId -> ScribeId
red = ScribeId -> ScribeId -> ScribeId
forall p. (Semigroup p, IsString p) => p -> p -> p
colorize ScribeId
"31"
    yellow :: ScribeId -> ScribeId
yellow = ScribeId -> ScribeId -> ScribeId
forall p. (Semigroup p, IsString p) => p -> p -> p
colorize ScribeId
"33"
    magenta :: ScribeId -> ScribeId
magenta = ScribeId -> ScribeId -> ScribeId
forall p. (Semigroup p, IsString p) => p -> p -> p
colorize ScribeId
"35"
    blue :: ScribeId -> ScribeId
blue = ScribeId -> ScribeId -> ScribeId
forall p. (Semigroup p, IsString p) => p -> p -> p
colorize ScribeId
"34"
    colorize :: p -> p -> p
colorize p
c p
m
      | Bool
withColor = p
"\ESC["p -> p -> p
forall a. Semigroup a => a -> a -> a
<> p
c p -> p -> p
forall a. Semigroup a => a -> a -> a
<> p
"m" p -> p -> p
forall a. Semigroup a => a -> a -> a
<> p
m p -> p -> p
forall a. Semigroup a => a -> a -> a
<> p
"\ESC[0m"
      | Bool
otherwise = p
m

-- translate Severity to Log.Severity
sev2klog :: Severity -> K.Severity
sev2klog :: Severity -> Severity
sev2klog = \case
    Severity
Debug     -> Severity
K.DebugS
    Severity
Info      -> Severity
K.InfoS
    Severity
Notice    -> Severity
K.NoticeS
    Severity
Warning   -> Severity
K.WarningS
    Severity
Error     -> Severity
K.ErrorS
    Severity
Critical  -> Severity
K.CriticalS
    Severity
Alert     -> Severity
K.AlertS
    Severity
Emergency -> Severity
K.EmergencyS

\end{code}

\begin{code}
newtype FileDescription = FileDescription { FileDescription -> String
filePath :: FilePath }
  deriving (Int -> FileDescription -> String -> String
[FileDescription] -> String -> String
FileDescription -> String
(Int -> FileDescription -> String -> String)
-> (FileDescription -> String)
-> ([FileDescription] -> String -> String)
-> Show FileDescription
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [FileDescription] -> String -> String
$cshowList :: [FileDescription] -> String -> String
show :: FileDescription -> String
$cshow :: FileDescription -> String
showsPrec :: Int -> FileDescription -> String -> String
$cshowsPrec :: Int -> FileDescription -> String -> String
Show)

prefixPath :: FileDescription -> FilePath
prefixPath :: FileDescription -> String
prefixPath = String -> String
takeDirectory (String -> String)
-> (FileDescription -> String) -> FileDescription -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileDescription -> String
filePath

\end{code}