From adce7c842783d5e7bb0d96139a801c3535069ff3 Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Wed, 30 Sep 2026 00:07:31 +0300 Subject: [PATCH] Split Controller.hs into vertical submodules behind umbrella re-export --- home-assistant-controller.cabal | 16 +- src/HomeAssistant/Controller.hs | 349 +----------------- src/HomeAssistant/Controller/Door.hs | 9 + src/HomeAssistant/Controller/Effect.hs | 55 +++ src/HomeAssistant/Controller/Entity.hs | 50 +++ src/HomeAssistant/Controller/Ikea.hs | 80 ++++ src/HomeAssistant/Controller/Light/Command.hs | 62 ++++ src/HomeAssistant/Controller/Light/Mode.hs | 3 +- .../Controller/Light/Observation.hs | 53 +++ src/HomeAssistant/Controller/Presence.hs | 55 +++ src/HomeAssistant/Controller/Scene.hs | 21 ++ src/HomeAssistant/Controller/Service.hs | 18 + src/HomeAssistant/Controller/Switch.hs | 14 + 13 files changed, 444 insertions(+), 341 deletions(-) create mode 100644 src/HomeAssistant/Controller/Door.hs create mode 100644 src/HomeAssistant/Controller/Effect.hs create mode 100644 src/HomeAssistant/Controller/Entity.hs create mode 100644 src/HomeAssistant/Controller/Ikea.hs create mode 100644 src/HomeAssistant/Controller/Light/Command.hs create mode 100644 src/HomeAssistant/Controller/Light/Observation.hs create mode 100644 src/HomeAssistant/Controller/Presence.hs create mode 100644 src/HomeAssistant/Controller/Scene.hs create mode 100644 src/HomeAssistant/Controller/Service.hs create mode 100644 src/HomeAssistant/Controller/Switch.hs diff --git a/home-assistant-controller.cabal b/home-assistant-controller.cabal index 2cf8e41..151e5bb 100644 --- a/home-assistant-controller.cabal +++ b/home-assistant-controller.cabal @@ -62,12 +62,22 @@ library exposed-modules: AFRP , HomeAssistant.Controller , HomeAssistant.Controller.Bedroom - , HomeAssistant.Controller.Hallway - , HomeAssistant.Controller.Kitchen - , HomeAssistant.Controller.Light.Mode , HomeAssistant.Controller.Children + , HomeAssistant.Controller.Door + , HomeAssistant.Controller.Effect + , HomeAssistant.Controller.Entity + , HomeAssistant.Controller.Hallway + , HomeAssistant.Controller.Ikea + , HomeAssistant.Controller.Kitchen + , HomeAssistant.Controller.Light.Command + , HomeAssistant.Controller.Light.Mode + , HomeAssistant.Controller.Light.Observation , HomeAssistant.Controller.Livingroom + , HomeAssistant.Controller.Presence , HomeAssistant.Controller.Ruuvi + , HomeAssistant.Controller.Scene + , HomeAssistant.Controller.Service + , HomeAssistant.Controller.Switch , HomeAssistant.Runtime , HomeAssistant.Runtime.Bus , HomeAssistant.Runtime.Connection diff --git a/src/HomeAssistant/Controller.hs b/src/HomeAssistant/Controller.hs index 16634e0..202fa78 100644 --- a/src/HomeAssistant/Controller.hs +++ b/src/HomeAssistant/Controller.hs @@ -1,340 +1,15 @@ -{-# LANGUAGE Arrows #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MonadComprehensions #-} - module HomeAssistant.Controller - ( Service(..) - , HASSEff(..) - , HASS - , callService - , callServices - , callServiceDyn - , callServicesDyn - , entityChangeEvent - , entityChangeEvent' - , entityRead - , entityRead' - , entityBool - , entityBool' - , DoorState(..) - , light - , Presence(..) - , presence - , motion - , motionToPresence - , debug - , traceEvent - , traceValue - , switchService - , Target(..) - , lightBrightnessEvent - , lightTemperatureEvent - , LightCommand(..) - , observedLight - , LightSnapshot(..) - , ikeaQuickButton - , IkeaButton(..) - , IkeaGesture(..) - , activateScene - , activateSceneWith - , ikeaBoxRemote - , IkeaRemoteAction(..) - , LightAttributes(..) - , Brightness(..) - , formatLightAttributes + ( module Export ) where -import AFRP (Mealy (..), eff, Event(..), events, filterA, (>>|), toEvent, Request, hold, lMerge, waitFor, tag, edge) -import Control.Arrow (Arrow(..), returnA) -import Control.Category ((>>>), (.)) -import Prelude hiding ((.)) -import Data.Aeson (Value, object, (.=)) -import qualified Data.Text as T -import qualified Data.Set as S -import Control.Lens (has, only, (^?), to, traversed) -import Data.Aeson.Lens (key, _String, _Integral) -import qualified Data.Text.Lens as TL -import Data.Bool (bool) -import Data.Serialize (Serialize) -import GHC.Generics (Generic) -import Data.Time (NominalDiffTime) -import Data.Default (Default) -import Data.Aeson.Types (Pair) -import Data.Maybe (catMaybes) - -data Target = EntityId !T.Text | AreaId !T.Text - deriving (Show,Eq,Ord) - -data Service = Service - { serviceDomain :: T.Text - , serviceName :: T.Text - , serviceData :: Maybe Value - , serviceTarget :: [Target] - } - deriving (Show, Eq) - -data HASSEff a where - CallService :: Request -> Service -> HASSEff () - CallServices :: Request -> [Service] -> HASSEff () - Debug :: Show a => a -> HASSEff () - Trace :: Show a => Request -> a -> HASSEff () - -type HASS a b = Mealy HASSEff a b - -callService :: Service -> HASS a () -callService service = eff (\req _ -> CallService req service) - -callServices :: [Service] -> HASS a () -callServices service = eff (\req _ -> CallServices req service) - -callServiceDyn :: (a -> Service) -> HASS a () -callServiceDyn mkService = eff (\req a -> CallService req (mkService a)) - -callServicesDyn :: (a -> [Service]) -> HASS a () -callServicesDyn mkService = eff (\req a -> CallServices req (mkService a)) - -debug :: Show a => HASS a a -debug = proc x -> do - eff (const Debug) -< x - returnA -< x - -traceEvent :: Show a => HASS (Event a) (Event a) -traceEvent = proc ev -> do - case ev of - Event a -> eff Trace -< a - Tick -> returnA -< () - returnA -< ev - -traceValue :: Show a => HASS a a -traceValue = proc x -> do - eff Trace -< x - returnA -< x - -data DoorState = Open | Closed - deriving (Show, Eq, Generic) - -instance Serialize DoorState - -data Presence = Occupied | Unoccupied - deriving (Show, Eq, Generic) - -instance Serialize Presence - -presence :: T.Text -> HASS (Event Value) (Event Presence) -presence entityId = entityBool entityId - >>> arr (fmap (bool Unoccupied Occupied)) - - -data Motion = MotionDetected | MotionNotDetected | MotionUnknown - deriving (Show, Eq, Generic) - - -motion :: T.Text -> HASS (Event Value) Motion -motion entityId = entityBool entityId - >>> arr (fmap (bool MotionNotDetected MotionDetected)) - >>> hold MotionUnknown - - --- Convert a motion status into a simulated presence --- --- A motion tracker detects _motion_, but if you are still, it can't detect you. --- A simple and cheap heuristic is to assume the person is a bit longer there -motionToPresence :: NominalDiffTime -> HASS Motion Presence -motionToPresence delay = (eventOccupied &&& eventUnoccupied) - >>> arr (uncurry lMerge) - >>> AFRP.hold Unoccupied - where - eventOccupied :: HASS Motion (Event Presence) - eventOccupied = arr (== MotionDetected) >>> edge >>> arr (fmap (const Occupied)) - eventUnoccupied :: HASS Motion (Event Presence) - eventUnoccupied = arr (== MotionNotDetected) >>> waitFor delay >>> arr (tag Unoccupied) - -instance Serialize Motion - -data Brightness = BrightnessPercent Double | BrightnessAbsolute Int - deriving (Show, Generic) -instance Default Brightness where - -data LightAttributes = LightAttributes - { lightBrightness :: Maybe Brightness - , lightColorTemperature :: Maybe Int - , lightTransition :: Maybe Double - } - deriving (Show, Generic) - - -instance Default LightAttributes where - - -formatLightAttributes :: LightAttributes -> Maybe Value -formatLightAttributes s = toObject $ catMaybes - [ ["transition" .= x | x <- lightTransition s] - , ["color_temp_kelvin" .= k | k <- lightColorTemperature s] - , ["brightness" .= b | BrightnessAbsolute b <- lightBrightness s] - , ["brightness_pct" .= b | BrightnessPercent b <- lightBrightness s] - ] - where - toObject :: [Pair] -> Maybe Value - toObject [] = Nothing - toObject xs = Just $ object xs - -data LightCommand - = Off - | On LightAttributes - --- Turn off lights when door is closed -light :: [Target] -> LightCommand -> Service -light targets (On settings) = Service - { serviceDomain="light" - , serviceName= "turn_on" - , serviceData= formatLightAttributes settings - , serviceTarget=targets - } -light targets Off = Service - { serviceDomain="light" - , serviceName= "turn_off" - , serviceData=Nothing - , serviceTarget=targets - } - -switchService :: [Target] -> Bool -> Service -switchService targets b = Service - { serviceDomain="switch" - , serviceName= bool "turn_off" "turn_on" b - , serviceData=Nothing - , serviceTarget=targets - } - - -entityChangeEvent :: T.Text -> Mealy eff (Event Value) (Event Value) -entityChangeEvent entityId = entityChangeEvent' entityId >>> toEvent - -entityChangeEvent' :: T.Text -> Mealy eff (Event Value) (Either () Value) -entityChangeEvent' entityId = Mealy (S.singleton entityId) $ runMealy (events >>| filterA isEntity) - where - isEntity :: Value -> Bool - isEntity = has (key "event" . key "variables" . key "trigger" . key "entity_id" . _String . only entityId) - -entityRead' :: (Read a) => T.Text -> Mealy eff (Event Value) (Either () a) -entityRead' entityId = entityChangeEvent' entityId >>| (arr state >>> arr (maybe (Left ()) Right)) - where - state v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "state" . _String . TL.unpacked . to read - -entityBool' :: T.Text -> Mealy eff (Event Value) (Either () Bool) -entityBool' entityId = entityChangeEvent' entityId >>| (arr state >>> arr (maybe (Left ()) Right)) - where - state v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "state" . _String . TL.unpacked . to toBool - toBool = \case - "on" -> True - "off" -> False - _ -> False - -entityRead :: (Read a) => T.Text -> Mealy eff (Event Value) (Event a) -entityRead entityId = entityRead' entityId >>> toEvent - -entityBool :: T.Text -> Mealy eff (Event Value) (Event Bool) -entityBool entityId = entityBool' entityId >>> toEvent - -lightBrightnessEvent :: T.Text -> HASS (Event Value) (Event Int) -lightBrightnessEvent entityId = - entityChangeEvent' entityId - >>| arr (maybe (Left ()) Right . eventBrightness) - >>> AFRP.toEvent - where - eventBrightness v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "attributes" . key "brightness" . _Integral - -lightTemperatureEvent :: T.Text -> HASS (Event Value) (Event Int) -lightTemperatureEvent entityId = - entityChangeEvent' entityId - >>| arr (maybe (Left ()) Right . eventTemperature) - >>> AFRP.toEvent - where - eventTemperature v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "attributes" . key "color_temp_kelvin" . _Integral - -data LightSnapshot = LightSnapshot - { observedOn :: Bool - , observedBrightness :: Int - , observedTemperature :: Int - } - deriving (Show, Generic, Eq) -instance Serialize LightSnapshot - -observedLight :: T.Text -> HASS (Event Value) LightSnapshot -observedLight entityId = proc ev -> do - e <- hold False . entityBool entityId -< ev - b <- hold 0 . lightBrightnessEvent entityId -< ev - t <- hold 0 . lightTemperatureEvent entityId -< ev - returnA -< LightSnapshot e b t - -data IkeaGesture - = ShortClick - | ShortRelease - | DoubleClick - | LongClick - deriving Show - -data IkeaButton a = OnButton !a | OffButton !a - deriving Show - - -toIkeaQuickButton :: T.Text -> Maybe (IkeaButton IkeaGesture) -toIkeaQuickButton = \case - -- 1 is on, 2 is off side of the button - "1_initial_press" -> Just $ OnButton ShortClick - "1_short_release" -> Just $ OnButton ShortRelease - "1_double_press" -> Just $ OnButton DoubleClick - "1_long_press" -> Just $ OnButton LongClick - "2_initial_press" -> Just $ OffButton ShortClick - "2_short_release" -> Just $ OffButton ShortRelease - "2_double_press" -> Just $ OffButton DoubleClick - "2_long_press" -> Just $ OffButton LongClick - _ -> Nothing - -ikeaQuickButton :: T.Text -> HASS (Event Value) (Event (IkeaButton IkeaGesture)) -ikeaQuickButton entityId = - entityChangeEvent' entityId - >>| arr (maybe (Left ()) Right . eventType) - >>> toEvent - where - eventType v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "attributes" . key "event_type" . _String . to toIkeaQuickButton . traversed - -data IkeaRemoteAction - = RemoteOn -- Short press on - | RemoteOff -- Short press off - | RemoteBrightnessUp -- Turn brightness up - | RemoteBrightnessDown -- Turn brightness down - | RemoteArrowRight -- Arrow right - | RemoteArrowLeft -- Arrow left - | RemoteBrightnessStop - deriving Show - -toIkeaController :: T.Text -> Maybe IkeaRemoteAction -toIkeaController = \case - "on" -> Just RemoteOn - "off" -> Just RemoteOff - "brightness_move_up" -> Just RemoteBrightnessUp - "brightness_move_down" -> Just RemoteBrightnessDown - "brightness_stop" -> Just RemoteBrightnessStop - "arrow_right_click" -> Just RemoteArrowRight - "arrow_left_click" -> Just RemoteArrowLeft - _ -> Nothing - -ikeaBoxRemote :: T.Text -> HASS (Event Value) (Event IkeaRemoteAction) -ikeaBoxRemote entityId = entityChangeEvent' entityId - >>| arr (maybe (Left ()) Right . eventType) - >>> toEvent - where - eventType v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "attributes" . key "event_type" . _String . to toIkeaController . traversed - -activateScene :: T.Text -> Service -activateScene sceneId = activateSceneWith sceneId Nothing - -activateSceneWith :: T.Text -> Maybe Value -> Service -activateSceneWith sceneId d = Service - { serviceDomain="scene" - , serviceName= "turn_on" - , serviceTarget= [EntityId sceneId] - , serviceData = d - } +import HomeAssistant.Controller.Service as Export +import HomeAssistant.Controller.Effect as Export +import HomeAssistant.Controller.Entity as Export +import HomeAssistant.Controller.Presence as Export +import HomeAssistant.Controller.Door as Export +import HomeAssistant.Controller.Switch as Export +import HomeAssistant.Controller.Scene as Export +import HomeAssistant.Controller.Ikea as Export +import HomeAssistant.Controller.Light.Command as Export +import HomeAssistant.Controller.Light.Observation as Export +import HomeAssistant.Controller.Light.Mode as Export diff --git a/src/HomeAssistant/Controller/Door.hs b/src/HomeAssistant/Controller/Door.hs new file mode 100644 index 0000000..33ddceb --- /dev/null +++ b/src/HomeAssistant/Controller/Door.hs @@ -0,0 +1,9 @@ +module HomeAssistant.Controller.Door (DoorState(..)) where + +import GHC.Generics (Generic) +import Data.Serialize (Serialize) + +data DoorState = Open | Closed + deriving (Show, Eq, Generic) + +instance Serialize DoorState diff --git a/src/HomeAssistant/Controller/Effect.hs b/src/HomeAssistant/Controller/Effect.hs new file mode 100644 index 0000000..48ab98b --- /dev/null +++ b/src/HomeAssistant/Controller/Effect.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE GADTs #-} + +module HomeAssistant.Controller.Effect + ( HASSEff(..) + , HASS + , callService + , callServices + , callServiceDyn + , callServicesDyn + , debug + , traceEvent + , traceValue + ) where + +import AFRP (Mealy, eff, Event (..), Request) +import Control.Arrow (returnA) +import HomeAssistant.Controller.Service (Service) + +data HASSEff a where + CallService :: Request -> Service -> HASSEff () + CallServices :: Request -> [Service] -> HASSEff () + Debug :: Show a => a -> HASSEff () + Trace :: Show a => Request -> a -> HASSEff () + +type HASS a b = Mealy HASSEff a b + +callService :: Service -> HASS a () +callService service = eff (\req _ -> CallService req service) + +callServices :: [Service] -> HASS a () +callServices service = eff (\req _ -> CallServices req service) + +callServiceDyn :: (a -> Service) -> HASS a () +callServiceDyn mkService = eff (\req a -> CallService req (mkService a)) + +callServicesDyn :: (a -> [Service]) -> HASS a () +callServicesDyn mkService = eff (\req a -> CallServices req (mkService a)) + +debug :: Show a => HASS a a +debug = proc x -> do + eff (const Debug) -< x + returnA -< x + +traceEvent :: Show a => HASS (Event a) (Event a) +traceEvent = proc ev -> do + case ev of + Event a -> eff Trace -< a + Tick -> returnA -< () + returnA -< ev + +traceValue :: Show a => HASS a a +traceValue = proc x -> do + eff Trace -< x + returnA -< x diff --git a/src/HomeAssistant/Controller/Entity.hs b/src/HomeAssistant/Controller/Entity.hs new file mode 100644 index 0000000..4819ffe --- /dev/null +++ b/src/HomeAssistant/Controller/Entity.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module HomeAssistant.Controller.Entity + ( entityChangeEvent + , entityChangeEvent' + , entityRead + , entityRead' + , entityBool + , entityBool' + ) where + +import AFRP (Mealy (..), Event, events, filterA, (>>|), toEvent) +import Control.Arrow (arr) +import Control.Category ((>>>)) +import Data.Aeson (Value) +import Data.Aeson.Lens (key, _String) +import qualified Data.Text as T +import qualified Data.Set as S +import Control.Lens (has, only, (^?), to) +import qualified Data.Text.Lens as TL + +entityChangeEvent :: T.Text -> Mealy eff (Event Value) (Event Value) +entityChangeEvent entityId = entityChangeEvent' entityId >>> toEvent + +entityChangeEvent' :: T.Text -> Mealy eff (Event Value) (Either () Value) +entityChangeEvent' entityId = Mealy (S.singleton entityId) $ runMealy (events >>| filterA isEntity) + where + isEntity :: Value -> Bool + isEntity = has (key "event" . key "variables" . key "trigger" . key "entity_id" . _String . only entityId) + +entityRead' :: (Read a) => T.Text -> Mealy eff (Event Value) (Either () a) +entityRead' entityId = entityChangeEvent' entityId >>| (arr state >>> arr (maybe (Left ()) Right)) + where + state v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "state" . _String . TL.unpacked . to read + +entityBool' :: T.Text -> Mealy eff (Event Value) (Either () Bool) +entityBool' entityId = entityChangeEvent' entityId >>| (arr state >>> arr (maybe (Left ()) Right)) + where + state v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "state" . _String . TL.unpacked . to toBool + toBool = \case + "on" -> True + "off" -> False + _ -> False + +entityRead :: (Read a) => T.Text -> Mealy eff (Event Value) (Event a) +entityRead entityId = entityRead' entityId >>> toEvent + +entityBool :: T.Text -> Mealy eff (Event Value) (Event Bool) +entityBool entityId = entityBool' entityId >>> toEvent diff --git a/src/HomeAssistant/Controller/Ikea.hs b/src/HomeAssistant/Controller/Ikea.hs new file mode 100644 index 0000000..4e6befe --- /dev/null +++ b/src/HomeAssistant/Controller/Ikea.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module HomeAssistant.Controller.Ikea + ( IkeaGesture(..) + , IkeaButton(..) + , IkeaRemoteAction(..) + , ikeaQuickButton + , ikeaBoxRemote + ) where + +import AFRP (Event, toEvent, (>>|)) +import Control.Arrow (arr) +import Control.Category ((>>>)) +import Control.Lens ((^?), to, traversed) +import Data.Aeson (Value) +import Data.Aeson.Lens (key, _String) +import qualified Data.Text as T +import HomeAssistant.Controller.Entity (entityChangeEvent') +import HomeAssistant.Controller.Effect (HASS) + +data IkeaGesture + = ShortClick + | ShortRelease + | DoubleClick + | LongClick + deriving Show + +data IkeaButton a = OnButton !a | OffButton !a + deriving Show + + +toIkeaQuickButton :: T.Text -> Maybe (IkeaButton IkeaGesture) +toIkeaQuickButton = \case + -- 1 is on, 2 is off side of the button + "1_initial_press" -> Just $ OnButton ShortClick + "1_short_release" -> Just $ OnButton ShortRelease + "1_double_press" -> Just $ OnButton DoubleClick + "1_long_press" -> Just $ OnButton LongClick + "2_initial_press" -> Just $ OffButton ShortClick + "2_short_release" -> Just $ OffButton ShortRelease + "2_double_press" -> Just $ OffButton DoubleClick + "2_long_press" -> Just $ OffButton LongClick + _ -> Nothing + +ikeaQuickButton :: T.Text -> HASS (Event Value) (Event (IkeaButton IkeaGesture)) +ikeaQuickButton entityId = + entityChangeEvent' entityId + >>| arr (maybe (Left ()) Right . eventType) + >>> toEvent + where + eventType v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "attributes" . key "event_type" . _String . to toIkeaQuickButton . traversed + +data IkeaRemoteAction + = RemoteOn -- Short press on + | RemoteOff -- Short press off + | RemoteBrightnessUp -- Turn brightness up + | RemoteBrightnessDown -- Turn brightness down + | RemoteArrowRight -- Arrow right + | RemoteArrowLeft -- Arrow left + | RemoteBrightnessStop + deriving Show + +toIkeaController :: T.Text -> Maybe IkeaRemoteAction +toIkeaController = \case + "on" -> Just RemoteOn + "off" -> Just RemoteOff + "brightness_move_up" -> Just RemoteBrightnessUp + "brightness_move_down" -> Just RemoteBrightnessDown + "brightness_stop" -> Just RemoteBrightnessStop + "arrow_right_click" -> Just RemoteArrowRight + "arrow_left_click" -> Just RemoteArrowLeft + _ -> Nothing + +ikeaBoxRemote :: T.Text -> HASS (Event Value) (Event IkeaRemoteAction) +ikeaBoxRemote entityId = entityChangeEvent' entityId + >>| arr (maybe (Left ()) Right . eventType) + >>> toEvent + where + eventType v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "attributes" . key "event_type" . _String . to toIkeaController . traversed diff --git a/src/HomeAssistant/Controller/Light/Command.hs b/src/HomeAssistant/Controller/Light/Command.hs new file mode 100644 index 0000000..1853f80 --- /dev/null +++ b/src/HomeAssistant/Controller/Light/Command.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE OverloadedStrings #-} + +module HomeAssistant.Controller.Light.Command + ( LightCommand(..) + , LightAttributes(..) + , Brightness(..) + , light + , formatLightAttributes + ) where + +import Data.Aeson (Value, object, (.=)) +import Data.Aeson.Types (Pair) +import Data.Default (Default) +import Data.Maybe (catMaybes) +import GHC.Generics (Generic) +import HomeAssistant.Controller.Service (Service (..), Target) + +data Brightness = BrightnessPercent Double | BrightnessAbsolute Int + deriving (Show, Generic) +instance Default Brightness where + +data LightAttributes = LightAttributes + { lightBrightness :: Maybe Brightness + , lightColorTemperature :: Maybe Int + , lightTransition :: Maybe Double + } + deriving (Show, Generic) + + +instance Default LightAttributes where + + +formatLightAttributes :: LightAttributes -> Maybe Value +formatLightAttributes s = toObject $ catMaybes + [ ["transition" .= x | x <- lightTransition s] + , ["color_temp_kelvin" .= k | k <- lightColorTemperature s] + , ["brightness" .= b | BrightnessAbsolute b <- lightBrightness s] + , ["brightness_pct" .= b | BrightnessPercent b <- lightBrightness s] + ] + where + toObject :: [Pair] -> Maybe Value + toObject [] = Nothing + toObject xs = Just $ object xs + +data LightCommand + = Off + | On LightAttributes + +light :: [Target] -> LightCommand -> Service +light targets (On settings) = Service + { serviceDomain="light" + , serviceName= "turn_on" + , serviceData= formatLightAttributes settings + , serviceTarget=targets + } +light targets Off = Service + { serviceDomain="light" + , serviceName= "turn_off" + , serviceData=Nothing + , serviceTarget=targets + } diff --git a/src/HomeAssistant/Controller/Light/Mode.hs b/src/HomeAssistant/Controller/Light/Mode.hs index 5d5f8f9..f0c5442 100644 --- a/src/HomeAssistant/Controller/Light/Mode.hs +++ b/src/HomeAssistant/Controller/Light/Mode.hs @@ -4,7 +4,8 @@ module HomeAssistant.Controller.Light.Mode , lightingModeEvents ) where -import HomeAssistant.Controller (Presence(..), HASS) +import HomeAssistant.Controller.Effect (HASS) +import HomeAssistant.Controller.Presence (Presence (..)) import qualified AFRP import Control.Arrow (Arrow(..), (>>>)) diff --git a/src/HomeAssistant/Controller/Light/Observation.hs b/src/HomeAssistant/Controller/Light/Observation.hs new file mode 100644 index 0000000..389baa0 --- /dev/null +++ b/src/HomeAssistant/Controller/Light/Observation.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE OverloadedStrings #-} + +module HomeAssistant.Controller.Light.Observation + ( LightSnapshot(..) + , observedLight + , lightBrightnessEvent + , lightTemperatureEvent + ) where + +import AFRP (Event, hold, toEvent, (>>|)) +import Control.Arrow (arr, returnA) +import Control.Category ((>>>), (.)) +import Control.Lens ((^?)) +import Data.Aeson (Value) +import Data.Aeson.Lens (key, _Integral) +import qualified Data.Text as T +import GHC.Generics (Generic) +import Data.Serialize (Serialize) +import HomeAssistant.Controller.Entity (entityChangeEvent', entityBool) +import HomeAssistant.Controller.Effect (HASS) +import Prelude hiding ((.)) + +lightBrightnessEvent :: T.Text -> HASS (Event Value) (Event Int) +lightBrightnessEvent entityId = + entityChangeEvent' entityId + >>| arr (maybe (Left ()) Right . eventBrightness) + >>> AFRP.toEvent + where + eventBrightness v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "attributes" . key "brightness" . _Integral + +lightTemperatureEvent :: T.Text -> HASS (Event Value) (Event Int) +lightTemperatureEvent entityId = + entityChangeEvent' entityId + >>| arr (maybe (Left ()) Right . eventTemperature) + >>> AFRP.toEvent + where + eventTemperature v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "attributes" . key "color_temp_kelvin" . _Integral + +data LightSnapshot = LightSnapshot + { observedOn :: Bool + , observedBrightness :: Int + , observedTemperature :: Int + } + deriving (Show, Generic, Eq) +instance Serialize LightSnapshot + +observedLight :: T.Text -> HASS (Event Value) LightSnapshot +observedLight entityId = proc ev -> do + e <- hold False . entityBool entityId -< ev + b <- hold 0 . lightBrightnessEvent entityId -< ev + t <- hold 0 . lightTemperatureEvent entityId -< ev + returnA -< LightSnapshot e b t diff --git a/src/HomeAssistant/Controller/Presence.hs b/src/HomeAssistant/Controller/Presence.hs new file mode 100644 index 0000000..8efa9eb --- /dev/null +++ b/src/HomeAssistant/Controller/Presence.hs @@ -0,0 +1,55 @@ +module HomeAssistant.Controller.Presence + ( Presence(..) + , presence + , Motion(..) + , motion + , motionToPresence + ) where + +import AFRP (Event, hold, lMerge, waitFor, tag, edge) +import Control.Arrow (arr, (&&&)) +import Control.Category ((>>>)) +import Data.Aeson (Value) +import qualified Data.Text as T +import Data.Bool (bool) +import Data.Serialize (Serialize) +import GHC.Generics (Generic) +import Data.Time (NominalDiffTime) +import HomeAssistant.Controller.Entity (entityBool) +import HomeAssistant.Controller.Effect (HASS) + +data Presence = Occupied | Unoccupied + deriving (Show, Eq, Generic) + +instance Serialize Presence + +presence :: T.Text -> HASS (Event Value) (Event Presence) +presence entityId = entityBool entityId + >>> arr (fmap (bool Unoccupied Occupied)) + + +data Motion = MotionDetected | MotionNotDetected | MotionUnknown + deriving (Show, Eq, Generic) + + +motion :: T.Text -> HASS (Event Value) Motion +motion entityId = entityBool entityId + >>> arr (fmap (bool MotionNotDetected MotionDetected)) + >>> hold MotionUnknown + + +-- Convert a motion status into a simulated presence +-- +-- A motion tracker detects _motion_, but if you are still, it can't detect you. +-- A simple and cheap heuristic is to assume the person is a bit longer there +motionToPresence :: NominalDiffTime -> HASS Motion Presence +motionToPresence delay = (eventOccupied &&& eventUnoccupied) + >>> arr (uncurry lMerge) + >>> AFRP.hold Unoccupied + where + eventOccupied :: HASS Motion (Event Presence) + eventOccupied = arr (== MotionDetected) >>> edge >>> arr (fmap (const Occupied)) + eventUnoccupied :: HASS Motion (Event Presence) + eventUnoccupied = arr (== MotionNotDetected) >>> waitFor delay >>> arr (tag Unoccupied) + +instance Serialize Motion diff --git a/src/HomeAssistant/Controller/Scene.hs b/src/HomeAssistant/Controller/Scene.hs new file mode 100644 index 0000000..350bfd7 --- /dev/null +++ b/src/HomeAssistant/Controller/Scene.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HomeAssistant.Controller.Scene + ( activateScene + , activateSceneWith + ) where + +import Data.Aeson (Value) +import qualified Data.Text as T +import HomeAssistant.Controller.Service (Service (..), Target (..)) + +activateScene :: T.Text -> Service +activateScene sceneId = activateSceneWith sceneId Nothing + +activateSceneWith :: T.Text -> Maybe Value -> Service +activateSceneWith sceneId d = Service + { serviceDomain="scene" + , serviceName= "turn_on" + , serviceTarget= [EntityId sceneId] + , serviceData = d + } diff --git a/src/HomeAssistant/Controller/Service.hs b/src/HomeAssistant/Controller/Service.hs new file mode 100644 index 0000000..92ce8f9 --- /dev/null +++ b/src/HomeAssistant/Controller/Service.hs @@ -0,0 +1,18 @@ +module HomeAssistant.Controller.Service + ( Service(..) + , Target(..) + ) where + +import Data.Aeson (Value) +import qualified Data.Text as T + +data Target = EntityId !T.Text | AreaId !T.Text + deriving (Show,Eq,Ord) + +data Service = Service + { serviceDomain :: T.Text + , serviceName :: T.Text + , serviceData :: Maybe Value + , serviceTarget :: [Target] + } + deriving (Show, Eq) diff --git a/src/HomeAssistant/Controller/Switch.hs b/src/HomeAssistant/Controller/Switch.hs new file mode 100644 index 0000000..090b1f7 --- /dev/null +++ b/src/HomeAssistant/Controller/Switch.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HomeAssistant.Controller.Switch (switchService) where + +import Data.Bool (bool) +import HomeAssistant.Controller.Service (Service (..), Target) + +switchService :: [Target] -> Bool -> Service +switchService targets b = Service + { serviceDomain="switch" + , serviceName= bool "turn_off" "turn_on" b + , serviceData=Nothing + , serviceTarget=targets + }