Push to journalctl

src/HomeAssistant/Runtime/Bus.hs

@@ -34,6 +34,9 @@ import Data.UUID (toText)
 import AFRP (Request(..), Event(..))
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import HomeAssistant.Runtime.Flags (Flags)
+import Katip.Scribes.Journal (mkJournalScribe)
+import System.Environment (lookupEnv)
+import Data.Maybe (isJust)
 
 -- | Shared runtime state: inbound is a broadcast channel (controllers
 -- read from 'dupTChan' copies), outbound queues service calls for the
@@ -50,8 +53,7 @@ data Bus = Bus
 
 withBus :: Severity -> AppMetrics -> Flags -> (Bus -> IO a) -> IO a
 withBus severity metrics flags callback = do
-  handleScribe <- mkHandleScribe ColorIfTerminal stdout (permitItem severity) V2
-  let makeLogEnv = registerScribe "stdout" handleScribe defaultScribeSettings =<< initLogEnv "hass-controller" "production"
+  let makeLogEnv = registerJournalScribe =<< registerHandleScribe =<< initLogEnv "hass-controller" "production"
   -- closeScribes will stop accepting new logs, flush existing ones and clean up resources
   bracket makeLogEnv closeScribes $ \le -> do
     bus <- Bus
@@ -63,6 +65,18 @@ withBus severity metrics flags callback = do
           <*> pure metrics
           <*> pure flags
     callback bus
+  where
+    registerJournalScribe :: LogEnv -> IO LogEnv
+    registerJournalScribe le = do
+      journalScribe <- mkJournalScribe (permitItem severity) V2
+      registerScribe "journalctl" journalScribe defaultScribeSettings le
+    registerHandleScribe le = do
+      systemdUnit <- isJust <$> lookupEnv "INVOCATION_ID"
+      if systemdUnit
+         then pure le -- ignore stdout when running in systemd
+         else do
+           handleScribe <- mkHandleScribe ColorIfTerminal stdout (permitItem severity) V2
+           registerScribe "stdout" handleScribe defaultScribeSettings le
 
 recordInbound :: Bus -> IO ()
 recordInbound bus = inc (amTriggersIn (busMetrics bus))

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 ()