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 }