diff --git a/src/HomeAssistant/Controller.hs b/src/HomeAssistant/Controller.hs index bccdb02..6bbdc4c 100644 --- a/src/HomeAssistant/Controller.hs +++ b/src/HomeAssistant/Controller.hs @@ -28,6 +28,10 @@ module HomeAssistant.Controller , Target(..) , brightness , Light(..) + , ikeaQuickButton + , IkeaButton(..) + , IkeaGesture(..) + , activateScene ) where import AFRP (Mealy (..), eff, Event(..), events, filterA, (>>|), toEvent, Request, hold, lMerge, waitFor, tag, edge) @@ -36,7 +40,7 @@ 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 Control.Lens (has, only, (^?), to, traversed) import Data.Aeson.Lens (key, _String, _Integral) import qualified Data.Text.Lens as TL import Data.Bool (bool) @@ -191,3 +195,43 @@ brightness entityId = >>> AFRP.toEvent where eventBrightness v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "attributes" . key "brightness" . _Integral + +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 "variables" . key "trigger" . key "to_state" . key "attributes" . key "event_type" . _String . to toIkeaQuickButton . traversed + +activateScene :: T.Text -> Service +activateScene sceneId = Service + { serviceDomain="scene" + , serviceName= "turn_on" + , serviceTarget= [EntityId sceneId] + , serviceData = Nothing + } diff --git a/src/HomeAssistant/Controller/Bedroom.hs b/src/HomeAssistant/Controller/Bedroom.hs index fd80c0b..0a78f17 100644 --- a/src/HomeAssistant/Controller/Bedroom.hs +++ b/src/HomeAssistant/Controller/Bedroom.hs @@ -4,11 +4,9 @@ module HomeAssistant.Controller.Bedroom where import HomeAssistant.Controller import qualified Data.Text as T -import AFRP (Event (..), (>>|), toEvent, lMerge, duration, edge) +import AFRP (Event (..), lMerge, duration, edge) 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) import Data.Time (NominalDiffTime) import qualified AFRP @@ -30,13 +28,6 @@ createBedroomScene = Service } -activateScene :: T.Text -> Service -activateScene sceneId = Service - { serviceDomain="scene" - , serviceName= "turn_on" - , serviceTarget= [EntityId sceneId] - , serviceData = Nothing - } -- Bedroom presence bedroomPresence :: HASS (Event Value) (Event Presence) @@ -50,36 +41,6 @@ bedroomPresenceController = proc x -> do Event Occupied -> callService (activateScene "scene.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 "variables" . key "trigger" . key "to_state" . key "attributes" . key "event_type" . _String . to toIkeaQuickButton . traversed data BedroomControls diff --git a/src/HomeAssistant/Controller/Children.hs b/src/HomeAssistant/Controller/Children.hs index 9be9c63..9e55956 100644 --- a/src/HomeAssistant/Controller/Children.hs +++ b/src/HomeAssistant/Controller/Children.hs @@ -1,13 +1,14 @@ {-# LANGUAGE Arrows #-} {-# LANGUAGE OverloadedStrings #-} module HomeAssistant.Controller.Children where -import HomeAssistant.Controller (HASS, callService, Target (AreaId), light, Light(..)) -import AFRP (Event) +import HomeAssistant.Controller (HASS, callService, Target (AreaId), light, Light(..), ikeaQuickButton, IkeaGesture (..), IkeaButton (..), traceEvent, activateScene) +import AFRP (Event (..)) import qualified AFRP -import Control.Arrow (Arrow(..), (>>>)) +import Control.Arrow (Arrow(..), (>>>), returnA) import Data.Time (Day, TimeOfDay (..), localDay, LocalTime (..)) import Data.Time.Calendar.OrdinalDate (WeekOfYear, mondayStartWeek) import Data.Functor.Contravariant (Predicate (..), (>$<)) +import Data.Aeson (Value) -- Let's see building some reasonable interface for utctime dow :: Day -> (WeekOfYear, Int) @@ -80,3 +81,17 @@ lightsOn = foldMap atTime timersOn lightsOff :: HASS a () lightsOff = foldMap atTime timersOff >>> AFRP.onEvent (callService (light [AreaId "lasten_makuuhuone"] Off)) + + +bedroomButton :: HASS (Event Value) (Event (IkeaButton IkeaGesture)) +bedroomButton = ikeaQuickButton "event.children_quick_remote_action" + +childrenBedroomButtonController :: HASS (Event Value) () +childrenBedroomButtonController = proc x -> do + ev <- bedroomButton >>> traceEvent -< x + case ev of + Event (OnButton ShortRelease) -> callService (activateScene "scene.lasten_nukkuvalmistelu") -< () + Event (OnButton DoubleClick) -> callService (activateScene "scene.lasten_luku") -< () + Event (OnButton LongClick) -> callService (activateScene "scene.lasten_kirkas") -< () + Event (OffButton _) -> callService (light [AreaId "lasten_makuuhuone"] Off) -< () + _ -> returnA -< () diff --git a/src/HomeAssistant/Runtime.hs b/src/HomeAssistant/Runtime.hs index 174f0b2..3737b33 100644 --- a/src/HomeAssistant/Runtime.hs +++ b/src/HomeAssistant/Runtime.hs @@ -29,7 +29,7 @@ import Data.UUID (UUID, toText) import qualified Data.UUID.V4 as UUID.V4 import Katip (runKatipT, logF, sl, Severity (..), ls, Namespace (Namespace), runKatipContextT) import Control.Monad.IO.Class (liftIO, MonadIO) -import HomeAssistant.Controller.Children (schoolLightController) +import HomeAssistant.Controller.Children (schoolLightController, childrenBedroomButtonController) import Data.Maybe (fromMaybe) import qualified System.Metrics import qualified HomeAssistant.Runtime.Metrics @@ -50,25 +50,26 @@ step path trace st a = do let req = Request now tz trace stepAutoSerializing path st req a -data Controller = forall b. Controller T.Text (HASS (Event Value) b) Bool +data Controller = forall b. Controller Bool T.Text (HASS (Event Value) b) controllers :: [Controller] controllers = - [ Controller "bedroom-presence" bedroomPresenceController True - , Controller "bedroom-button" bedroomButtonController True - , Controller "bedroom-drawer" bedroomDrawerController True - , Controller "bedroom-humidifier" humidifierController True - , Controller "school-light-controller" schoolLightController True - , Controller "kitchen-motion-controller" kitchenMotionController True - , Controller "livingroom-presence" livingroomPresenceController True - , Controller "hallway-motion-controller" hallwayLightsController True + [ Controller True "bedroom-presence" bedroomPresenceController + , Controller True "bedroom-button" bedroomButtonController + , Controller True "bedroom-drawer" bedroomDrawerController + , Controller True "bedroom-humidifier" humidifierController + , Controller True "school-light-controller" schoolLightController + , Controller True "kitchen-motion-controller" kitchenMotionController + , Controller True "livingroom-presence" livingroomPresenceController + , Controller True "hallway-motion-controller" hallwayLightsController + , Controller True "children-button" childrenBedroomButtonController ] -- | Steps the machine for every inbound message; service calls go to the -- bus. A restart re-dups the inbound channel and starts from the machine's -- initial state; messages broadcast during the restart window are lost. runController :: MonadIO m => FilePath -> Bus -> Controller -> m Void -runController rootDir bus (Controller name machine _enabled) = liftIO $ do +runController rootDir bus (Controller _enabled name machine ) = liftIO $ do inbound <- atomically (dupTChan (busInbound bus)) let ns = Namespace [name] let workerDefinition = runMealy machine (runKatipContextT (busLogEnv bus) () ns . channelHassEval bus) @@ -108,14 +109,14 @@ defaultMain = withSocketsDo $ do rrdtool <- fromMaybe "rrdtool" <$> lookupEnv "HA_RRDTOOL" metricsPort <- lookupPort writerLimiter <- slidingWindowLimiter rateLimitMetrics 10 20 - let active = [c | c@(Controller _ _ True) <- controllers] - ents = foldMap (\(Controller _ m _) -> entities m) active + let active = [c | c@(Controller True _ _) <- controllers] + ents = foldMap (\(Controller _ _ m) -> entities m) active workers = [ ("reader", readerAction host 8123 token ents bus) , ("writer", writerAction writerLimiter bus) , ("metrics", HomeAssistant.Runtime.Metrics.metricsAction store rrdPath rrdtool) , ("metrics-http", HomeAssistant.Runtime.Graphing.graphAction rrdPath rrdtool metricsPort) - ] ++ [ (name, runController rootPath bus c) | c@(Controller name _ True) <- controllers ] + ] ++ [ (name, runController rootPath bus c) | c@(Controller True name _) <- active ] runKatipContextT (busLogEnv bus) () mempty $ mapConcurrently_ (uncurry supervised) workers