Split Controller.hs into vertical submodules behind umbrella re-export
This commit is contained in:
@@ -62,12 +62,22 @@ library
|
|||||||
exposed-modules: AFRP
|
exposed-modules: AFRP
|
||||||
, HomeAssistant.Controller
|
, HomeAssistant.Controller
|
||||||
, HomeAssistant.Controller.Bedroom
|
, HomeAssistant.Controller.Bedroom
|
||||||
, HomeAssistant.Controller.Hallway
|
|
||||||
, HomeAssistant.Controller.Kitchen
|
|
||||||
, HomeAssistant.Controller.Light.Mode
|
|
||||||
, HomeAssistant.Controller.Children
|
, 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.Livingroom
|
||||||
|
, HomeAssistant.Controller.Presence
|
||||||
, HomeAssistant.Controller.Ruuvi
|
, HomeAssistant.Controller.Ruuvi
|
||||||
|
, HomeAssistant.Controller.Scene
|
||||||
|
, HomeAssistant.Controller.Service
|
||||||
|
, HomeAssistant.Controller.Switch
|
||||||
, HomeAssistant.Runtime
|
, HomeAssistant.Runtime
|
||||||
, HomeAssistant.Runtime.Bus
|
, HomeAssistant.Runtime.Bus
|
||||||
, HomeAssistant.Runtime.Connection
|
, HomeAssistant.Runtime.Connection
|
||||||
|
|||||||
+12
-337
@@ -1,340 +1,15 @@
|
|||||||
{-# LANGUAGE Arrows #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
{-# LANGUAGE GADTs #-}
|
|
||||||
{-# LANGUAGE MonadComprehensions #-}
|
|
||||||
|
|
||||||
module HomeAssistant.Controller
|
module HomeAssistant.Controller
|
||||||
( Service(..)
|
( module Export
|
||||||
, 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
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import AFRP (Mealy (..), eff, Event(..), events, filterA, (>>|), toEvent, Request, hold, lMerge, waitFor, tag, edge)
|
import HomeAssistant.Controller.Service as Export
|
||||||
import Control.Arrow (Arrow(..), returnA)
|
import HomeAssistant.Controller.Effect as Export
|
||||||
import Control.Category ((>>>), (.))
|
import HomeAssistant.Controller.Entity as Export
|
||||||
import Prelude hiding ((.))
|
import HomeAssistant.Controller.Presence as Export
|
||||||
import Data.Aeson (Value, object, (.=))
|
import HomeAssistant.Controller.Door as Export
|
||||||
import qualified Data.Text as T
|
import HomeAssistant.Controller.Switch as Export
|
||||||
import qualified Data.Set as S
|
import HomeAssistant.Controller.Scene as Export
|
||||||
import Control.Lens (has, only, (^?), to, traversed)
|
import HomeAssistant.Controller.Ikea as Export
|
||||||
import Data.Aeson.Lens (key, _String, _Integral)
|
import HomeAssistant.Controller.Light.Command as Export
|
||||||
import qualified Data.Text.Lens as TL
|
import HomeAssistant.Controller.Light.Observation as Export
|
||||||
import Data.Bool (bool)
|
import HomeAssistant.Controller.Light.Mode as Export
|
||||||
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
|
|
||||||
}
|
|
||||||
|
|||||||
@@ -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
|
, lightingModeEvents
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import HomeAssistant.Controller (Presence(..), HASS)
|
import HomeAssistant.Controller.Effect (HASS)
|
||||||
|
import HomeAssistant.Controller.Presence (Presence (..))
|
||||||
import qualified AFRP
|
import qualified AFRP
|
||||||
import Control.Arrow (Arrow(..), (>>>))
|
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