\subsection{Cardano.BM.Scribe.Systemd}
\label{code:Cardano.BM.Scribe.Systemd}
%if style == newcode
\begin{code}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
#if defined(linux_HOST_OS)
#define LINUX
#endif
module Cardano.BM.Scribe.Systemd
(
#if defined(LINUX)
plugin
#endif
) where
#ifdef LINUX
import Control.Monad (when)
import Data.Aeson (ToJSON, FromJSON, encode)
import qualified Data.ByteString.Lazy as BL (toStrict)
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Data.Text.Encoding as T (encodeUtf8)
import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Builder (toLazyText)
import Language.Haskell.TH.Syntax (Loc(Loc, loc_filename, loc_start))
import Systemd.Journal (JournalFields, codeFile, codeLine, message,
mkJournalField, priority, sendJournalFields,
syslogFacility, syslogIdentifier)
import qualified Systemd.Journal as J
import System.Posix.Syslog (Facility)
import qualified Katip as K
import qualified Katip.Core as KC
import Katip.Format.Time (formatAsIso8601)
import Cardano.BM.Configuration
import Cardano.BM.Backend.Log (sev2klog)
import Cardano.BM.Data.Backend
import Cardano.BM.Data.Severity
import Cardano.BM.Data.Trace
import Cardano.BM.Plugin (Plugin (..))
#endif
\end{code}
%endif
This plugin provides a scribe to \emph{katip} to output logged items
to systemd's journal on \emph{Linux}.
\subsubsection{Plugin definition}
\begin{code}
#ifdef LINUX
plugin :: (IsEffectuator s a, ToJSON a, FromJSON a)
=> Configuration -> Trace IO a -> s a -> T.Text -> IO (Plugin a)
plugin :: Configuration -> Trace IO a -> s a -> Text -> IO (Plugin a)
plugin Configuration
_ Trace IO a
_ s a
_ Text
syslogIdent =
Scribe -> Text -> Plugin a
forall a. Scribe -> Text -> Plugin a
ScribePlugin
(Scribe -> Text -> Plugin a) -> IO Scribe -> IO (Text -> Plugin a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> IO Scribe
mkJournalScribe Text
syslogIdent
IO (Text -> Plugin a) -> IO Text -> IO (Plugin a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"JournalSK::" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
syslogIdent)
#endif
\end{code}
\subsubsection{Scribe definition}
\begin{code}
#ifdef LINUX
mkJournalScribe :: T.Text -> IO K.Scribe
mkJournalScribe :: Text -> IO Scribe
mkJournalScribe Text
identifier = 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
$ Maybe Facility -> Severity -> Text -> Verbosity -> Scribe
journalScribe Maybe Facility
forall a. Maybe a
Nothing (Severity -> Severity
sev2klog Severity
Debug) Text
identifier Verbosity
K.V3
journalScribe :: Maybe Facility
-> K.Severity
-> T.Text
-> K.Verbosity
-> K.Scribe
journalScribe :: Maybe Facility -> Severity -> Text -> Verbosity -> Scribe
journalScribe Maybe Facility
facility Severity
severity Text
identifier Verbosity
verbosity =
(forall a. LogItem a => Item a -> IO ())
-> IO () -> PermitFunc -> Scribe
K.Scribe forall a. LogItem a => Item a -> IO ()
liPush IO ()
scribeFinalizer (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)
where
liPush :: K.LogItem a => K.Item a -> IO ()
liPush :: Item a -> IO ()
liPush Item a
i = do
Bool
permit <- Severity -> Item a -> IO Bool
forall (m :: * -> *) a. Monad m => Severity -> Item a -> m Bool
K.permitItem Severity
severity Item a
i
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
permit (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
JournalFields -> IO ()
sendJournalFields (JournalFields -> IO ()) -> JournalFields -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe Facility -> Text -> Verbosity -> Item a -> JournalFields
forall a.
LogItem a =>
Maybe Facility -> Text -> Verbosity -> Item a -> JournalFields
itemToJournalFields Maybe Facility
facility Text
identifier Verbosity
verbosity Item a
i
scribeFinalizer :: IO ()
scribeFinalizer :: IO ()
scribeFinalizer = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
#endif
\end{code}
\subsubsection{Conversion utilities}
Converts a |Katip Item| into a libsystemd-journal |JournalFields| map.
\begin{code}
#ifdef LINUX
itemToJournalFields :: K.LogItem a
=> Maybe Facility
-> T.Text
-> K.Verbosity
-> K.Item a
-> JournalFields
itemToJournalFields :: Maybe Facility -> Text -> Verbosity -> Item a -> JournalFields
itemToJournalFields Maybe Facility
facility Text
identifier Verbosity
verbosity Item a
item =
[JournalFields] -> JournalFields
forall a. Monoid a => [a] -> a
mconcat [ Item a -> JournalFields
forall a. LogItem a => Item a -> JournalFields
defaultFields Item a
item
, JournalFields
-> (Facility -> JournalFields) -> Maybe Facility -> JournalFields
forall b a. b -> (a -> b) -> Maybe a -> b
maybe JournalFields
forall k v. HashMap k v
HM.empty Facility -> JournalFields
facilityFields Maybe Facility
facility
, JournalFields
-> (Loc -> JournalFields) -> Maybe Loc -> JournalFields
forall b a. b -> (a -> b) -> Maybe a -> b
maybe JournalFields
forall k v. HashMap k v
HM.empty Loc -> JournalFields
locFields (Item a -> Maybe Loc
forall a. Item a -> Maybe Loc
K._itemLoc Item a
item)
]
where
defaultFields :: Item a -> JournalFields
defaultFields Item a
kItem =
[JournalFields] -> JournalFields
forall a. Monoid a => [a] -> a
mconcat [ Text -> JournalFields
message (Text -> Text
TL.toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Builder -> Text
toLazyText (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ LogStr -> Builder
KC.unLogStr (Item a -> LogStr
forall a. Item a -> LogStr
KC._itemMessage Item a
kItem))
, Priority -> JournalFields
priority (Severity -> Priority
mapSeverity (Item a -> Severity
forall a. Item a -> Severity
KC._itemSeverity Item a
kItem))
, Text -> JournalFields
syslogIdentifier Text
identifier
, [(JournalField, ByteString)] -> JournalFields
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [ (JournalField
environment, Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Environment -> Text
KC.getEnvironment (Item a -> Environment
forall a. Item a -> Environment
KC._itemEnv Item a
kItem))
, (JournalField
namespace, Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Namespace -> Text
unNS (Item a -> Namespace
forall a. Item a -> Namespace
KC._itemNamespace Item a
kItem))
, (JournalField
payload, ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Object -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Object -> ByteString) -> Object -> ByteString
forall a b. (a -> b) -> a -> b
$ Verbosity -> a -> Object
forall a. LogItem a => Verbosity -> a -> Object
KC.payloadObject Verbosity
verbosity (Item a -> a
forall a. Item a -> a
KC._itemPayload Item a
kItem))
, (JournalField
thread, Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ ThreadIdText -> Text
KC.getThreadIdText (Item a -> ThreadIdText
forall a. Item a -> ThreadIdText
KC._itemThread Item a
kItem))
, (JournalField
time, Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ UTCTime -> Text
formatAsIso8601 (Item a -> UTCTime
forall a. Item a -> UTCTime
KC._itemTime Item a
kItem))
]
]
facilityFields :: Facility -> JournalFields
facilityFields = Facility -> JournalFields
syslogFacility
locFields :: Loc -> JournalFields
locFields Loc{String
CharPos
loc_start :: CharPos
loc_filename :: String
loc_start :: Loc -> CharPos
loc_filename :: Loc -> String
..} = [JournalFields] -> JournalFields
forall a. Monoid a => [a] -> a
mconcat [ String -> JournalFields
codeFile String
loc_filename
, Int -> JournalFields
codeLine (CharPos -> Int
forall a b. (a, b) -> a
fst CharPos
loc_start)
]
unNS :: Namespace -> Text
unNS Namespace
ns = case Namespace -> [Text]
K.unNamespace Namespace
ns of
[] -> Text
T.empty
[Text
p] -> Text
p
[Text]
parts -> Text -> [Text] -> Text
T.intercalate Text
"." [Text]
parts
environment :: JournalField
environment = Text -> JournalField
mkJournalField Text
"environment"
namespace :: JournalField
namespace = Text -> JournalField
mkJournalField Text
"namespace"
payload :: JournalField
payload = Text -> JournalField
mkJournalField Text
"payload"
thread :: JournalField
thread = Text -> JournalField
mkJournalField Text
"thread"
time :: JournalField
time = Text -> JournalField
mkJournalField Text
"time"
mapSeverity :: Severity -> Priority
mapSeverity Severity
s = case Severity
s of
Severity
K.DebugS -> Priority
J.Debug
Severity
K.InfoS -> Priority
J.Info
Severity
K.NoticeS -> Priority
J.Notice
Severity
K.WarningS -> Priority
J.Warning
Severity
K.ErrorS -> Priority
J.Error
Severity
K.CriticalS -> Priority
J.Critical
Severity
K.AlertS -> Priority
J.Alert
Severity
K.EmergencyS -> Priority
J.Emergency
#endif
\end{code}