Works

src/HomeAssistant/Runtime.hs

@@ -27,12 +27,15 @@ import HomeAssistant.Runtime.Supervisor (defaultBackoff, supervised)
 import Network.Socket (withSocketsDo)
 import System.Environment (getEnv)
 import HomeAssistant.Controller.Bedroom (bedroomPresenceController, bedroomButtonController, bedroomDrawerController)
-import Data.UUID (UUID)
+import Data.UUID (UUID, toText)
 import qualified Data.UUID.V4 as UUID.V4
+import Katip (runKatipT, logF, sl, Severity (..), ls, Namespace (Namespace), runKatipContextT)
+import Control.Monad.IO.Class (liftIO, MonadIO)
+import Control.Monad.Fix (MonadFix)
 
-step :: (forall x. eff x -> IO x) -> UUID -> Mealy eff a b -> a -> IO (b, Mealy eff a b)
+step :: (MonadFix m, MonadIO m) => (forall x. eff x -> m x) -> UUID -> Mealy eff a b -> a -> m (b, Mealy eff a b)
 step nt trace (Mealy f) a = do
-  now <- getCurrentTime
+  now <- liftIO getCurrentTime
   f nt (Request now trace) a
 
 data Controller = forall b. Controller T.Text (HASS (Event Value) b) Bool
@@ -40,7 +43,7 @@ data Controller = forall b. Controller T.Text (HASS (Event Value) b) Bool
 controllers :: [Controller]
 controllers =
   [ Controller "bedroom-presence" bedroomPresenceController False
-  , Controller "bedroom-button" bedroomButtonController False
+  , Controller "bedroom-button" bedroomButtonController False -- This works but leaving for vacation
   , Controller "bedroom-drawer" bedroomDrawerController True
   ]
 
@@ -48,20 +51,20 @@ controllers =
 -- bus. A restart re-dups the inbound channel and starts from the machine's
 -- initial state; messages broadcast during the restart window are lost.
 runController :: Bus -> Controller -> IO Void
-runController bus (Controller _name machine _enabled) = do
+runController bus (Controller name machine _enabled) = do
   inbound <- atomically (dupTChan (busInbound bus))
   go inbound machine
   where
     go inbound f = do
       msg <- atomically (readTChan inbound)
       uuid <- UUID.V4.nextRandom
-      (_, f') <- step (channelHassEval bus) uuid f (Event msg)
+      let ns = Namespace [name]
+      (_, f') <- step (runKatipContextT (busLogEnv bus) () ns . channelHassEval bus) uuid f (Event msg)
       go inbound f'
 
 defaultMain :: IO ()
-defaultMain = withSocketsDo $ do
+defaultMain = withSocketsDo $ withBus $ \bus -> do
   token <- getEnv "HA_TOKEN"
-  bus <- newBus 0
   let workers =
         [ ("reader", readerAction "last-resort-redux" 8123 token bus)
         , ("writer", writerAction bus)
@@ -70,10 +73,12 @@ defaultMain = withSocketsDo $ do
   (_, v) <- waitAny as
   absurd v
 
-dryRunHassEval :: CallIdGen -> HASSEff a -> IO a
-dryRunHassEval gen = \case
-  CallService x -> do
-    callId <- generateCallId gen
-    print (callId, x)
-  Debug x -> print x
-  Trace req x -> print (req, x)
+dryRunHassEval :: Namespace -> Bus -> HASSEff a -> IO a
+dryRunHassEval ns bus = \case
+  CallService req x -> runKatipT (busLogEnv bus) $ do
+    callId <- liftIO $ generateCallId (busGen bus)
+    logF (sl "traceId" (toText (requestTraceId req))) ns DebugS (ls $ show (callId, x))
+  Debug x -> runKatipT (busLogEnv bus) $ do
+    logF () ns DebugS (ls $ show x)
+  Trace req x -> runKatipT (busLogEnv bus) $ do
+    logF (sl "traceId" (toText (requestTraceId req))) ns InfoS (ls $ show x)