Push to journalctl

src/Katip/Scribes/Journal.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Katip.Scribes.Journal where
+
+import Data.Text.Lazy qualified as TL
+import Data.Text.Lazy.Builder qualified as Builder
+import Katip (Item (..), LogStr (..), PermitFunc, Scribe (..), Verbosity (..), permitItem, Severity (..), registerScribe, defaultScribeSettings, initLogEnv, closeScribes, runKatipContextT, logLocM, LogItem, Namespace (..), getThreadIdText, payloadObject, katipAddContext, sl, getEnvironment)
+import Systemd.Journal qualified as J
+import Control.Exception (bracket)
+import GHC.Stack (HasCallStack)
+import qualified Data.Text as T
+import qualified Data.HashMap.Strict as HashMap
+import qualified Data.Text.Encoding as TE
+import qualified Data.Aeson as A
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Aeson.KeyMap as KeyMap
+import qualified Data.Aeson.Key as Key
+import qualified Data.ByteString as B
+
+mkJournalScribe :: PermitFunc -> Verbosity -> IO Scribe
+mkJournalScribe permitFunc verbosity =
+  pure $
+    Scribe
+      { liPush = \i ->
+          J.sendMessageWith (TL.toStrict $ Builder.toLazyText $ unLogStr $ _itemMessage i) (itemToJournalFields verbosity i),
+        scribeFinalizer = pure (), -- no cleanup?
+        scribePermitItem = permitFunc
+      }
+
+itemToJournalFields :: forall a. LogItem a => Verbosity -> Item a -> J.JournalFields
+itemToJournalFields verbosity item = mconcat
+  [ J.syslogIdentifier (unNS item)
+  , J.priority (mapPriority item)
+  , thread item
+  , payload item
+  , environment item
+  ]
+  where
+    mapPriority i =
+      case _itemSeverity i of
+           DebugS -> J.Debug
+           InfoS -> J.Info
+           NoticeS -> J.Notice
+           WarningS -> J.Warning
+           ErrorS -> J.Error
+           CriticalS -> J.Critical
+           AlertS -> J.Alert
+           EmergencyS -> J.Emergency
+    unNS = T.intercalate "." . unNamespace . _itemNamespace
+    thread i = HashMap.singleton (katipField "thread") (TE.encodeUtf8 $ getThreadIdText $ _itemThread i)
+    environment i = HashMap.singleton (katipField "environment") (TE.encodeUtf8 $ getEnvironment $ _itemEnv i)
+    payload :: Item a -> J.JournalFields
+    payload i = -- HashMap.singleton (J.mkJournalField "payload") (BL.toStrict $ A.encode $ payloadObject verbosity $ _itemPayload i)
+      HashMap.fromList $ map (\(k,v) -> (katipField (Key.toText k), encodeValue v)) $ KeyMap.toList $ payloadObject verbosity $ _itemPayload i
+    -- The upstream doesn't handle '-'
+    katipField = J.mkJournalField . T.replace "-" "_" . ("KATIP_" <>)
+    encodeValue :: A.Value -> B.ByteString
+    encodeValue = \case
+      -- Handle simple scalar values as is
+      A.String t -> TE.encodeUtf8 t
+      x -> BL.toStrict $ A.encode x
+
+test :: HasCallStack => IO ()
+test = do
+  scribe <- mkJournalScribe (permitItem InfoS) V2
+  let makeLogEnv = registerScribe "journald" scribe defaultScribeSettings =<< initLogEnv "hass-controller" "dev"
+  bracket makeLogEnv closeScribes $ \le -> do
+    runKatipContextT le () "findme-context" $
+      katipAddContext (sl "trace-id" ("abcdefg" :: String)) $
+        logLocM InfoS "Hello world"
+  pure ()