\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

-- taken from https://github.com/haskell-service/katip-libsystemd-journal
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}