Works

src/HomeAssistant/Runtime/Bus.hs

@@ -1,10 +1,11 @@
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module HomeAssistant.Runtime.Bus
   ( Bus(..)
   , CallIdGen(..)
   , mkCallIdGen
-  , newBus
+  , withBus
   , channelHassEval
   ) where
 
@@ -21,29 +22,46 @@ import Data.Aeson (Value)
 import Data.IORef (atomicModifyIORef', newIORef)
 import HomeAssistant.Controller (HASSEff (..), Service)
 import Network.WebSockets (Connection)
+import Katip (LogEnv, closeScribes, mkHandleScribe, ColorStrategy (..), permitItem, Severity (..), Verbosity (V2), registerScribe, defaultScribeSettings, initLogEnv, ls, sl, logFM, katipAddContext, KatipContext)
+import Control.Exception (bracket)
+import System.IO (stdout)
+import Data.UUID (toText)
+import AFRP (Request(..))
+import Control.Monad.IO.Class (MonadIO, liftIO)
 
 -- | Shared runtime state: inbound is a broadcast channel (controllers
 -- read from 'dupTChan' copies), outbound queues service calls for the
 -- writer, conn holds the current websocket (Nothing before first connect).
 data Bus = Bus
   { busInbound  :: TChan Value
-  , busOutbound :: TChan Service
+  , busOutbound :: TChan (Request, Service)
   , busConn     :: TVar (Maybe Connection)
   , busGen      :: CallIdGen
+  , busLogEnv   :: LogEnv
   }
 
-newBus :: Int -> IO Bus
-newBus start = Bus
-  <$> newBroadcastTChanIO
-  <*> newTChanIO
-  <*> newTVarIO Nothing
-  <*> mkCallIdGen start
+withBus :: (Bus -> IO a) -> IO a
+withBus callback = do
+  handleScribe <- mkHandleScribe ColorIfTerminal stdout (permitItem DebugS) V2
+  let makeLogEnv = registerScribe "stdout" handleScribe defaultScribeSettings =<< initLogEnv "hass-controller" "production"
+  -- closeScribes will stop accepting new logs, flush existing ones and clean up resources
+  bracket makeLogEnv closeScribes $ \le -> do
+    bus <- Bus
+          <$> newBroadcastTChanIO
+          <*> newTChanIO
+          <*> newTVarIO Nothing
+          <*> mkCallIdGen 0
+          <*> pure le
+    callback bus
 
-channelHassEval :: Bus -> HASSEff a -> IO a
+channelHassEval :: (MonadIO m, KatipContext m) => Bus -> HASSEff a -> m a
 channelHassEval bus = \case
-  CallService svc -> atomically $ writeTChan (busOutbound bus) svc
-  Debug x -> print x
-  Trace req x -> print (req, x)
+  CallService req svc -> katipAddContext (sl "traceId" (toText (requestTraceId req))) $ do
+    logFM DebugS (ls $ show svc)
+    liftIO $ atomically $ writeTChan (busOutbound bus) (req, svc)
+  Debug x -> logFM DebugS (ls $ show x)
+  Trace req x -> katipAddContext (sl "traceId" (toText (requestTraceId req))) $
+    logFM InfoS (ls $ show x)
 
 newtype CallIdGen = CallIdGen { generateCallId :: IO Int }
 

src/HomeAssistant/Runtime/Connection.hs

@@ -28,6 +28,9 @@ import HomeAssistant.Controller (Service (..), Target (..))
 import HomeAssistant.Runtime.Bus
 import HomeAssistant.Runtime.Supervisor (Fatal (..))
 import qualified Network.WebSockets as WS
+import Katip (runKatipContextT, sl, logFM, Severity (..), ls)
+import Data.UUID (toText)
+import AFRP (Request(..))
 
 -- | Connect, authenticate, subscribe, then receive and broadcast forever.
 -- Restarting this action reconnects. All setup sends happen before the
@@ -86,10 +89,13 @@ receiveJSON conn = do
 
 writerAction :: Bus -> IO Void
 writerAction bus = forever $ do
-  svc <- atomically $ readTChan (busOutbound bus)
+  (request, svc) <- atomically $ readTChan (busOutbound bus)
   conn <- atomically $ readTVar (busConn bus) >>= maybe retry pure
   callId <- generateCallId (busGen bus)
-  WS.sendTextData conn $ encode $ encodeService callId svc
+  let textData = encode $ encodeService callId svc
+  runKatipContextT (busLogEnv bus) (sl "traceId" (toText (requestTraceId request))) "connection" $
+    logFM DebugS (ls textData)
+  WS.sendTextData conn textData
 
 encodeService :: Int -> Service -> Value
 encodeService callId Service{..} = object $