Works

src/AFRP.hs

@@ -39,9 +39,9 @@ data Request = Request
 newtype Mealy eff a b = Mealy
   { runMealy :: forall m. MonadFix m => (forall x. eff x -> m x) -> Request -> a -> m (b, Mealy eff a b) }
 
-eff :: (a -> eff b) -> Mealy eff a b
-eff f = Mealy $ \nt _ x ->
-  nt (f x) >>= \b -> pure (b, eff f)
+eff :: (Request -> a -> eff b) -> Mealy eff a b
+eff f = Mealy $ \nt req x ->
+  nt (f req x) >>= \b -> pure (b, eff f)
 
 instance Category (Mealy eff) where
   id = Mealy (\_ _ x -> pure (x, id))

src/HomeAssistant/Controller.hs

@@ -52,18 +52,18 @@ data Service = Service
   deriving (Show, Eq)
 
 data HASSEff a where
-  CallService :: Service -> HASSEff ()
+  CallService :: Request -> Service -> HASSEff ()
   Debug :: Show a => a -> HASSEff ()
   Trace :: Show a => Request -> a -> HASSEff ()
 
 type HASS a b = Mealy HASSEff a b
 
 callService :: Service -> HASS a ()
-callService service = eff (\_ -> CallService service)
+callService service = eff (\req _ -> CallService req service)
 
 debug :: Show a => HASS a a
 debug = proc x -> do
-  eff Debug -< x
+  eff (const Debug) -< x
   returnA -< x
 
 traceEvent :: Show a => HASS (Event a) (Event a)

src/HomeAssistant/Controller/Bedroom.hs

@@ -114,10 +114,10 @@ drawer = entityBool "binary_sensor.bedroom_nightstand_drawer_sensor_masse_contac
 
 bedroomDrawerController :: HASS (Event Value) ()
 bedroomDrawerController = proc x -> do
-  st <- drawer -< x
+  st <- drawer >>> traceEvent -< x
   case st of
        Event Open -> callService (switch [entity] True) -< ()
        Event Closed -> callService (switch [entity] False) -< ()
        _ -> returnA -< ()
   where
-    entity = EntityId "bedroom_drawer_light_masse"
+    entity = EntityId "switch.bedroom_drawer_light_masse"

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)

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 $