diff --git a/default.nix b/default.nix index 70a0ef8..25d36ee 100644 --- a/default.nix +++ b/default.nix @@ -2,9 +2,9 @@ , cereal, cereal-conduit, cereal-text, conduit, containers , data-default, directory, ekg-core, exceptions, filepath, hedgehog , hspec, hspec-hedgehog, http-media, http-types, katip, lens -, lens-aeson, lib, network, process, retry, servant, servant-server -, stm, temporary, text, time, unliftio, unordered-containers, uuid -, wai, warp, websockets +, lens-aeson, lib, libsystemd-journal, network, process, retry +, servant, servant-server, stm, temporary, text, time, unliftio +, unordered-containers, uuid, wai, warp, websockets }: mkDerivation { pname = "home-assistant-controller"; @@ -16,8 +16,9 @@ mkDerivation { aeson annotated-exception async base bytestring cereal cereal-conduit cereal-text conduit containers data-default directory ekg-core exceptions filepath http-media http-types katip - lens lens-aeson network process retry servant servant-server stm - text time unliftio unordered-containers uuid wai warp websockets + lens lens-aeson libsystemd-journal network process retry servant + servant-server stm text time unliftio unordered-containers uuid wai + warp websockets ]; executableHaskellDepends = [ base ]; testHaskellDepends = [ diff --git a/home-assistant-controller.cabal b/home-assistant-controller.cabal index 151e5bb..188475a 100644 --- a/home-assistant-controller.cabal +++ b/home-assistant-controller.cabal @@ -87,6 +87,7 @@ library , HomeAssistant.Runtime.Supervisor , HomeAssistant.Runtime.RateLimit , HttpServer + , Katip.Scribes.Journal -- Modules included in this library but not exported. -- other-modules: @@ -130,6 +131,7 @@ library , warp , wai , retry + , libsystemd-journal -- Directories containing source files. hs-source-dirs: src diff --git a/src/HomeAssistant/Runtime/Bus.hs b/src/HomeAssistant/Runtime/Bus.hs index 5b212d3..8838238 100644 --- a/src/HomeAssistant/Runtime/Bus.hs +++ b/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)) diff --git a/src/Katip/Scribes/Journal.hs b/src/Katip/Scribes/Journal.hs new file mode 100644 index 0000000..e8e7784 --- /dev/null +++ b/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 ()