154 lines
4.4 KiB
Haskell
154 lines
4.4 KiB
Haskell
{-# LANGUAGE Arrows #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
|
|
module HomeAssistant.Controller
|
|
( Service(..)
|
|
, HASSEff(..)
|
|
, HASS
|
|
, callService
|
|
, entityChangeEvent
|
|
, entityChangeEvent'
|
|
, entityRead
|
|
, entityRead'
|
|
, entityBool
|
|
, entityBool'
|
|
, DoorState(..)
|
|
, light
|
|
, Presence(..)
|
|
, presence
|
|
, debug
|
|
, traceEvent
|
|
, traceValue
|
|
, switch
|
|
, Target(..)
|
|
, brightness
|
|
, Light(..)
|
|
) where
|
|
|
|
import AFRP (Mealy (..), eff, Event(..), events, filterA, (>>|), toEvent, Request)
|
|
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)
|
|
import Data.Aeson.Lens (key, _String, _Integral)
|
|
import qualified Data.Text.Lens as TL
|
|
import Data.Bool (bool)
|
|
|
|
data Target = EntityId !T.Text | AreaId !T.Text
|
|
deriving (Show,Eq)
|
|
|
|
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)
|
|
|
|
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 = Mealy mempty $ \nt req -> \case
|
|
Event a -> nt (Trace req a) >>= \() -> pure (Event a, traceEvent)
|
|
Tick -> pure (Tick, traceEvent)
|
|
|
|
traceValue :: Show a => HASS a a
|
|
traceValue = proc x -> do
|
|
eff Trace -< x
|
|
returnA -< x
|
|
|
|
data DoorState = Open | Closed
|
|
deriving (Show, Eq)
|
|
|
|
data Presence = Occupied | Unoccupied
|
|
deriving (Show, Eq)
|
|
|
|
presence :: T.Text -> HASS (Event Value) (Event Presence)
|
|
presence entityId =entityBool entityId
|
|
>>> arr (fmap (bool Unoccupied Occupied))
|
|
|
|
|
|
|
|
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
|