164 lines
5.0 KiB
Haskell
164 lines
5.0 KiB
Haskell
{-# LANGUAGE Arrows #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
|
|
module HomeAssistant.Controller
|
|
( Service(..)
|
|
, HASSEff(..)
|
|
, HASS
|
|
, callService
|
|
, entityChangeEvent
|
|
, entityChangeEvent'
|
|
, entityRead
|
|
, entityRead'
|
|
, entityBool
|
|
, entityBool'
|
|
, Ruuvi(..)
|
|
, ruuvi
|
|
, ruuviTemperatures
|
|
, ruuviPressures
|
|
, DoorState(..)
|
|
, door
|
|
, light
|
|
, lightController
|
|
, bedroomPresenceController
|
|
) where
|
|
|
|
import AFRP (Mealy, eff, Event(..), hold, events, changes, filterA, (>>|), toEvent)
|
|
import Control.Arrow (Arrow(..), returnA)
|
|
import Control.Category ((>>>))
|
|
import Data.Aeson (Value, object, (.=))
|
|
import qualified Data.Text as T
|
|
import Control.Lens (has, only, (^?), to)
|
|
import Data.Aeson.Lens (key, _String)
|
|
import qualified Data.Text.Lens as TL
|
|
import Data.Bool (bool)
|
|
|
|
data Service = Service
|
|
{ serviceDomain :: T.Text
|
|
, serviceName :: T.Text
|
|
, serviceData :: Maybe Value
|
|
, serviceTarget :: [T.Text]
|
|
}
|
|
deriving (Show, Eq)
|
|
|
|
data HASSEff a where
|
|
CallService :: Service -> HASSEff ()
|
|
|
|
type HASS a b = Mealy HASSEff a b
|
|
|
|
callService :: Service -> HASS a ()
|
|
callService service = eff (\_ -> CallService service)
|
|
|
|
ruuviTemperatures :: Mealy eff (Event Value) Double
|
|
ruuviTemperatures = entityRead @Double "sensor.ruuvitag_b168_temperature" >>> hold 0
|
|
|
|
ruuviPressures :: Mealy eff (Event Value) Double
|
|
ruuviPressures = entityRead "sensor.ruuvitag_b168_pressure" >>> hold 0
|
|
|
|
data Ruuvi = Ruuvi { ruuviTemperature :: Double, ruuviPressure :: Double }
|
|
deriving (Show, Eq)
|
|
|
|
ruuvi :: Mealy eff (Event Value) (Event Ruuvi)
|
|
ruuvi = (Ruuvi <$> ruuviTemperatures <*> ruuviPressures) >>> changes
|
|
|
|
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))
|
|
|
|
bedroomLights :: [T.Text]
|
|
bedroomLights = ["light.bedroom_masse","light.bedroom_jemina","light.bedroom_ceiling","light.bedroom_led_switch"]
|
|
|
|
createBedroomScene :: Service
|
|
createBedroomScene = Service
|
|
{ serviceDomain="scene"
|
|
, serviceName= "create"
|
|
, serviceData= Just $ object
|
|
[ "scene_id" .= ("makuuhuone_lights_snapshot" :: T.Text)
|
|
, "snapshot_entities" .= bedroomLights
|
|
]
|
|
, serviceTarget= [] -- bedroomLights
|
|
}
|
|
|
|
|
|
activateScene :: T.Text -> Service
|
|
activateScene sceneId = Service
|
|
{ serviceDomain="scene"
|
|
, serviceName= "turn_on"
|
|
, serviceTarget= [sceneId]
|
|
, serviceData = Nothing
|
|
}
|
|
|
|
-- Bedroom presence
|
|
bedroomPresence :: HASS (Event Value) (Event Presence)
|
|
bedroomPresence = presence "binary_sensor.presence_sensor_bedroom_occupancy"
|
|
|
|
bedroomPresenceController :: HASS (Event Value) ()
|
|
bedroomPresenceController = proc x -> do
|
|
p <- bedroomPresence -< x
|
|
case p of
|
|
Event Unoccupied -> callService createBedroomScene >>> callService (light bedroomLights False) -< ()
|
|
Event Occupied -> callService (activateScene "makuuhuone_lights_snapshot") -< ()
|
|
_ -> returnA -< ()
|
|
|
|
|
|
door :: HASS (Event Value) (Event DoorState)
|
|
door = entityBool "binary_sensor.makuuhuone_ovi_contact"
|
|
>>> arr (fmap (bool Closed Open))
|
|
>>> hold Open
|
|
>>> changes
|
|
|
|
-- Turn off lights when door is closed
|
|
light :: [T.Text] -> Bool -> Service
|
|
light entityIds b = Service
|
|
{ serviceDomain="light"
|
|
, serviceName= bool "turn_off" "turn_on" b
|
|
, serviceData=Nothing
|
|
, serviceTarget=entityIds
|
|
}
|
|
|
|
lightController :: HASS (Event Value) (Event DoorState)
|
|
lightController = proc ev -> do
|
|
doorState <- door -< ev
|
|
case doorState of
|
|
Event Open -> callService (light ["light.bedroom_masse"] False) -< ()
|
|
Event Closed -> callService (light ["light.bedroom_masse"] True) -< ()
|
|
_ -> returnA -< ()
|
|
returnA -< doorState
|
|
|
|
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 = events >>| filterA isEntity
|
|
where
|
|
isEntity :: Value -> Bool
|
|
isEntity = has (key "event" . key "data" . 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 "data" . key "new_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 "data" . key "new_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
|