Hallway lights automation

home-assistant-controller.cabal

@@ -62,6 +62,7 @@ library
     exposed-modules:  AFRP
                     , HomeAssistant.Controller
                     , HomeAssistant.Controller.Bedroom
+                    , HomeAssistant.Controller.Hallway
                     , HomeAssistant.Controller.Kitchen
                     , HomeAssistant.Controller.Children
                     , HomeAssistant.Controller.Livingroom

src/HomeAssistant/Controller/Hallway.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Arrows #-}
+module HomeAssistant.Controller.Hallway where
+
+import HomeAssistant.Controller (Presence (..), HASS, motion, motionToPresence, traceEvent, callServiceDyn, light, Target (..), Light (..))
+import AFRP (Event (..))
+import qualified AFRP
+import Data.Aeson (Value)
+import Control.Arrow ((>>>), Arrow (..), returnA)
+import Data.Time (LocalTime(..), TimeOfDay (..))
+
+
+
+hallwayPresence :: HASS (Event Value) Presence
+hallwayPresence = motion "binary_sensor.hallway_movement_occupancy" >>> motionToPresence 500
+
+data Lights = LightsOn | LightsOff
+  deriving (Show)
+
+eventLights :: HASS Presence (Event Lights)
+eventLights = AFRP.changes >>> arr (fmap presenceLights)
+  where
+    presenceLights Occupied = LightsOn
+    presenceLights Unoccupied = LightsOff
+
+hallwayLightsController :: HASS (Event Value) ()
+hallwayLightsController = proc x -> do
+  now <- AFRP.currentTime -< ()
+  p <- hallwayPresence -< x
+  ev <- eventLights -< p
+  traceEvent -< ev
+  case ev of
+       -- The lights entity is a "group of lights" in hass
+       Event LightsOn | lightsAllowed now -> callServiceDyn (light [EntityId "light.hallway_lights"]) -< On Nothing
+       Event LightsOff -> callServiceDyn (light [EntityId "light.hallway_lights"]) -< Off
+       _ -> returnA -< ()
+  where
+    lightsAllowed (LocalTime _ tod) = not (tod > TimeOfDay 1 45 0 && tod < TimeOfDay 5 0 0)

src/HomeAssistant/Runtime.hs

@@ -29,7 +29,6 @@ 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.Ruuvi (ruuviController)
 import HomeAssistant.Controller.Children (schoolLightController)
 import Data.Maybe (fromMaybe)
 import qualified System.Metrics
@@ -42,6 +41,7 @@ import HomeAssistant.Runtime.RateLimit (slidingWindowLimiter, registerRateLimitM
 import UnliftIO.Async
 import HomeAssistant.Runtime.Supervisor (supervised)
 import qualified HomeAssistant.Runtime.Graphing
+import HomeAssistant.Controller.Hallway (hallwayLightsController)
 
 step :: (MonadIO m) => FilePath -> UUID -> Auto m a b -> a -> m (b, Auto m a b)
 step path trace st a = do
@@ -54,14 +54,14 @@ data Controller = forall b. Controller T.Text (HASS (Event Value) b) Bool
 
 controllers :: [Controller]
 controllers =
-  [ Controller "bedroom-presence" bedroomPresenceController True
+  [ Controller "bedroom-presence" bedroomPresenceController False
-  , Controller "bedroom-button" bedroomButtonController True
+  , Controller "bedroom-button" bedroomButtonController False
-  , Controller "bedroom-drawer" bedroomDrawerController True
+  , Controller "bedroom-drawer" bedroomDrawerController False
-  , Controller "bedroom-humidifier" humidifierController True
+  , Controller "bedroom-humidifier" humidifierController False
-  , Controller "ruuvi-controller" ruuviController False
+  , Controller "school-light-controller" schoolLightController False
-  , Controller "school-light-controller" schoolLightController True
+  , Controller "kitchen-motion-controller" kitchenMotionController False
-  , Controller "kitchen-motion-controller" kitchenMotionController True
+  , Controller "livingroom-presence" livingroomPresenceController False
-  , Controller "livingroom-presence" livingroomPresenceController True
+  , Controller "hallway-motion-controller" hallwayLightsController True
   ]
 
 -- | Steps the machine for every inbound message; service calls go to the