diff --git a/home-assistant-controller.cabal b/home-assistant-controller.cabal index 19879a7..2cf8e41 100644 --- a/home-assistant-controller.cabal +++ b/home-assistant-controller.cabal @@ -64,6 +64,7 @@ library , HomeAssistant.Controller.Bedroom , HomeAssistant.Controller.Hallway , HomeAssistant.Controller.Kitchen + , HomeAssistant.Controller.Light.Mode , HomeAssistant.Controller.Children , HomeAssistant.Controller.Livingroom , HomeAssistant.Controller.Ruuvi diff --git a/src/HomeAssistant/Controller/Bedroom.hs b/src/HomeAssistant/Controller/Bedroom.hs index 6dc0f68..6d5fd0f 100644 --- a/src/HomeAssistant/Controller/Bedroom.hs +++ b/src/HomeAssistant/Controller/Bedroom.hs @@ -3,6 +3,7 @@ module HomeAssistant.Controller.Bedroom where import HomeAssistant.Controller +import HomeAssistant.Controller.Light.Mode (LightingMode (..)) import qualified Data.Text as T import AFRP (Event (..), lMerge, duration, edge) import Data.Aeson (Value, object, (.=)) @@ -32,17 +33,11 @@ createBedroomScene = Service , serviceTarget= [] } -data PresenceLights - = LightsOn -- Restore lights - | LightsOff -- Timer expired, darkness - | LightsSleep -- No presence detected, sleep mode - deriving (Eq, Show) - -- Bedroom presence bedroomPresence :: HASS (Event Value) (Event Presence) bedroomPresence = presence "binary_sensor.presence_sensor_bedroom_occupancy" -presenceLightEvents :: HASS (Event Value) (Event PresenceLights) +presenceLightEvents :: HASS (Event Value) (Event LightingMode) presenceLightEvents = bedroomPresence >>> AFRP.hold Unoccupied >>> arr lightWanted @@ -50,9 +45,9 @@ presenceLightEvents = >>> arr (\(s,(o,n)) -> s `AFRP.lMerge` o `AFRP.lMerge` n) where lightWanted o = o == Occupied - sleepEvent = arr not >>> AFRP.edge >>> arr (AFRP.tag LightsSleep) - onEvent = AFRP.edge >>> arr (AFRP.tag LightsOn) - offEvent = arr not >>> AFRP.waitFor 300 >>> arr (AFRP.tag LightsOff) + sleepEvent = arr not >>> AFRP.edge >>> arr (AFRP.tag LightingSleep) + onEvent = AFRP.edge >>> arr (AFRP.tag LightingOn) + offEvent = arr not >>> AFRP.waitFor 300 >>> arr (AFRP.tag LightingOff) bedroomLightsSignal :: HASS (Event Value) (Map T.Text LightSnapshot) @@ -63,13 +58,13 @@ bedroomPresenceController = proc x -> do p <- presenceLightEvents >>> traceEvent -< x snap <- (doSnapshot &&& bedroomLightsSignal) >>> AFRP.snapshot M.empty >>> traceValue -< x case p of - Event LightsOff -> do + Event LightingOff -> do callService (light bedroomLights Off) -< () - Event LightsOn -> do + Event LightingOn -> do -- callService (activateSceneWith "scene.makuuhuone_lights_snapshot" transition) -< () callServicesDyn (concatMap (uncurry toLight)) -< M.toList snap returnA -< () - Event LightsSleep -> do + Event LightingSleep -> do callService createBedroomScene -< () callService (activateSceneWith "scene.makuuhuone_lepotila" transition) -< () _ -> returnA -< () @@ -83,7 +78,7 @@ bedroomPresenceController = proc x -> do , light [EntityId entityId] (On def{lightTransition=Just 5, lightBrightness=Just (BrightnessAbsolute b)}) ] doSnapshot = presenceLightEvents - >>> arr (\ev -> if ev == Event LightsSleep then Event () else Tick) + >>> arr (\ev -> if ev == Event LightingSleep then Event () else Tick) transition = Just $ object ["transition" .= (1:: Int)] diff --git a/src/HomeAssistant/Controller/Hallway.hs b/src/HomeAssistant/Controller/Hallway.hs index 3d84f6d..db886e2 100644 --- a/src/HomeAssistant/Controller/Hallway.hs +++ b/src/HomeAssistant/Controller/Hallway.hs @@ -2,7 +2,8 @@ {-# LANGUAGE Arrows #-} module HomeAssistant.Controller.Hallway where -import HomeAssistant.Controller (Presence (..), HASS, motion, motionToPresence, traceEvent, callServiceDyn, light, Target (..), LightCommand (..)) +import HomeAssistant.Controller (Presence, HASS, motion, motionToPresence, traceEvent, callServiceDyn, light, Target (..), LightCommand (..)) +import HomeAssistant.Controller.Light.Mode (LightingMode (..), lightingModeEvents) import AFRP (Event (..)) import qualified AFRP import Data.Aeson (Value) @@ -15,25 +16,16 @@ import Data.Default (def) 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 + ev <- lightingModeEvents -< 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 def - Event LightsOff -> callServiceDyn (light [EntityId "light.hallway_lights"]) -< Off + Event LightingOn | lightsAllowed now -> callServiceDyn (light [EntityId "light.hallway_lights"]) -< On def + Event LightingOff -> 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/Controller/Kitchen.hs b/src/HomeAssistant/Controller/Kitchen.hs index e08a985..27ec651 100644 --- a/src/HomeAssistant/Controller/Kitchen.hs +++ b/src/HomeAssistant/Controller/Kitchen.hs @@ -2,6 +2,7 @@ {-# LANGUAGE Arrows #-} module HomeAssistant.Controller.Kitchen where import HomeAssistant.Controller +import HomeAssistant.Controller.Light.Mode (LightingMode (..), lightingModeEvents) import AFRP (Event (..)) import qualified AFRP import Data.Aeson (Value) @@ -13,27 +14,18 @@ import Data.Default (def) -- Kitchen has two "presence" sensors. One IKEA motion sensor and one SwitchBot presence sensor -data Lights = LightsOn | LightsOff | LightsSleep - deriving (Show) - kitchenPresence :: HASS (Event Value) Presence kitchenPresence = motion "binary_sensor.kitchen_movement_occupancy" >>> motionToPresence 500 -eventLights :: HASS Presence (Event Lights) -eventLights = AFRP.changes >>> arr (fmap presenceLights) - where - presenceLights Occupied = LightsOn - presenceLights Unoccupied = LightsOff - kitchenCeilingController :: HASS (Event Value) () kitchenCeilingController = proc x -> do now <- AFRP.currentTime -< () p <- kitchenPresence -< x - ev <- eventLights -< p + ev <- lightingModeEvents -< p traceEvent -< ev case ev of - Event LightsOn | lightsAllowed now -> callServiceDyn (light [EntityId "light.kitchen_ceiling"]) -< On def - Event LightsOff -> callServiceDyn (light [EntityId "light.kitchen_ceiling"]) -< Off + Event LightingOn | lightsAllowed now -> callServiceDyn (light [EntityId "light.kitchen_ceiling"]) -< On def + Event LightingOff -> callServiceDyn (light [EntityId "light.kitchen_ceiling"]) -< Off _ -> returnA -< () where lightsAllowed (LocalTime _ tod) = not (tod > TimeOfDay 1 45 0 && tod < TimeOfDay 5 0 0) @@ -45,7 +37,7 @@ dinnerLightLevel = entityRead "sensor.sijainti_keittio_light_level" >>> AFRP.hol dinnerPresence :: HASS (Event Value) Presence dinnerPresence = presence "binary_sensor.sijainti_keittio_occupancy" >>> AFRP.hold Unoccupied -dinnerLightEvents :: HASS (Event Value) (Event Lights) +dinnerLightEvents :: HASS (Event Value) (Event LightingMode) dinnerLightEvents = ((,) <$> dinnerLightLevel <*> dinnerPresence) >>> arr lightWanted @@ -56,29 +48,29 @@ dinnerLightEvents = onEvent = AFRP.edge - >>> arr (fmap (const LightsOn)) + >>> arr (fmap (const LightingOn)) sleepEvent = arr not >>> AFRP.edge - >>> arr (fmap (const LightsSleep)) + >>> arr (fmap (const LightingSleep)) offEvent = arr not >>> AFRP.waitFor 300 - >>> arr (fmap (const LightsOff)) + >>> arr (fmap (const LightingOff)) dinnerTableController :: HASS (Event Value) () dinnerTableController = proc x -> do ev <- dinnerLightEvents -< x case ev of - Event LightsOn -> do + Event LightingOn -> do sleep -< False callServiceDyn (light [EntityId "light.kitchen_dining_large"]) -< On def - Event LightsOff -> do + Event LightingOff -> do sleep -< False callServiceDyn (light [EntityId "light.kitchen_dining_large"]) -< Off - Event LightsSleep -> do + Event LightingSleep -> do sleep -< True _ -> returnA -< () where diff --git a/src/HomeAssistant/Controller/Light/Mode.hs b/src/HomeAssistant/Controller/Light/Mode.hs new file mode 100644 index 0000000..5d5f8f9 --- /dev/null +++ b/src/HomeAssistant/Controller/Light/Mode.hs @@ -0,0 +1,19 @@ +module HomeAssistant.Controller.Light.Mode + ( LightingMode(..) + , toLightingMode + , lightingModeEvents + ) where + +import HomeAssistant.Controller (Presence(..), HASS) +import qualified AFRP +import Control.Arrow (Arrow(..), (>>>)) + +data LightingMode = LightingOn | LightingOff | LightingSleep + deriving (Eq, Show) + +toLightingMode :: Presence -> LightingMode +toLightingMode Occupied = LightingOn +toLightingMode Unoccupied = LightingOff + +lightingModeEvents :: HASS Presence (AFRP.Event LightingMode) +lightingModeEvents = AFRP.changes >>> arr (fmap toLightingMode) diff --git a/src/HomeAssistant/Controller/Livingroom.hs b/src/HomeAssistant/Controller/Livingroom.hs index 786ff5c..c6213d5 100644 --- a/src/HomeAssistant/Controller/Livingroom.hs +++ b/src/HomeAssistant/Controller/Livingroom.hs @@ -3,6 +3,7 @@ module HomeAssistant.Controller.Livingroom where import HomeAssistant.Controller (HASS, Presence (..), Target (..), presence, callServiceDyn, light, LightCommand (..), traceEvent, callService, activateScene) +import HomeAssistant.Controller.Light.Mode (LightingMode (..), lightingModeEvents) import qualified AFRP import Control.Arrow ((>>>), Arrow (..), returnA) import Data.Aeson (Value) @@ -11,18 +12,9 @@ import Control.Category ((.)) import Data.Time (LocalTime(..), toGregorian, TimeOfDay (..)) import Data.Default (def) -data Lights = LightsOn | LightsOff - deriving (Show) - livingroomPresence :: HASS (AFRP.Event Value) Presence livingroomPresence = presence "binary_sensor.occupancy_olohuone_derived" >>> AFRP.hold Unoccupied -eventLights :: HASS Presence (AFRP.Event Lights) -eventLights = AFRP.changes >>> arr (fmap presenceLights) - where - presenceLights Occupied = LightsOn - presenceLights Unoccupied = LightsOff - -- There's a small race condition / corner case bug in the og implementation -- I have a couple of lights in the Livingroom @@ -44,11 +36,11 @@ lights = [EntityId "light.livingroom_ceiling", EntityId "light.livingroom_sofa"] livingroomPresenceController :: HASS (AFRP.Event Value) () livingroomPresenceController = proc x -> do - ev <- eventLights . livingroomPresence -< x + ev <- lightingModeEvents . livingroomPresence -< x traceEvent -< ev case ev of - AFRP.Event LightsOn -> callServiceDyn (light lights) -< On def - AFRP.Event LightsOff -> callServiceDyn (light lights) -< Off + AFRP.Event LightingOn -> callServiceDyn (light lights) -< On def + AFRP.Event LightingOff -> callServiceDyn (light lights) -< Off _ -> returnA -< () returnA -< ()