Logging and really not working light restoration

AGENTS.md

@@ -10,6 +10,7 @@ reactive programming (AFRP). Haskell, built with cabal.
 - Vertical modules: split by feature/concept, not by layer.
 - Comments are minimal. They describe the contract, not the implementation,
   and should stay stable as the implementation changes.
+- Never ever log directly to stdout via `putStr` and friends. Always use proper logging functions
 
 ## Build
 

app/Main.hs

@@ -4,5 +4,4 @@ import qualified HomeAssistant.Runtime (defaultMain)
 
 main :: IO ()
 main = do
-  putStrLn "Hello, Haskell!"
   HomeAssistant.Runtime.defaultMain

src/AFRP.hs

@@ -56,7 +56,7 @@ import qualified Data.Set as S
 import qualified Data.Text as T
 import Data.Serialize (Get, Putter, Serialize (put), runGet, get)
 import qualified Data.ByteString as B
-import Control.Exception (IOException, handle, throwIO)
+import Control.Exception (IOException)
 import System.IO.Error (isDoesNotExistError)
 import GHC.Generics (Generic)
 import Data.Sequence (Seq, (|>))
@@ -65,6 +65,8 @@ import Control.Monad.IO.Class (MonadIO, liftIO)
 import Conduit (ConduitT, (.|))
 import qualified Data.Conduit.Cereal as CC
 import qualified Conduit as C
+import Control.Monad.Catch (MonadCatch, handle)
+import Control.Exception.Annotated (throw)
 
 
 data Codec s = Codec { getter :: !(Get s), putter :: !(Putter s) }
@@ -247,13 +249,13 @@ save path s
     isDirty _ = False
 
 
-load :: forall m a b. FilePath -> Auto m a b -> IO (DecodedAuto m a b)
+load :: forall eff a b m. (MonadCatch m, MonadIO m) => FilePath -> Auto eff a b -> m (DecodedAuto eff a b)
-load path a = handle defaultOnMissingFile (flip deserialize a <$> B.readFile path)
+load path a = handle defaultOnMissingFile (flip deserialize a <$> liftIO (B.readFile path))
   where
-    defaultOnMissingFile :: IOException -> IO (DecodedAuto m a b)
+    defaultOnMissingFile :: IOException -> m (DecodedAuto eff a b)
     defaultOnMissingFile e
       | isDoesNotExistError e = pure $ FailDecode "State doesn't exist yet" a
-      | otherwise = throwIO e
+      | otherwise = throw e
 
 -- | The set of entity ids an arrow subscribes to. Static: it does not
 -- change as the machine steps, so the runtime can read it once to build

src/HomeAssistant/Controller/Bedroom.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE Arrows #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DerivingVia #-}
 module HomeAssistant.Controller.Bedroom where
 
 import HomeAssistant.Controller
@@ -14,6 +15,7 @@ import Data.Map (Map)
 import qualified Data.Map.Strict as M
 import Data.Serialize.Text ()
 import Data.Default (def)
+import Data.Serialize (Serialize)
 
 
 
@@ -48,32 +50,38 @@ presenceLightEvents =
     offEvent = arr not >>> AFRP.waitFor 300 >>> arr (AFRP.tag LightingOff)
 
 
-bedroomLightSnapshots :: HASS (Event Value) (Map T.Text LightSnapshot)
+bedroomLightStatus :: HASS (Event Value) (Map T.Text LightObservation)
-bedroomLightSnapshots = M.fromList <$> traverse (\e -> (e,) <$> observedLight e) [e | EntityId e <- bedroomLightTargets]
+bedroomLightStatus = M.fromList <$> traverse (\e -> (e,) <$> observedLight e) [e | EntityId e <- bedroomLightTargets]
+
+newtype Snapshot = Snapshot { getSnapshot :: Map T.Text LightObservation }
+  deriving (Show, Eq)
+  deriving Serialize via (Map T.Text LightObservation)
 
 bedroomPresenceController :: HASS (Event Value) ()
 bedroomPresenceController = proc x -> do
   p <- presenceLightEvents >>> traceEvent -< x
