Split Controller.hs into vertical submodules behind umbrella re-export
This commit is contained in:
@@ -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
|
||||
|
||||
+12
-337
@@ -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
|
||||
|
||||
@@ -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
|
||||
@@ -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
|
||||
@@ -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
|
||||
@@ -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
|
||||
@@ -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
|
||||
}
|
||||
@@ -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(..), (>>>))
|
||||
|
||||
|
||||
@@ -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
|
||||
@@ -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
|
||||
@@ -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
|
||||
}
|
||||
@@ -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)
|
||||
@@ -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
|
||||
}
|
||||
Reference in New Issue
Block a user