268 lines
8.1 KiB
Haskell
268 lines
8.1 KiB
Haskell
{-# LANGUAGE Arrows #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
|
|
module HomeAssistant.Controller
|
|
( Service(..)
|
|
, HASSEff(..)
|
|
, HASS
|
|
, callService
|
|
, callServiceDyn
|
|
, entityChangeEvent
|
|
, entityChangeEvent'
|
|
, entityRead
|
|
, entityRead'
|
|
, entityBool
|
|
, entityBool'
|
|
, DoorState(..)
|
|
, light
|
|
, Presence(..)
|
|
, presence
|
|
, motion
|
|
, motionToPresence
|
|
, debug
|
|
, traceEvent
|
|
, traceValue
|
|
, switch
|
|
, Target(..)
|
|
, brightness
|
|
, Light(..)
|
|
, ikeaQuickButton
|
|
, IkeaButton(..)
|
|
, IkeaGesture(..)
|
|
, activateScene
|
|
, ikeaBoxRemote
|
|
, IkeaController(..)
|
|
) where
|
|
|
|
import AFRP (Mealy (..), eff, Event(..), events, filterA, (>>|), toEvent, Request, hold, lMerge, waitFor, tag, edge)
|
|
import Control.Arrow (Arrow(..), returnA)
|
|
import Control.Category ((>>>))
|
|
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)
|
|
|
|
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 ()
|
|
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)
|
|
|
|
callServiceDyn :: (a -> Service) -> HASS a ()
|
|
callServiceDyn mkService = eff (\req a -> CallService 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 Light
|
|
= Off
|
|
| On { brightnessPercentage :: Maybe Double }
|
|
|
|
-- Turn off lights when door is closed
|
|
light :: [Target] -> Light -> Service
|
|
light targets (On {brightnessPercentage}) = Service
|
|
{ serviceDomain="light"
|
|
, serviceName= "turn_on"
|
|
, serviceData=fmap (\pct -> object ["brightness_pct" .= pct]) brightnessPercentage
|
|
, serviceTarget=targets
|
|
}
|
|
light targets Off = Service
|
|
{ serviceDomain="light"
|
|
, serviceName= "turn_off"
|
|
, serviceData=Nothing
|
|
, serviceTarget=targets
|
|
}
|
|
|
|
-- Name conflict with AFRP
|
|
switch :: [Target] -> Bool -> Service
|
|
switch 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
|
|
|
|
brightness :: T.Text -> HASS (Event Value) (Event Int)
|
|
brightness 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
|
|
|
|
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 IkeaController
|
|
= ControllerOn -- Short press on
|
|
| ControllerOff -- Short press off
|
|
| ControllerBrighnessUp -- Turn brightness up
|
|
| ControllerBrighnessDown -- Turn brighness down
|
|
| ControllerArrowRight -- Turn brighness down
|
|
| ControllerArrowLeft -- Turn brighness down
|
|
| ControllerBrighnessStop
|
|
deriving Show
|
|
|
|
toIkeaController :: T.Text -> Maybe IkeaController
|
|
toIkeaController = \case
|
|
"on" -> Just ControllerOn
|
|
"off" -> Just ControllerOff
|
|
"brightness_move_up" -> Just ControllerBrighnessUp
|
|
"brightness_move_down" -> Just ControllerBrighnessDown
|
|
"brightness_stop" -> Just ControllerBrighnessStop
|
|
"arrow_right_click" -> Just ControllerArrowRight
|
|
"arrow_left_click" -> Just ControllerArrowLeft
|
|
_ -> Nothing
|
|
|
|
ikeaBoxRemote :: T.Text -> HASS (Event Value) (Event IkeaController)
|
|
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 = Service
|
|
{ serviceDomain="scene"
|
|
, serviceName= "turn_on"
|
|
, serviceTarget= [EntityId sceneId]
|
|
, serviceData = Nothing
|
|
}
|