-  snap <- (doSnapshot &&& bedroomLightSnapshots) >>> AFRP.snapshot M.empty >>> traceValue -< x
+  -- This line is just for debugging purposes
+  _ <- bedroomLightStatus >>> AFRP.changes >>> traceEvent -< x
+  snap <- (doSnapshot &&& bedroomLightStatus) >>> AFRP.snapshot M.empty >>> arr Snapshot -< x
+  -- This line is just for debugging
+  _ <- AFRP.changes >>> traceEvent -< snap
   case p of
        Event LightingOff -> do
          callService (light bedroomLightTargets Off) -< ()
        Event LightingOn -> do
-         -- callService (activateSceneWith "scene.makuuhuone_lights_snapshot" transition) -< ()
+         callServicesDyn (concatMap (uncurry toLight)) -< M.toList (getSnapshot snap)
-         callServicesDyn (concatMap (uncurry toLight)) -< M.toList snap
          returnA -< ()
        Event LightingSleep -> do
-         callService createBedroomScene -< ()
          callService (activateSceneWith "scene.makuuhuone_lepotila" transition) -< ()
        _ -> returnA -< ()
   where
     -- This is the meat of this change. To support transitioning the brightness, exactly,
     -- we need to do the brightness call separately and last
-    toLight :: T.Text -> LightSnapshot -> [Service]
+    toLight :: T.Text -> LightObservation -> [Service]
-    toLight entityId LightSnapshot{observedOn=False} = [light [EntityId entityId] Off]
+    toLight entityId LightObservation{observedOn=False} = [light [EntityId entityId] Off]
-    toLight entityId LightSnapshot{observedOn=True, observedTemperature=t, observedBrightness=b} =
+    toLight entityId LightObservation{observedOn=True, observedTemperature=t, observedBrightness=b} =
-      [ light [EntityId entityId] (On def{lightColorTemperature=Just t})
+      [ light [EntityId entityId] (On def{lightTransition = Just 2, lightBrightness = Just (BrightnessAbsolute b), lightColorTemperature=Just t})
-      , light [EntityId entityId] (On def{lightTransition=Just 5, lightBrightness=Just (BrightnessAbsolute b)})
+      -- , light [EntityId entityId] (On def{lightTransition = Just 2, lightBrightness=Just (BrightnessAbsolute b)})
       ]
     doSnapshot = presenceLightEvents
       >>> arr (\ev -> if ev == Event LightingSleep then Event () else Tick)

src/HomeAssistant/Controller/Light/Observation.hs

@@ -2,7 +2,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module HomeAssistant.Controller.Light.Observation
-  ( LightSnapshot(..)
+  ( LightObservation(..)
   , observedLight
   , lightBrightnessEvent
   , lightTemperatureEvent
@@ -37,17 +37,17 @@ lightTemperatureEvent entityId =
   where
     eventTemperature v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "attributes" . key "color_temp_kelvin" . _Integral
 
-data LightSnapshot = LightSnapshot
+data LightObservation = LightObservation
   { observedOn :: Bool
   , observedBrightness :: Int
   , observedTemperature :: Int
   }
   deriving (Show, Generic, Eq)
-instance Serialize LightSnapshot
+instance Serialize LightObservation
 
-observedLight :: T.Text -> HASS (Event Value) LightSnapshot
+observedLight :: T.Text -> HASS (Event Value) LightObservation
 observedLight entityId = proc ev -> do
   e <- hold False . entityBool entityId -< ev
   b <- hold 0 . lightBrightnessEvent entityId -< ev
   t <- hold 0 . lightTemperatureEvent entityId -< ev
-  returnA -< LightSnapshot e b t
+  returnA -< LightObservation e b t

src/HomeAssistant/Runtime.hs

@@ -4,46 +4,50 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module HomeAssistant.Runtime
-  ( defaultMain
+  ( defaultMain,
-  , step
+    step,
-  , CallIdGen
+    CallIdGen,
-  , mkCallIdGen
+    mkCallIdGen,
-  , dryRunHassEval
+    dryRunHassEval,
-  , Controller(..)
+    Controller (..),
-  , runController
+    runController,
-  ) where
+  )
+where
 
-import AFRP (Event (..), Mealy (..), Request (..), Auto, stepAutoSerializing, load, DecodedAuto (..))
+import AFRP (Auto, DecodedAuto (..), Event (..), Mealy (..), Request (..), load, stepAutoSerializing)
 import Control.Concurrent.STM (atomically, dupTChan, readTChan)
+import Control.Monad.IO.Class (MonadIO, liftIO)
 import Data.Aeson (Value)
-import qualified Data.Text as T
+import Data.Foldable (forM_)
+import Data.Maybe (fromMaybe)
+import Data.Text qualified as T
 import Data.Time (getCurrentTime, getCurrentTimeZone)
+import Data.UUID (UUID, toText)
+import Data.UUID.V4 qualified as UUID.V4
 import Data.Void (Void)
+import GHC.Stack (HasCallStack)
 import HomeAssistant.Controller (HASS, HASSEff (..))
+import HomeAssistant.Controller.Bedroom (bedroomButtonController, bedroomDrawerController, bedroomPresenceController, humidifierController)
+import HomeAssistant.Controller.Children (childrenBedroomButtonController, schoolLightController)
+import HomeAssistant.Controller.Hallway (hallwayLightsController)
+import HomeAssistant.Controller.Kitchen (kitchenMotionController)
+import HomeAssistant.Controller.Livingroom (livingroomPlantLights, livingroomPresenceController)
 import HomeAssistant.Runtime.Bus
+import HomeAssistant.Runtime.Connection (readerAction, writerAction)
 import HomeAssistant.Runtime.Flags (loadFlags)
-import HomeAssistant.Runtime.Connection (writerAction, readerAction)
+import HomeAssistant.Runtime.Metrics qualified
+import HomeAssistant.Runtime.RateLimit (registerRateLimitMetrics, slidingWindowLimiter)
+import HomeAssistant.Runtime.Supervisor (supervised)
+import HttpServer qualified
+import Katip (KatipContext, Namespace (Namespace), Severity (..), logF, logLocM, ls, runKatipContextT, runKatipT, sl, katipAddNamespace)
 import Network.Socket (withSocketsDo)
 import System.Environment (getEnv, lookupEnv)
-import HomeAssistant.Controller.Bedroom (bedroomPresenceController, bedroomButtonController, bedroomDrawerController, humidifierController)
-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 HomeAssistant.Controller.Children (schoolLightController, childrenBedroomButtonController)
-import Data.Maybe (fromMaybe)
-import qualified System.Metrics
-import qualified HomeAssistant.Runtime.Metrics
 import System.FilePath ((</>))
+import System.Metrics qualified
 import Text.Read (readMaybe)
-import HomeAssistant.Controller.Kitchen (kitchenMotionController)
-import HomeAssistant.Controller.Livingroom (livingroomPresenceController, livingroomPlantLights)
-import HomeAssistant.Runtime.RateLimit (slidingWindowLimiter, registerRateLimitMetrics)
 import UnliftIO.Async
-import HomeAssistant.Runtime.Supervisor (supervised)
+import Control.Monad.Catch (MonadCatch)
-import HomeAssistant.Controller.Hallway (hallwayLightsController)
+import Control.Exception.Annotated (checkpoint, Annotation (..))
-import qualified HttpServer
-import Data.Foldable (forM_)
 
 step :: (MonadIO m) => FilePath -> T.Text -> UUID -> Auto m a b -> a -> m (b, Auto m a b)
 step path name trace st a = do
@@ -56,73 +60,79 @@ data Controller = forall b. Controller T.Text (HASS (Event Value) b)
 
 controllers :: [Controller]
 controllers =
-  [ Controller "bedroom-presence" bedroomPresenceController
+  [ Controller "bedroom-presence" bedroomPresenceController,
-  , Controller "bedroom-button" bedroomButtonController
+    Controller "bedroom-button" bedroomButtonController,
-  , Controller "bedroom-drawer" bedroomDrawerController
+    Controller "bedroom-drawer" bedroomDrawerController,
-  , Controller "bedroom-humidifier" humidifierController
+    Controller "bedroom-humidifier" humidifierController,
-  , Controller "school-light-controller" schoolLightController
+    Controller "school-light-controller" schoolLightController,
-  , Controller "kitchen-motion-controller" kitchenMotionController
+    Controller "kitchen-motion-controller" kitchenMotionController,
-  , Controller "livingroom-presence" livingroomPresenceController
+    Controller "livingroom-presence" livingroomPresenceController,
-  , Controller "hallway-motion-controller" hallwayLightsController
+    Controller "hallway-motion-controller" hallwayLightsController,
-  , Controller "children-button" childrenBedroomButtonController
+    Controller "children-button" childrenBedroomButtonController,
-  , Controller "livingroom-plants" livingroomPlantLights
+    Controller "livingroom-plants" livingroomPlantLights
   ]
 
 -- | Steps the machine for every inbound message; service calls go to the
 -- 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 :: MonadIO m => FilePath -> Bus -> Controller -> m Void
+runController :: forall m. (HasCallStack, MonadCatch m, KatipContext m, MonadIO m) => FilePath -> Bus -> Controller -> m Void
-runController rootDir bus (Controller name machine ) = liftIO $ do
+runController rootDir bus (Controller name machine) = checkpoint (Annotation name) $ katipAddNamespace ns $ do
-  inbound <- atomically (dupTChan (busInbound bus))
+  inbound <- liftIO $ atomically (dupTChan (busInbound bus))
-  let ns = Namespace [name]
+  let workerDefinition = runMealy machine (channelHassEval @m bus)
-  let workerDefinition = runMealy machine (runKatipContextT (busLogEnv bus) () ns . channelHassEval bus)
+  let path = rootDir </> T.unpack name
-  let path  = rootDir </> T.unpack name
+  worker <-
-  worker <- load path workerDefinition >>= \case
+    load path workerDefinition >>= \case
-    Decoded a -> pure a
+      Decoded a -> pure a
-    FailDecode err a -> a <$ putStrLn ("Failed to load (" <> T.unpack name <> "): " <> err)
+      FailDecode err a -> a <$ logLocM WarningS (ls ("Failed to load (" <> T.unpack name <> "): " <> err))
   go path inbound worker
   where
+    ns = Namespace [name]
     go path inbound f = do
-      msg <- atomically (readTChan inbound)
+      msg <- liftIO $ atomically (readTChan inbound)
-      uuid <- UUID.V4.nextRandom
+      uuid <-  liftIO UUID.V4.nextRandom
       (_, next) <- step path name uuid f msg
       go path inbound next
 
-lookupPort :: IO Int
+lookupPort :: (MonadFail m, MonadIO m) => m Int
 lookupPort = do
-  m <- lookupEnv "HA_METRICS_PORT"
+  m <- liftIO (lookupEnv "HA_METRICS_PORT")
   case m of
     Nothing -> pure 8124
-    Just s  -> case readMaybe s of
+    Just s -> case readMaybe s of
       Just p | p >= 1 && p <= 65535 -> pure p
       _ -> fail ("HA_METRICS_PORT must be a port in 1..65535: " <> s)
 
 defaultMain :: IO ()
-defaultMain = withSocketsDo $ do
+defaultMain =
-  severity <- maybe InfoS (const DebugS) <$> lookupEnv "HA_DEBUG"
+  withSocketsDo $
-  store <- System.Metrics.newStore
+    getSeverity >>= \s -> withLogEnv s $ \le -> runKatipContextT le () mempty $ do
-  System.Metrics.registerGcMetrics store
+      logLocM InfoS "Hello world"
-  appMetrics <- HomeAssistant.Runtime.Metrics.registerAppMetrics store
+      store <- liftIO System.Metrics.newStore
-  rateLimitMetrics <- registerRateLimitMetrics store
+      liftIO $ System.Metrics.registerGcMetrics store
-  rootPath <- fromMaybe "/tmp/" <$> lookupEnv "HA_LIB_DIR"
+      appMetrics <- liftIO $ HomeAssistant.Runtime.Metrics.registerAppMetrics store
-  let allNames = map (\(Controller n _) -> n) controllers
+      rateLimitMetrics <- registerRateLimitMetrics store
-  flags <- loadFlags rootPath allNames
+      rootPath <- fromMaybe "/tmp/" <$> liftIO (lookupEnv "HA_LIB_DIR")
-  withBus severity appMetrics flags $ \bus -> do
+      let allNames = map (\(Controller n _) -> n) controllers
-    token <- getEnv "HA_TOKEN"
+      flags <- loadFlags rootPath allNames
-    host <- getEnv "HA_HOST"
+      withBus le appMetrics flags $ \bus -> do
-    let rrdPath = rootPath </> "hass-controller.rrd"
+        token <- liftIO $ getEnv "HA_TOKEN"
-    rrdtool <- fromMaybe "rrdtool" <$> lookupEnv "HA_RRDTOOL"
+        host <- liftIO $ getEnv "HA_HOST"
-    metricsPort <- lookupPort
+        let rrdPath = rootPath </> "hass-controller.rrd"
-    writerLimiter <- slidingWindowLimiter rateLimitMetrics 10 20
+        rrdtool <- fromMaybe "rrdtool" <$> liftIO (lookupEnv "HA_RRDTOOL")
-    let ents = foldMap (\(Controller _ m) -> entities m) controllers
+        metricsPort <- lookupPort
-        workers =
+        writerLimiter <- slidingWindowLimiter rateLimitMetrics 10 20
-          [ ("reader", readerAction host 8123 token ents bus)
+        let ents = foldMap (\(Controller _ m) -> entities m) controllers
-          , ("writer", writerAction writerLimiter bus)
+            workers =
-          , ("metrics", HomeAssistant.Runtime.Metrics.metricsAction store rrdPath rrdtool)
+              [ ("reader", readerAction host 8123 token ents bus),
-          , ("metrics-http", HttpServer.runHttpServer (busLogEnv bus) rrdPath rrdtool (busFlags bus) metricsPort)
+                ("writer", writerAction writerLimiter bus),
-          ] ++ [ (name, runController rootPath bus c) | c@(Controller name _) <- controllers ]
+                ("metrics", HomeAssistant.Runtime.Metrics.metricsAction store rrdPath rrdtool),
-    runKatipContextT (busLogEnv bus) () mempty $
+                ("metrics-http", HttpServer.runHttpServer (busLogEnv bus) rrdPath rrdtool (busFlags bus) metricsPort)
-      mapConcurrently_ (uncurry supervised) workers
+              ]
+                ++ [(name, runController rootPath bus c) | c@(Controller name _) <- controllers]
+        runKatipContextT (busLogEnv bus) () mempty $
+          mapConcurrently_ (uncurry supervised) workers
+  where
+    getSeverity = maybe InfoS (const DebugS) <$> lookupEnv "HA_DEBUG"
 
 dryRunHassEval :: Namespace -> Bus -> HASSEff a -> IO a
 dryRunHassEval ns bus = \case

src/HomeAssistant/Runtime/Bus.hs

@@ -10,6 +10,7 @@ module HomeAssistant.Runtime.Bus
   , recordInbound
   , recordOutbound
   , channelHassEval
+  , withLogEnv
   ) where
 
 import Control.Concurrent.STM
@@ -51,33 +52,36 @@ data Bus = Bus
   , busFlags    :: Flags
   }
 
-withBus :: Severity -> AppMetrics -> Flags -> (Bus -> IO a) -> IO a
+withLogEnv :: Severity -> (LogEnv -> IO a) -> IO a
-withBus severity metrics flags callback = do
+withLogEnv severity f = do
   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
+  bracket makeLogEnv closeScribes $ \le -> f le
-    bus <- Bus
-          <$> newBroadcastTChanIO
-          <*> newTChanIO
-          <*> newTVarIO Nothing
-          <*> mkCallIdGen 0
-          <*> pure le
-          <*> 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"
+      systemdUnit <- isJust <$> lookupEnv "HA_CONTROLLER_SYSTEMD"
       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
 
+withBus :: MonadIO m => LogEnv -> AppMetrics -> Flags -> (Bus -> m a) -> m a
+withBus le metrics flags callback = do
+  bus <- Bus
+        <$> liftIO newBroadcastTChanIO
+        <*> liftIO newTChanIO
+        <*> liftIO (newTVarIO Nothing)
+        <*> liftIO (mkCallIdGen 0)
+        <*> pure le
+        <*> pure metrics
+        <*> pure flags
+  callback bus
+
 recordInbound :: Bus -> IO ()
 recordInbound bus = inc (amTriggersIn (busMetrics bus))
 

src/HomeAssistant/Runtime/Connection.hs

@@ -17,9 +17,7 @@ import Control.Concurrent.STM
   , writeTChan
   , writeTVar
   )
-import Control.Concurrent.Async (race)
 import Control.Concurrent (threadDelay)
-import Control.Exception (onException)
 import Control.Exception.Annotated (throw)
 import Control.Lens ((^?))
 import Control.Monad (forever, forM_, when)
@@ -33,25 +31,28 @@ import HomeAssistant.Runtime.Bus
 import HomeAssistant.Runtime.Flags (isEnabled)
 import HomeAssistant.Runtime.Supervisor (Fatal (..))
 import qualified Network.WebSockets as WS
-import Katip (sl, logFM, Severity (..), ls, Namespace (Namespace), KatipContext, katipAddNamespace, katipAddContext)
+import Katip (sl, logFM, Severity (..), ls, Namespace (Namespace), KatipContext, katipAddNamespace, katipAddContext, logLocM)
 import Data.UUID (toText)
 import AFRP (Request(..), Event(..))
 import Control.Monad.IO.Class (liftIO, MonadIO)
 import HomeAssistant.Runtime.RateLimit (RateLimited, RateLimiter, runRateLimited)
 import Control.Monad.Catch (MonadCatch)
+import GHC.Stack (HasCallStack)
+import UnliftIO (MonadUnliftIO, race, withRunInIO)
+import Control.Monad.Catch (onException)
 
 -- | Connect, authenticate, subscribe, then receive and broadcast forever.
 -- Restarting this action reconnects. All setup sends happen before the
 -- connection is published in the bus, so only the writer sends afterwards.
-readerAction :: MonadIO m => String -> Int -> String -> S.Set T.Text -> Bus -> m Void
+readerAction :: (MonadCatch m, HasCallStack, KatipContext m, MonadUnliftIO m, MonadIO m) => String -> Int -> String -> S.Set T.Text -> Bus -> m Void
-readerAction host port token ents bus = liftIO $
+readerAction host port token ents bus = katipAddNamespace "receiver" $ withRunInIO $ \rio ->
-  WS.runClient host port "/api/websocket" $ \conn -> do
+  WS.runClient host port "/api/websocket" $ \conn -> rio $ do
-    handshake conn token
+    liftIO $ handshake conn token
     subscribe bus conn ents
-    atomically $ writeTVar (busConn bus) (Just conn)
+    liftIO $ atomically $ writeTVar (busConn bus) (Just conn)
-    putStrLn "[reader] connected"
+    logLocM InfoS "connected"
     -- Unpublish on exit so the writer blocks and the backlog survives the outage.
-    receiveLoop bus conn `onException` atomically (writeTVar (busConn bus) Nothing)
+    receiveLoop bus conn `onException` liftIO (atomically (writeTVar (busConn bus) Nothing))
 
 handshake :: WS.Connection -> String -> IO ()
 handshake conn token = do
@@ -73,12 +74,12 @@ expectType expected msg =
 isTriggerEvent :: Value -> Bool
 isTriggerEvent v = v ^? key "type" . _String == Just "event"
 
-subscribe :: Bus -> WS.Connection -> S.Set T.Text -> IO ()
+subscribe :: HasCallStack => KatipContext m => Bus -> WS.Connection -> S.Set T.Text -> m ()
 subscribe bus conn ents =
   forM_ (S.toList ents) $ \entityId -> do
-    print entityId
+    logLocM InfoS $ ls entityId
-    sid <- generateCallId (busGen bus)
+    sid <- liftIO $ generateCallId (busGen bus)
-    WS.sendTextData conn $ encode $ object
+    liftIO $ WS.sendTextData conn $ encode $ object
       [ "id"         .= sid
       , "type"       .= ("subscribe_trigger" :: T.Text)
       , "trigger"    .= object
@@ -93,14 +94,14 @@ subscribe bus conn ents =
 -- Each read races a one-second timeout: a timeout broadcasts 'Tick' so
 -- time-based primitives (debounce, rollup, fixed, ...) keep advancing
 -- even when no state changes arrive.
-receiveLoop :: Bus -> WS.Connection -> IO Void
+receiveLoop :: (HasCallStack, MonadUnliftIO m, KatipContext m) => Bus -> WS.Connection -> m Void
 receiveLoop bus conn = forever $ do
-  winner <- race (threadDelay 1_000_000) (WS.receiveData conn)
+  winner <- race (liftIO $ threadDelay 1_000_000) (liftIO $ WS.receiveData conn)
   case winner of
-    Left () -> atomically $ writeTChan (busInbound bus) Tick
+    Left () -> liftIO $ atomically $ writeTChan (busInbound bus) Tick
     Right msg -> case eitherDecode msg of
-      Left err -> putStrLn $ "[reader] skipping undecodable message: " <> err
+      Left err -> logLocM WarningS $ ls $ "skipping undecodable message: " <> err
-      Right v  -> do
+      Right v  -> liftIO $ do
         when (isTriggerEvent v) (recordInbound bus)
         atomically $ writeTChan (busInbound bus) (Event v)
 
@@ -134,11 +135,11 @@ dispatchService
   => RateLimiter -> Bus -> Request -> Service -> m ()
 dispatchService rateLimiter bus request svc = do
   enabled <- isEnabled (busFlags bus) (requestHandler request)
-  if enabled
+  let logPrefix = if enabled then "Calling: " else "Skipping: "
-    then do
+  logFM InfoS (ls $ logPrefix <> show svc)
-      conn <- liftIO $ atomically $ readTVar (busConn bus) >>= maybe retry pure
+  when enabled $ do
-      runRateLimited rateLimiter $ sendWithId bus conn svc
+    conn <- liftIO $ atomically $ readTVar (busConn bus) >>= maybe retry pure
-    else logFM InfoS (ls $ "skipped disabled handler: " <> show svc)
+    runRateLimited rateLimiter $ sendWithId bus conn svc
 
 encodeService :: Int -> Service -> Value
 encodeService callId Service{..} = object $

src/HomeAssistant/Runtime/Flags.hs

@@ -12,7 +12,6 @@ module HomeAssistant.Runtime.Flags
 
 import Control.Concurrent.MVar (MVar, newMVar, withMVar)
 import Control.Concurrent.STM (TVar, atomically, newTVarIO, readTVarIO, stateTVar)
-import Control.Exception (IOException, handle)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import qualified Conduit as C
 import Conduit ((.|))
@@ -24,8 +23,12 @@ import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Text (Text)
 import System.FilePath ((</>))
-import System.IO (hPutStrLn, stderr)
 import System.IO.Error (isDoesNotExistError)
+import GHC.Stack (HasCallStack)
+import Katip (KatipContext, logLocM, Severity (..), ls)
+import Control.Monad.Catch (MonadCatch, handle)
+import Control.Exception (IOException)
+import Data.Maybe (fromMaybe)
 
 type Name = Text
 
@@ -36,14 +39,14 @@ data Flags = Flags
   , flagsValidNames :: Set Text
   }
 
-loadFlags :: MonadIO m => FilePath -> [Name] -> m Flags
+loadFlags :: (KatipContext m, MonadCatch m, MonadIO m) => FilePath -> [Name] -> m Flags
-loadFlags rootPath allNames = liftIO $ do
+loadFlags rootPath allNames = do
   let path = rootPath </> "handlers.json"
   fileMap <- readFlagsFile path
   let defaults = M.fromList [(n, True) | n <- allNames]
-      initial = M.unionWith (\fileVal _default -> fileVal) fileMap defaults
+      initial = M.unionWith (\fileVal -> const fileVal) fileMap defaults
-  tv <- newTVarIO initial
+  tv <- liftIO $ newTVarIO initial
-  lock <- newMVar ()
+  lock <- liftIO $ newMVar ()
   pure Flags
     { flagsState = tv
     , flagsLock = lock
@@ -51,21 +54,21 @@ loadFlags rootPath allNames = liftIO $ do
     , flagsValidNames = S.fromList allNames
     }
 
-readFlagsFile :: FilePath -> IO (Map Name Bool)
+readFlagsFile :: forall m. (HasCallStack, KatipContext m, MonadCatch m) => FilePath -> m (Map Name Bool)
 readFlagsFile path =
   handle onMissingOrUnreadable $ do
-    decoded <- decodeFileStrict' path
+    decoded <- liftIO $ decodeFileStrict' path
     case decoded of
       Nothing -> do
-        hPutStrLn stderr ("handlers.json is unparseable; treating all handlers as enabled: " <> path)
+        logLocM WarningS $ ls ("handlers.json is unparseable; treating all handlers as enabled: " <> path)
         pure mempty
-      Just m -> pure (maybe mempty id m)
+      Just m -> pure (fromMaybe mempty m)
   where
-    onMissingOrUnreadable :: IOException -> IO (Map Name Bool)
+    onMissingOrUnreadable :: HasCallStack => IOException -> m (Map Name Bool)
     onMissingOrUnreadable e
       | isDoesNotExistError e = pure mempty
       | otherwise = do
-          hPutStrLn stderr ("could not read handlers.json (" <> show e <> "); treating all handlers as enabled")
+          logLocM WarningS $ ls ("could not read handlers.json (" <> show e <> "); treating all handlers as enabled")
           pure mempty
 
 isEnabled :: MonadIO m => Flags -> Name -> m Bool

src/HomeAssistant/Runtime/RateLimit.hs

@@ -38,12 +38,13 @@ data RateLimiter = RateLimiter
 
 
 slidingWindowLimiter
-  :: RateLimitMetrics
+  :: MonadIO m
+  => RateLimitMetrics
   -> NominalDiffTime -- ^ Within how many seconds
   -> Int -- ^ How many requests we can make
-  -> IO RateLimiter
+  -> m RateLimiter
 slidingWindowLimiter metrics timeWindow size = do
-  window <- newTVarIO []
+  window <- liftIO $ newTVarIO []
   return $ RateLimiter metrics $ \(RateLimited action) -> do
     now <- liftIO getPOSIXTime
     allowed <- liftIO $ atomically $ do