Runtimes and controllers

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 :: [T.Text] -> Bool -> Service
-light b = 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 Open -> callService (light ["light.bedroom_masse"] False) -< ()
-       Event Closed -> callService (light True) -< ()
+       Event Closed -> callService (light ["light.bedroom_masse"] True) -< ()
        _ -> returnA -< ()
   returnA -< doorState
 

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

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 }
 

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

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