122 lines
4.3 KiB
Haskell
122 lines
4.3 KiB
Haskell
{-# LANGUAGE Arrows #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
module HomeAssistant.Controller.Bedroom where
|
|
|
|
import HomeAssistant.Controller
|
|
import qualified Data.Text as T
|
|
import AFRP (Event (..), (>>|), toEvent, lMerge)
|
|
import Data.Aeson (Value, object, (.=))
|
|
import Control.Arrow ((>>>), returnA, arr, Arrow (..))
|
|
import Control.Lens ((^?), to, traversed)
|
|
import Data.Aeson.Lens (key, _String)
|
|
import Data.Bool (bool)
|
|
|
|
|
|
|
|
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= []
|
|
}
|
|
|
|
|
|
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 -< ()
|
|
|
|
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 "data" . key "new_state" . key "attributes" . key "event_type" . _String . to toIkeaQuickButton . traversed
|
|
|
|
|
|
data BedroomControls
|
|
= Masse (IkeaButton IkeaGesture)
|
|
| Enishen (IkeaButton IkeaGesture)
|
|
deriving Show
|
|
|
|
|
|
bedroomButton :: HASS (Event Value) (Event BedroomControls)
|
|
bedroomButton = (masseButton &&& enishenButton) >>> arr (uncurry lMerge)
|
|
where
|
|
masseButton = fmap Masse <$> ikeaQuickButton "event.bedroom_quick_remote_masse_action"
|
|
enishenButton = fmap Enishen <$> ikeaQuickButton "event.bedroom_quick_jemina_action"
|
|
|
|
bedroomButtonController :: HASS (Event Value) ()
|
|
bedroomButtonController = proc x -> do
|
|
ev <- bedroomButton >>> traceEvent -< x
|
|
case ev of
|
|
Event (Masse (OnButton ShortRelease)) -> callService (activateScene "scene.makuuhuone_masse") -< () -- this should be on release
|
|
Event (Masse (OnButton DoubleClick)) -> callService (activateScene "scene.makuuhuone_keski") -< ()
|
|
Event (Masse (OnButton LongClick)) -> callService (activateScene "scene.makuuhuone_kirkas") -< ()
|
|
Event (Enishen (OnButton ShortRelease)) -> callService (activateScene "scene.makuuhuone_jemina") -< ()
|
|
Event (Enishen (OnButton DoubleClick)) -> callService (activateScene "scene.makuuhuone_keski") -< ()
|
|
Event (Enishen (OnButton LongClick)) -> callService (activateScene "scene.makuuhuone_kirkas") -< ()
|
|
_ -> returnA -< ()
|
|
|
|
|
|
|
|
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 -< x
|
|
case st of
|
|
Event Open -> callService (switch [entity] True) -< ()
|
|
Event Closed -> callService (switch [entity] False) -< ()
|
|
_ -> returnA -< ()
|
|
where
|
|
entity = "bedroom_drawer_light_masse"
|