Control the kitchen lights

src/HomeAssistant/Controller.hs

@@ -8,6 +8,7 @@ module HomeAssistant.Controller
   , HASSEff(..)
   , HASS
   , callService
+  , callServiceDyn
   , entityChangeEvent
   , entityChangeEvent'
   , entityRead
@@ -61,6 +62,9 @@ type HASS a b = Mealy HASSEff a b
 callService :: Service -> HASS a ()
 callService service = eff (\req _ -> CallService req service)
 
+callServiceDyn :: (a -> Service) -> HASS a ()
+callServiceDyn mkService = eff (\req a -> CallService req (mkService a))
+
 debug :: Show a => HASS a a
 debug = proc x -> do
   eff (const Debug) -< x
@@ -84,7 +88,9 @@ data DoorState = Open | Closed
 instance Serialize DoorState
 
 data Presence = Occupied | Unoccupied
-  deriving (Show, Eq)
+  deriving (Show, Eq, Generic)
+
+instance Serialize Presence
 
 presence :: T.Text -> HASS (Event Value) (Event Presence)
 presence entityId =entityBool entityId

src/HomeAssistant/Controller/Bedroom.hs

@@ -131,12 +131,12 @@ door = entityBool "binary_sensor.makuuhuone_ovi_contact"
 waitFor :: NominalDiffTime -> HASS a (Event ())
 waitFor n = duration >>> arr (> n) >>> edge
 
+
 delayedDoor :: HASS (Event Value) (Event DoorState)
 delayedDoor = door
   >>> AFRP.debounce 15
   >>> AFRP.hold Open
   >>> AFRP.changes
-  >>> traceEvent
 
 humidifierController :: HASS (Event Value) ()
 humidifierController = proc x -> do

src/HomeAssistant/Controller/Kitchen.hs

@@ -0,0 +1,59 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Arrows #-}
+module HomeAssistant.Controller.Kitchen where
+import HomeAssistant.Controller
+import AFRP (Event (..))
+import qualified AFRP
+import Data.Aeson (Value)
+import Control.Arrow ((>>>), Arrow (..), returnA)
+import Data.Bool (bool)
+import GHC.Generics (Generic)
+import Data.Serialize (Serialize)
+import Prelude hiding (id)
+import Data.Time (LocalTime(..), TimeOfDay (..))
+
+
+-- Kitchen has two "presence" sensors. One IKEA motion sensor and one SwitchBot presence sensor
+data Motion = MotionDetected | MotionNotDetected | MotionUnknown
+  deriving (Show, Eq, Generic)
+
+instance Serialize Motion
+
+data Lights = LightsOn | LightsOff
+  deriving (Show)
+
+kitchenMotion :: HASS (Event Value) Motion
+kitchenMotion = entityBool "binary_sensor.kitchen_movement_occupancy"
+  >>> arr (fmap (bool MotionNotDetected MotionDetected))
+  >>> traceEvent
+  >>> AFRP.hold MotionUnknown
+
+
+kitchenPresence :: HASS Motion Presence
+kitchenPresence = (eventOccupied &&& eventUnoccupied)
+  >>> arr (uncurry AFRP.lMerge) >>> traceEvent
+  >>> AFRP.hold Unoccupied
+  where
+    eventOccupied :: HASS Motion (Event Presence)
+    eventOccupied = arr (== MotionDetected) >>> AFRP.edge >>> arr (fmap (const Occupied))
+    eventUnoccupied :: HASS Motion (Event Presence)
+    eventUnoccupied = arr (== MotionNotDetected) >>> AFRP.waitFor 300 >>> arr (AFRP.tag Unoccupied)
+
+eventLights :: HASS Presence (Event Lights)
+eventLights = AFRP.changes >>> arr (fmap presenceLights)
+  where
+    presenceLights Occupied = LightsOn
+    presenceLights Unoccupied = LightsOff
+
+kitchenMotionController :: HASS (Event Value) ()
+kitchenMotionController = proc x -> do
+  now <- AFRP.currentTime -< ()
+  p <- kitchenMotion >>> kitchenPresence -< x
+  ev <- eventLights -< p
+  traceEvent -< ev
+  case ev of
+       Event LightsOn | lightsAllowed now -> callServiceDyn (light [EntityId "light.kitchen_ceiling"]) -< On Nothing
+       Event LightsOff -> callServiceDyn (light [EntityId "light.kitchen_ceiling"]) -< Off
+       _ -> returnA -< ()
+  where
+    lightsAllowed (LocalTime _ tod) = not (tod > TimeOfDay 1 45 0 && tod < TimeOfDay 5 0 0)

src/HomeAssistant/Runtime.hs

@@ -13,7 +13,7 @@ module HomeAssistant.Runtime
   , runController
   ) where
 
-import AFRP (Event (..), Mealy (..), Request (..), Auto, stepAutoSerializing)
+import AFRP (Event (..), Mealy (..), Request (..), Auto, stepAutoSerializing, load, DecodedAuto (..))
 import Control.Concurrent.Async (async, waitAny)
 import Control.Concurrent.STM (atomically, dupTChan, readTChan)
 import Data.Aeson (Value)
@@ -37,6 +37,7 @@ import Data.Maybe (fromMaybe)
 import qualified System.Metrics
 import qualified HomeAssistant.Runtime.Metrics
 import System.FilePath ((</>))
+import HomeAssistant.Controller.Kitchen (kitchenMotionController)
 
 step :: (MonadIO m) => FilePath -> UUID -> Auto m a b -> a -> m (b, Auto m a b)
 step path trace st a = do
@@ -52,9 +53,10 @@ controllers =
   [ Controller "bedroom-presence" bedroomPresenceController False
   , Controller "bedroom-button" bedroomButtonController False -- This works but leaving for vacation
   , Controller "bedroom-drawer" bedroomDrawerController True
-  , Controller "bedroom-humidifier" humidifierController False
+  , Controller "bedroom-humidifier" humidifierController True
   , Controller "ruuvi-controller" ruuviController False
   , Controller "school-light-controller" schoolLightController True
+  , Controller "kitchen-motion-controller" kitchenMotionController True
   ]
 
 -- | Steps the machine for every inbound message; service calls go to the
@@ -64,8 +66,11 @@ runController :: FilePath -> Bus -> Controller -> IO Void
 runController rootDir bus (Controller name machine _enabled) = do
   inbound <- atomically (dupTChan (busInbound bus))
   let ns = Namespace [name]
-  let worker = runMealy machine (runKatipContextT (busLogEnv bus) () ns . channelHassEval bus)
+  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)
   go path inbound worker
   where
     go path inbound f = do