\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
, 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
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
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))
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
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)) ->
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)) ->
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')
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
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)
IO ()
cleanup
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
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)
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
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
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}