154 lines
5.6 KiB
Haskell
154 lines
5.6 KiB
Haskell
{-# LANGUAGE Arrows #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
module HomeAssistant.Controller.Bedroom where
|
|
|
|
import HomeAssistant.Controller
|
|
import qualified Data.Text as T
|
|
import AFRP (Event (..), lMerge, duration, edge)
|
|
import Data.Aeson (Value, object, (.=))
|
|
import Control.Arrow ((>>>), returnA, arr, Arrow (..))
|
|
import Data.Bool (bool)
|
|
import Data.Time (NominalDiffTime)
|
|
import qualified AFRP
|
|
|
|
|
|
|
|
bedroomLights :: [Target]
|
|
bedroomLights = map EntityId ["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" .= [l | EntityId l <- bedroomLights]
|
|
]
|
|
, serviceTarget= []
|
|
}
|
|
|
|
data PresenceLights
|
|
= LightsOn -- Restore lights
|
|
| LightsOff -- Timer expired, darkness
|
|
| LightsSleep -- No presence detected, sleep mode
|
|
deriving Show
|
|
|
|
-- Bedroom presence
|
|
bedroomPresence :: HASS (Event Value) (Event Presence)
|
|
bedroomPresence = presence "binary_sensor.presence_sensor_bedroom_occupancy"
|
|
|
|
presenceLightEvents :: HASS (Event Value) (Event PresenceLights)
|
|
presenceLightEvents =
|
|
bedroomPresence >>> AFRP.hold Unoccupied
|
|
>>> arr lightWanted
|
|
>>> (sleepEvent &&& offEvent &&& onEvent)
|
|
>>> arr (\(s,(o,n)) -> s `AFRP.lMerge` o `AFRP.lMerge` n)
|
|
where
|
|
lightWanted o = o == Occupied
|
|
sleepEvent = arr not >>> AFRP.edge >>> arr (AFRP.tag LightsSleep)
|
|
onEvent = AFRP.edge >>> arr (AFRP.tag LightsOn)
|
|
offEvent = arr not >>> AFRP.waitFor 300 >>> arr (AFRP.tag LightsOff)
|
|
|
|
bedroomPresenceController :: HASS (Event Value) ()
|
|
bedroomPresenceController = proc x -> do
|
|
p <- presenceLightEvents >>> traceEvent -< x
|
|
case p of
|
|
Event LightsOff -> do
|
|
callService (light bedroomLights Off) -< ()
|
|
Event LightsOn -> do
|
|
callService (activateSceneWith "scene.makuuhuone_lights_snapshot" transition) -< ()
|
|
Event LightsSleep -> do
|
|
callService createBedroomScene -< ()
|
|
callService (activateSceneWith "scene.makuuhuone_lepotila" transition) -< ()
|
|
_ -> returnA -< ()
|
|
where
|
|
transition = Just $ object ["transition" .= (1:: Int)]
|
|
|
|
|
|
data BedroomControls
|
|
= Masse (IkeaButton IkeaGesture)
|
|
| Enishen (IkeaButton IkeaGesture)
|
|
| Central IkeaController
|
|
deriving Show
|
|
|
|
|
|
bedroomButton :: HASS (Event Value) (Event BedroomControls)
|
|
bedroomButton = (masseButton &&& enishenButton &&& centralButton)
|
|
>>> arr (\(a,(b,c)) -> a `lMerge` b `lMerge` c)
|
|
where
|
|
masseButton = fmap Masse <$> ikeaQuickButton "event.bedroom_quick_remote_masse_action"
|
|
enishenButton = fmap Enishen <$> ikeaQuickButton "event.bedroom_quick_jemina_action"
|
|
centralButton = fmap Central <$> ikeaBoxRemote "event.bedroom_remote_action"
|
|
|
|
bedroomButtonController :: HASS (Event Value) ()
|
|
bedroomButtonController = proc x -> do
|
|
ev <- bedroomButton >>> traceEvent -< x
|
|
-- Any event will cause the sleep mode to be turned off
|
|
case ev of
|
|
Event (Masse (OnButton ShortRelease)) -> do
|
|
callService (activateSceneWith "scene.makuuhuone_masse" transition) -< ()
|
|
Event (Masse (OnButton DoubleClick)) -> do
|
|
callService (activateSceneWith "scene.makuuhuone_keski" transition) -< ()
|
|
Event (Masse (OnButton LongClick)) -> do
|
|
callService (activateSceneWith "scene.makuuhuone_kirkas" transition) -< ()
|
|
Event (Masse (OffButton _)) -> do
|
|
callService (light [AreaId "makuuhuone"] Off) -< ()
|
|
Event (Enishen (OnButton ShortRelease)) -> do
|
|
callService (activateSceneWith "scene.makuuhuone_jemina" transition) -< ()
|
|
Event (Enishen (OnButton DoubleClick)) -> do
|
|
callService (activateSceneWith "scene.makuuhuone_keski" transition) -< ()
|
|
Event (Enishen (OnButton LongClick)) -> do
|
|
callService (activateSceneWith "scene.makuuhuone_kirkas" transition) -< ()
|
|
Event (Enishen (OffButton _)) -> do
|
|
callService (light [AreaId "makuuhuone"] Off) -< ()
|
|
_ -> returnA -< ()
|
|
where
|
|
transition = Just $ object ["transition" .= (1 :: Int)]
|
|
|
|
|
|
|
|
drawer :: HASS (Event Value) (Event DoorState)
|
|
drawer = entityBool "binary_sensor.bedroom_nightstand_drawer_sensor_masse_contact"
|
|
>>> arr (fmap (bool Closed Open))
|
|
|
|
bedroomDrawerController :: HASS (Event Value) ()
|
|
bedroomDrawerController = proc x -> do
|
|
st <- drawer >>> traceEvent -< x
|
|
case st of
|
|
Event Open -> callService (switch [entity] True) -< ()
|
|
Event Closed -> callService (switch [entity] False) -< ()
|
|
_ -> returnA -< ()
|
|
where
|
|
entity = EntityId "switch.bedroom_drawer_light_masse"
|
|
|
|
door :: HASS (Event Value) (Event DoorState)
|
|
door = entityBool "binary_sensor.makuuhuone_ovi_contact"
|
|
>>> arr (fmap (bool Closed Open))
|
|
|
|
waitFor :: NominalDiffTime -> HASS a (Event ())
|
|
waitFor n = duration >>> arr (> n) >>> edge
|
|
|
|
|
|
delayedDoor :: HASS (Event Value) (Event DoorState)
|
|
delayedDoor = door
|
|
>>> AFRP.debounce 15
|
|
>>> AFRP.hold Open
|
|
>>> AFRP.changes
|
|
|
|
humidifierController :: HASS (Event Value) ()
|
|
humidifierController = proc x -> do
|
|
st <- delayedDoor -< x
|
|
case st of
|
|
-- Turn the humidifier on when the door is closed
|
|
-- the humidifier is low-powered, no point in losing all the humidity
|
|
Event Open -> callService (humidifier False) -< ()
|
|
Event Closed -> callService (humidifier True) -< ()
|
|
_ -> returnA -< ()
|
|
where
|
|
humidifier state = Service
|
|
{ serviceDomain="humidifier"
|
|
, serviceName= bool "turn_off" "turn_on" state
|
|
, serviceData= Nothing
|
|
, serviceTarget= [EntityId "humidifier.makuuhuone_ilmankostutin"]
|
|
}
|