121 lines
3.6 KiB
Haskell
121 lines
3.6 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
|
|
) where
|
|
|
|
import AFRP (Mealy, eff, Event(..), hold, events, changes, filterA, (>>|), toEvent)
|
|
import Control.Arrow (Arrow(..), returnA)
|
|
import Control.Category ((>>>))
|
|
import Data.Aeson (Value)
|
|
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
|
|
|
|
data HASSEff a where
|
|
CallService :: Service -> HASSEff ()
|
|
Pure :: a -> HASSEff a
|
|
|
|
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)
|
|
|
|
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 :: Bool -> Service
|
|
light b = Service
|
|
{ serviceDomain="light"
|
|
, serviceName= bool "turn_off" "turn_on" b
|
|
, serviceData=Nothing
|
|
, serviceTarget="light.bedroom_masse"
|
|
}
|
|
|
|
lightController :: HASS (Event Value) (Event DoorState)
|
|
lightController = proc ev -> do
|
|
doorState <- door -< ev
|
|
case doorState of
|
|
Event Open -> callService (light False) -< ()
|
|
Event Closed -> callService (light 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
|