From 18e1d68a4faa2da627202ff39075bdcffa0a649f Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Thu, 20 Aug 2026 22:34:01 +0300 Subject: [PATCH] Runtimes and controllers --- src/HomeAssistant/Controller.hs | 59 +++++++++++++++++++++---- src/HomeAssistant/Runtime.hs | 8 ++-- src/HomeAssistant/Runtime/Bus.hs | 1 - src/HomeAssistant/Runtime/Connection.hs | 2 +- test/BusSpec.hs | 3 -- 5 files changed, 56 insertions(+), 17 deletions(-) diff --git a/src/HomeAssistant/Controller.hs b/src/HomeAssistant/Controller.hs index 6766223..150af6c 100644 --- a/src/HomeAssistant/Controller.hs +++ b/src/HomeAssistant/Controller.hs @@ -22,12 +22,13 @@ module HomeAssistant.Controller , door , light , lightController + , bedroomPresenceController ) where import AFRP (Mealy, eff, Event(..), hold, events, changes, filterA, (>>|), toEvent) import Control.Arrow (Arrow(..), returnA) import Control.Category ((>>>)) -import Data.Aeson (Value) +import Data.Aeson (Value, object, (.=)) import qualified Data.Text as T import Control.Lens (has, only, (^?), to) import Data.Aeson.Lens (key, _String) @@ -38,13 +39,12 @@ data Service = Service { serviceDomain :: T.Text , serviceName :: T.Text , serviceData :: Maybe Value - , serviceTarget :: T.Text + , serviceTarget :: [T.Text] } deriving (Show, Eq) data HASSEff a where CallService :: Service -> HASSEff () - Pure :: a -> HASSEff a type HASS a b = Mealy HASSEff a b @@ -66,6 +66,49 @@ ruuvi = (Ruuvi <$> ruuviTemperatures <*> ruuviPressures) >>> changes data DoorState = Open | Closed deriving (Show, Eq) +data Presence = Occupied | Unoccupied + deriving (Show, Eq) + +presence :: T.Text -> HASS (Event Value) (Event Presence) +presence entityId =entityBool entityId + >>> arr (fmap (bool Unoccupied Occupied)) + +bedroomLights :: [T.Text] +bedroomLights = ["light.bedroom_masse","light.bedroom_jemina","light.bedroom_ceiling","light.bedroom_led_switch"] + +createBedroomScene :: Service +createBedroomScene = Service + { serviceDomain="scene" + , serviceName= "create" + , serviceData= Just $ object + [ "scene_id" .= ("makuuhuone_lights_snapshot" :: T.Text) + , "snapshot_entities" .= bedroomLights + ] + , serviceTarget= [] -- bedroomLights + } + + +activateScene :: T.Text -> Service +activateScene sceneId = Service + { serviceDomain="scene" + , serviceName= "turn_on" + , serviceTarget= [sceneId] + , serviceData = Nothing + } + +-- Bedroom presence +bedroomPresence :: HASS (Event Value) (Event Presence) +bedroomPresence = presence "binary_sensor.presence_sensor_bedroom_occupancy" + +bedroomPresenceController :: HASS (Event Value) () +bedroomPresenceController = proc x -> do + p <- bedroomPresence -< x + case p of + Event Unoccupied -> callService createBedroomScene >>> callService (light bedroomLights False) -< () + Event Occupied -> callService (activateScene "makuuhuone_lights_snapshot") -< () + _ -> returnA -< () + + door :: HASS (Event Value) (Event DoorState) door = entityBool "binary_sensor.makuuhuone_ovi_contact" >>> arr (fmap (bool Closed Open)) @@ -73,20 +116,20 @@ door = entityBool "binary_sensor.makuuhuone_ovi_contact" >>> changes -- Turn off lights when door is closed -light :: Bool -> Service -light b = Service +light :: [T.Text] -> Bool -> Service +light entityIds b = Service { serviceDomain="light" , serviceName= bool "turn_off" "turn_on" b , serviceData=Nothing - , serviceTarget="light.bedroom_masse" + , serviceTarget=entityIds } lightController :: HASS (Event Value) (Event DoorState) lightController = proc ev -> do doorState <- door -< ev case doorState of - Event Open -> callService (light False) -< () - Event Closed -> callService (light True) -< () + Event Open -> callService (light ["light.bedroom_masse"] False) -< () + Event Closed -> callService (light ["light.bedroom_masse"] True) -< () _ -> returnA -< () returnA -< doorState diff --git a/src/HomeAssistant/Runtime.hs b/src/HomeAssistant/Runtime.hs index 163d422..c9440e0 100644 --- a/src/HomeAssistant/Runtime.hs +++ b/src/HomeAssistant/Runtime.hs @@ -20,7 +20,7 @@ import Data.Aeson (Value) import qualified Data.Text as T import Data.Time (getCurrentTime) import Data.Void (Void, absurd) -import HomeAssistant.Controller (HASS, HASSEff (..), lightController) +import HomeAssistant.Controller (HASS, HASSEff (..), bedroomPresenceController) import HomeAssistant.Runtime.Bus import HomeAssistant.Runtime.Connection (readerAction, writerAction) import HomeAssistant.Runtime.Supervisor (defaultBackoff, supervised) @@ -35,7 +35,7 @@ step nt (Mealy f) a = do data Controller = forall b. Controller T.Text (HASS (Event Value) b) controllers :: [Controller] -controllers = [Controller "light" lightController] +controllers = [Controller "bedroom-presence" bedroomPresenceController] -- | 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 @@ -47,7 +47,8 @@ runController bus (Controller _name machine) = do where go inbound f = do msg <- atomically (readTChan inbound) - (_, f') <- step (channelHassEval bus) f (Event msg) + -- (_, f') <- step (channelHassEval bus) f (Event msg) + (_, f') <- step (dryRunHassEval (busGen bus)) f (Event msg) go inbound f' defaultMain :: IO () @@ -67,4 +68,3 @@ dryRunHassEval gen = \case CallService x -> do callId <- generateCallId gen print (callId, x) - Pure a -> pure a diff --git a/src/HomeAssistant/Runtime/Bus.hs b/src/HomeAssistant/Runtime/Bus.hs index bb5ead5..46cf9e3 100644 --- a/src/HomeAssistant/Runtime/Bus.hs +++ b/src/HomeAssistant/Runtime/Bus.hs @@ -42,7 +42,6 @@ newBus start = Bus channelHassEval :: Bus -> HASSEff a -> IO a channelHassEval bus = \case CallService svc -> atomically $ writeTChan (busOutbound bus) svc - Pure a -> pure a newtype CallIdGen = CallIdGen { generateCallId :: IO Int } diff --git a/src/HomeAssistant/Runtime/Connection.hs b/src/HomeAssistant/Runtime/Connection.hs index b6aed1a..b33483c 100644 --- a/src/HomeAssistant/Runtime/Connection.hs +++ b/src/HomeAssistant/Runtime/Connection.hs @@ -98,4 +98,4 @@ encodeService callId Service{..} = object $ , "domain" .= serviceDomain , "service" .= serviceName , "target" .= object ["entity_id" .= serviceTarget] - ] <> maybe [] (\d -> ["service_data" .= d]) serviceData + ] <> maybe [] (\d -> ["data" .= d]) serviceData diff --git a/test/BusSpec.hs b/test/BusSpec.hs index 989c2c5..b424cfd 100644 --- a/test/BusSpec.hs +++ b/test/BusSpec.hs @@ -32,9 +32,6 @@ spec = describe "Bus" $ do channelHassEval bus (CallService svc) atomically (readTChan (busOutbound bus)) `shouldReturn` svc - it "channelHassEval leaves Pure untouched" $ do - bus <- newBus 0 - channelHassEval bus (Pure 42) `shouldReturn` (42 :: Int) it "generates unique sequential call ids" $ do gen <- mkCallIdGen 0