diff --git a/home-assistant-controller.cabal b/home-assistant-controller.cabal index 922bf4a..2814112 100644 --- a/home-assistant-controller.cabal +++ b/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 diff --git a/src/HomeAssistant/Controller/Hallway.hs b/src/HomeAssistant/Controller/Hallway.hs new file mode 100644 index 0000000..8b63acc --- /dev/null +++ b/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) diff --git a/src/HomeAssistant/Runtime.hs b/src/HomeAssistant/Runtime.hs index 27fd57d..9a1c89b 100644 --- a/src/HomeAssistant/Runtime.hs +++ b/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-button" bedroomButtonController True - , Controller "bedroom-drawer" bedroomDrawerController True - , Controller "bedroom-humidifier" humidifierController True - , Controller "ruuvi-controller" ruuviController False - , Controller "school-light-controller" schoolLightController True - , Controller "kitchen-motion-controller" kitchenMotionController True - , Controller "livingroom-presence" livingroomPresenceController True + [ Controller "bedroom-presence" bedroomPresenceController False + , Controller "bedroom-button" bedroomButtonController False + , Controller "bedroom-drawer" bedroomDrawerController False + , Controller "bedroom-humidifier" humidifierController False + , Controller "school-light-controller" schoolLightController False + , Controller "kitchen-motion-controller" kitchenMotionController False + , Controller "livingroom-presence" livingroomPresenceController False + , Controller "hallway-motion-controller" hallwayLightsController True ] -- | Steps the machine for every inbound message; service calls go to the