diff --git a/AGENTS.md b/AGENTS.md index 732881e..e263235 100644 --- a/AGENTS.md +++ b/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 diff --git a/app/Main.hs b/app/Main.hs index 7650e74..cd4fc88 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -4,5 +4,4 @@ import qualified HomeAssistant.Runtime (defaultMain) main :: IO () main = do - putStrLn "Hello, Haskell!" HomeAssistant.Runtime.defaultMain diff --git a/src/AFRP.hs b/src/AFRP.hs index e6f9323..9688f52 100644 --- a/src/AFRP.hs +++ b/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 path a = handle defaultOnMissingFile (flip deserialize a <$> B.readFile path) +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 <$> 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 diff --git a/src/HomeAssistant/Controller/Bedroom.hs b/src/HomeAssistant/Controller/Bedroom.hs index 8f9ae84..225f405 100644 --- a/src/HomeAssistant/Controller/Bedroom.hs +++ b/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) -bedroomLightSnapshots = M.fromList <$> traverse (\e -> (e,) <$> observedLight e) [e | EntityId e <- bedroomLightTargets] +bedroomLightStatus :: HASS (Event Value) (Map T.Text LightObservation) +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 snap + callServicesDyn (concatMap (uncurry toLight)) -< M.toList (getSnapshot 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 entityId LightSnapshot{observedOn=False} = [light [EntityId entityId] Off] - toLight entityId LightSnapshot{observedOn=True, observedTemperature=t, observedBrightness=b} = - [ light [EntityId entityId] (On def{lightColorTemperature=Just t}) - , light [EntityId entityId] (On def{lightTransition=Just 5, lightBrightness=Just (BrightnessAbsolute b)}) + toLight :: T.Text -> LightObservation -> [Service] + toLight entityId LightObservation{observedOn=False} = [light [EntityId entityId] Off] + toLight entityId LightObservation{observedOn=True, observedTemperature=t, observedBrightness=b} = + [ light [EntityId entityId] (On def{lightTransition = Just 2, lightBrightness = Just (BrightnessAbsolute b), lightColorTemperature=Just t}) + -- , light [EntityId entityId] (On def{lightTransition = Just 2, lightBrightness=Just (BrightnessAbsolute b)}) ] doSnapshot = presenceLightEvents >>> arr (\ev -> if ev == Event LightingSleep then Event () else Tick) diff --git a/src/HomeAssistant/Controller/Light/Observation.hs b/src/HomeAssistant/Controller/Light/Observation.hs index 389baa0..b426c15 100644 --- a/src/HomeAssistant/Controller/Light/Observation.hs +++ b/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 diff --git a/src/HomeAssistant/Runtime.hs b/src/HomeAssistant/Runtime.hs index b6fbba9..1e5dcfb 100644 --- a/src/HomeAssistant/Runtime.hs +++ b/src/HomeAssistant/Runtime.hs @@ -4,46 +4,50 @@ {-# LANGUAGE OverloadedStrings #-} module HomeAssistant.Runtime - ( defaultMain - , step - , CallIdGen - , mkCallIdGen - , dryRunHassEval - , Controller(..) - , runController - ) where + ( defaultMain, + step, + CallIdGen, + mkCallIdGen, + dryRunHassEval, + Controller (..), + runController, + ) +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 HomeAssistant.Controller.Hallway (hallwayLightsController) -import qualified HttpServer -import Data.Foldable (forM_) +import Control.Monad.Catch (MonadCatch) +import Control.Exception.Annotated (checkpoint, Annotation (..)) 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-button" bedroomButtonController - , Controller "bedroom-drawer" bedroomDrawerController - , Controller "bedroom-humidifier" humidifierController - , Controller "school-light-controller" schoolLightController - , Controller "kitchen-motion-controller" kitchenMotionController - , Controller "livingroom-presence" livingroomPresenceController - , Controller "hallway-motion-controller" hallwayLightsController - , Controller "children-button" childrenBedroomButtonController - , Controller "livingroom-plants" livingroomPlantLights + [ Controller "bedroom-presence" bedroomPresenceController, + Controller "bedroom-button" bedroomButtonController, + Controller "bedroom-drawer" bedroomDrawerController, + Controller "bedroom-humidifier" humidifierController, + Controller "school-light-controller" schoolLightController, + Controller "kitchen-motion-controller" kitchenMotionController, + Controller "livingroom-presence" livingroomPresenceController, + Controller "hallway-motion-controller" hallwayLightsController, + Controller "children-button" childrenBedroomButtonController, + 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 rootDir bus (Controller name machine ) = liftIO $ do - inbound <- atomically (dupTChan (busInbound bus)) - let ns = Namespace [name] - let workerDefinition = runMealy machine (runKatipContextT (busLogEnv bus) () ns . channelHassEval bus) - let path = rootDir T.unpack name - worker <- load path workerDefinition >>= \case - Decoded a -> pure a - FailDecode err a -> a <$ putStrLn ("Failed to load (" <> T.unpack name <> "): " <> err) +runController :: forall m. (HasCallStack, MonadCatch m, KatipContext m, MonadIO m) => FilePath -> Bus -> Controller -> m Void +runController rootDir bus (Controller name machine) = checkpoint (Annotation name) $ katipAddNamespace ns $ do + inbound <- liftIO $ atomically (dupTChan (busInbound bus)) + let workerDefinition = runMealy machine (channelHassEval @m bus) + let path = rootDir T.unpack name + worker <- + load path workerDefinition >>= \case + Decoded a -> pure a + 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) - uuid <- UUID.V4.nextRandom + msg <- liftIO $ atomically (readTChan inbound) + 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 - severity <- maybe InfoS (const DebugS) <$> lookupEnv "HA_DEBUG" - store <- System.Metrics.newStore - System.Metrics.registerGcMetrics store - appMetrics <- HomeAssistant.Runtime.Metrics.registerAppMetrics store - rateLimitMetrics <- registerRateLimitMetrics store - rootPath <- fromMaybe "/tmp/" <$> lookupEnv "HA_LIB_DIR" - let allNames = map (\(Controller n _) -> n) controllers - flags <- loadFlags rootPath allNames - withBus severity appMetrics flags $ \bus -> do - token <- getEnv "HA_TOKEN" - host <- getEnv "HA_HOST" - let rrdPath = rootPath "hass-controller.rrd" - rrdtool <- fromMaybe "rrdtool" <$> lookupEnv "HA_RRDTOOL" - metricsPort <- lookupPort - writerLimiter <- slidingWindowLimiter rateLimitMetrics 10 20 - let ents = foldMap (\(Controller _ m) -> entities m) controllers - workers = - [ ("reader", readerAction host 8123 token ents bus) - , ("writer", writerAction writerLimiter bus) - , ("metrics", HomeAssistant.Runtime.Metrics.metricsAction store rrdPath rrdtool) - , ("metrics-http", HttpServer.runHttpServer (busLogEnv bus) rrdPath rrdtool (busFlags bus) metricsPort) - ] ++ [ (name, runController rootPath bus c) | c@(Controller name _) <- controllers ] - runKatipContextT (busLogEnv bus) () mempty $ - mapConcurrently_ (uncurry supervised) workers +defaultMain = + withSocketsDo $ + getSeverity >>= \s -> withLogEnv s $ \le -> runKatipContextT le () mempty $ do + logLocM InfoS "Hello world" + store <- liftIO System.Metrics.newStore + liftIO $ System.Metrics.registerGcMetrics store + appMetrics <- liftIO $ HomeAssistant.Runtime.Metrics.registerAppMetrics store + rateLimitMetrics <- registerRateLimitMetrics store + rootPath <- fromMaybe "/tmp/" <$> liftIO (lookupEnv "HA_LIB_DIR") + let allNames = map (\(Controller n _) -> n) controllers + flags <- loadFlags rootPath allNames + withBus le appMetrics flags $ \bus -> do + token <- liftIO $ getEnv "HA_TOKEN" + host <- liftIO $ getEnv "HA_HOST" + let rrdPath = rootPath "hass-controller.rrd" + rrdtool <- fromMaybe "rrdtool" <$> liftIO (lookupEnv "HA_RRDTOOL") + metricsPort <- lookupPort + writerLimiter <- slidingWindowLimiter rateLimitMetrics 10 20 + let ents = foldMap (\(Controller _ m) -> entities m) controllers + workers = + [ ("reader", readerAction host 8123 token ents bus), + ("writer", writerAction writerLimiter bus), + ("metrics", HomeAssistant.Runtime.Metrics.metricsAction store rrdPath rrdtool), + ("metrics-http", HttpServer.runHttpServer (busLogEnv bus) rrdPath rrdtool (busFlags bus) metricsPort) + ] + ++ [(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 diff --git a/src/HomeAssistant/Runtime/Bus.hs b/src/HomeAssistant/Runtime/Bus.hs index 8838238..4a16d46 100644 --- a/src/HomeAssistant/Runtime/Bus.hs +++ b/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 -withBus severity metrics flags callback = do +withLogEnv :: Severity -> (LogEnv -> IO a) -> IO a +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 - bus <- Bus - <$> newBroadcastTChanIO - <*> newTChanIO - <*> newTVarIO Nothing - <*> mkCallIdGen 0 - <*> pure le - <*> pure metrics - <*> pure flags - callback bus + bracket makeLogEnv closeScribes $ \le -> f le 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)) diff --git a/src/HomeAssistant/Runtime/Connection.hs b/src/HomeAssistant/Runtime/Connection.hs index 5bfe287..4e62d10 100644 --- a/src/HomeAssistant/Runtime/Connection.hs +++ b/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 host port token ents bus = liftIO $ - WS.runClient host port "/api/websocket" $ \conn -> do - handshake conn token +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 = katipAddNamespace "receiver" $ withRunInIO $ \rio -> + WS.runClient host port "/api/websocket" $ \conn -> rio $ do + liftIO $ handshake conn token subscribe bus conn ents - atomically $ writeTVar (busConn bus) (Just conn) - putStrLn "[reader] connected" + liftIO $ atomically $ writeTVar (busConn bus) (Just conn) + 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 - sid <- generateCallId (busGen bus) - WS.sendTextData conn $ encode $ object + logLocM InfoS $ ls entityId + sid <- liftIO $ generateCallId (busGen bus) + 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 - Right v -> do + Left err -> logLocM WarningS $ ls $ "skipping undecodable message: " <> err + 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 - then do - conn <- liftIO $ atomically $ readTVar (busConn bus) >>= maybe retry pure - runRateLimited rateLimiter $ sendWithId bus conn svc - else logFM InfoS (ls $ "skipped disabled handler: " <> show svc) + let logPrefix = if enabled then "Calling: " else "Skipping: " + logFM InfoS (ls $ logPrefix <> show svc) + when enabled $ do + conn <- liftIO $ atomically $ readTVar (busConn bus) >>= maybe retry pure + runRateLimited rateLimiter $ sendWithId bus conn svc encodeService :: Int -> Service -> Value encodeService callId Service{..} = object $ diff --git a/src/HomeAssistant/Runtime/Flags.hs b/src/HomeAssistant/Runtime/Flags.hs index c594e9e..684055f 100644 --- a/src/HomeAssistant/Runtime/Flags.hs +++ b/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 rootPath allNames = liftIO $ do +loadFlags :: (KatipContext m, MonadCatch m, MonadIO m) => FilePath -> [Name] -> m Flags +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 - tv <- newTVarIO initial - lock <- newMVar () + initial = M.unionWith (\fileVal -> const fileVal) fileMap defaults + tv <- liftIO $ newTVarIO initial + 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 diff --git a/src/HomeAssistant/Runtime/RateLimit.hs b/src/HomeAssistant/Runtime/RateLimit.hs index 080e011..a574dc3 100644 --- a/src/HomeAssistant/Runtime/RateLimit.hs +++ b/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