diff --git a/home-assistant-controller.cabal b/home-assistant-controller.cabal index 2f75c1c..fdb0fb4 100644 --- a/home-assistant-controller.cabal +++ b/home-assistant-controller.cabal @@ -62,6 +62,7 @@ library exposed-modules: AFRP , HomeAssistant.Controller , HomeAssistant.Controller.Bedroom + , HomeAssistant.Controller.Children , HomeAssistant.Controller.Ruuvi , HomeAssistant.Runtime , HomeAssistant.Runtime.Bus @@ -130,11 +131,13 @@ test-suite home-assistant-controller-test -- Modules included in this executable, other than Main. other-modules: AFRPSpec + , BackoffProp + , BedroomSpec , BusSpec , ConnectionSpec , RuntimeSpec , SupervisorSpec - , BackoffProp + , Support -- LANGUAGE extensions used by modules in this package. -- other-extensions: diff --git a/src/HomeAssistant/Controller/Children.hs b/src/HomeAssistant/Controller/Children.hs new file mode 100644 index 0000000..5141cd7 --- /dev/null +++ b/src/HomeAssistant/Controller/Children.hs @@ -0,0 +1,14 @@ +module HomeAssistant.Controller.Children where +import HomeAssistant.Controller (HASS) +import AFRP (Event) +import Data.Aeson (Value) +import Control.Arrow (Arrow(..)) + +-- I don't have any proper presence sensors in their bedroom +-- and they are notoriously bad at changing clothes in complete darkness +-- So I have set up an automation that attempts to turn on the lights sometime +-- before they leave for school and turns them off a bit later +-- +-- I don't have enough primitives for this yet, leaving as a placeholder +schoolLightController :: HASS (Event Value) () +schoolLightController = arr (const ()) diff --git a/src/HomeAssistant/Runtime.hs b/src/HomeAssistant/Runtime.hs index e762515..f6edeb4 100644 --- a/src/HomeAssistant/Runtime.hs +++ b/src/HomeAssistant/Runtime.hs @@ -46,8 +46,8 @@ controllers = [ Controller "bedroom-presence" bedroomPresenceController False , Controller "bedroom-button" bedroomButtonController False -- This works but leaving for vacation , Controller "bedroom-drawer" bedroomDrawerController True - , Controller "bedroom-humidifier" humidifierController True - , Controller "ruuvi-controller" ruuviController True + , Controller "bedroom-humidifier" humidifierController False + , Controller "ruuvi-controller" ruuviController False ] -- | Steps the machine for every inbound message; service calls go to the diff --git a/test/BedroomSpec.hs b/test/BedroomSpec.hs new file mode 100644 index 0000000..5f0a432 --- /dev/null +++ b/test/BedroomSpec.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE OverloadedStrings #-} + +module BedroomSpec (spec) where + +import AFRP (Event (..)) +import qualified Data.Text as T +import Data.Aeson (Value) +import HomeAssistant.Controller +import HomeAssistant.Controller.Bedroom +import Support +import Test.Hspec + +masseButton :: T.Text -> Event Value +masseButton = Event . buttonEvent "event.bedroom_quick_remote_masse_action" + +enishenButton :: T.Text -> Event Value +enishenButton = Event . buttonEvent "event.bedroom_quick_jemina_action" + +drawerState :: T.Text -> Event Value +drawerState = Event . stateEvent "binary_sensor.bedroom_nightstand_drawer_sensor_masse_contact" + +spec :: Spec +spec = describe "Bedroom" $ do + drawerSpec + buttonSpec + +drawerSpec :: Spec +drawerSpec = describe "bedroomDrawerController" $ do + let entity = EntityId "switch.bedroom_drawer_light_masse" + + it "turns the drawer light on when the drawer opens" $ + services (runHASS bedroomDrawerController [drawerState "on"]) + `shouldBe` [[switch [entity] True]] + + it "turns the drawer light off when the drawer closes" $ + services (runHASS bedroomDrawerController [drawerState "off"]) + `shouldBe` [[switch [entity] False]] + + it "toggles the light as the drawer opens and closes" $ + services (runHASS bedroomDrawerController + [ drawerState "on", drawerState "off", drawerState "on" ]) + `shouldBe` [ [switch [entity] True] + , [switch [entity] False] + , [switch [entity] True] + ] + + it "ignores state events for other entities" $ + services (runHASS bedroomDrawerController + [Event (stateEvent "binary_sensor.some_other_contact" "on")]) + `shouldBe` [[]] + + it "does nothing on Tick" $ + services (runHASS bedroomDrawerController [Tick]) + `shouldBe` [[]] + +buttonSpec :: Spec +buttonSpec = describe "bedroomButtonController" $ do + let area = AreaId "makuuhuone" + + it "Masse single click turns on his nightstand scene (lowest)" $ + services (runHASS bedroomButtonController [masseButton "1_short_release"]) + `shouldBe` [[activateScene "scene.makuuhuone_masse"]] + + it "Masse double click turns on the middle scene" $ + services (runHASS bedroomButtonController [masseButton "1_double_press"]) + `shouldBe` [[activateScene "scene.makuuhuone_keski"]] + + it "Masse long click turns on the bright scene" $ + services (runHASS bedroomButtonController [masseButton "1_long_press"]) + `shouldBe` [[activateScene "scene.makuuhuone_kirkas"]] + + it "Masse off click turns the bedroom lights off" $ + services (runHASS bedroomButtonController [masseButton "2_short_release"]) + `shouldBe` [[light [area] False]] + + it "Enishen single click turns on her nightstand scene (lowest)" $ + services (runHASS bedroomButtonController [enishenButton "1_short_release"]) + `shouldBe` [[activateScene "scene.makuuhuone_jemina"]] + + it "Enishen double click turns on the middle scene" $ + services (runHASS bedroomButtonController [enishenButton "1_double_press"]) + `shouldBe` [[activateScene "scene.makuuhuone_keski"]] + + it "Enishen long click turns on the bright scene" $ + services (runHASS bedroomButtonController [enishenButton "1_long_press"]) + `shouldBe` [[activateScene "scene.makuuhuone_kirkas"]] + + it "Enishen off click turns the bedroom lights off" $ + services (runHASS bedroomButtonController [enishenButton "2_short_release"]) + `shouldBe` [[light [area] False]] + + it "ignores the initial press (scene only fires on release)" $ + services (runHASS bedroomButtonController [masseButton "1_initial_press"]) + `shouldBe` [[]] + + it "ignores button events for other entities" $ + services (runHASS bedroomButtonController + [Event (buttonEvent "event.some_other_action" "1_short_release")]) + `shouldBe` [[]] + + it "does nothing on Tick" $ + services (runHASS bedroomButtonController [Tick]) + `shouldBe` [[]] diff --git a/test/Main.hs b/test/Main.hs index 429ca51..17f9bdf 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -3,6 +3,7 @@ module Main (main) where import Test.Hspec (hspec) import qualified AFRPSpec import qualified BackoffProp +import qualified BedroomSpec import qualified BusSpec import qualified ConnectionSpec import qualified RuntimeSpec @@ -11,6 +12,7 @@ import qualified SupervisorSpec main :: IO () main = hspec $ do AFRPSpec.spec + BedroomSpec.spec BusSpec.spec ConnectionSpec.spec RuntimeSpec.spec diff --git a/test/Support.hs b/test/Support.hs new file mode 100644 index 0000000..c487fc0 --- /dev/null +++ b/test/Support.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Support + ( Acc(..) + , interp + , runHASS + , services + , fakeRequest + , sec + , stateEvent + , buttonEvent + ) where + +import Control.Monad.Fix (MonadFix (..)) +import Data.Aeson (Value, object, (.=)) +import qualified Data.Text as T +import Data.Time (UTCTime (..)) +import Data.UUID (nil) +import AFRP (Mealy (..), Request (..)) +import HomeAssistant.Controller (HASSEff (..), Service) + +fakeRequest :: Request +fakeRequest = Request (sec 0) nil + +sec :: Integer -> UTCTime +sec n = UTCTime (toEnum 0) (fromIntegral n) + +-- | A pure Writer-like monad accumulating `Service` calls per step. +newtype Acc a = Acc { runAcc :: [Service] -> (a, [Service]) } + +instance Functor Acc where + fmap f (Acc g) = Acc $ \s -> let (a, s') = g s in (f a, s') + +instance Applicative Acc where + pure a = Acc (\s -> (a, s)) + Acc f <*> Acc x = Acc $ \s -> let (f', s') = f s; (a, s'') = x s' in (f' a, s'') + +instance Monad Acc where + Acc m >>= k = Acc $ \s -> let (a, s') = m s; (b, s'') = runAcc (k a) s' in (b, s'') + +instance MonadFix Acc where + mfix f = Acc $ \s -> let (a, s') = runAcc (f a) s in (a, s') + +-- | Interpret `HASSEff` in `Acc`: record `CallService`, drop tracing/debug. +interp :: HASSEff a -> Acc a +interp (CallService _ svc) = Acc $ \s -> ((), s ++ [svc]) +interp (Debug _) = pure () +interp (Trace _ _) = pure () + +-- | Run a HASS arrow over a list of inputs, collecting per-step emitted services. +runHASS :: Mealy HASSEff a b -> [a] -> [(b, [Service])] +runHASS _ [] = [] +runHASS m (a : as) = + case runAcc (runMealy m interp fakeRequest a) [] of + ((b, m'), svcs) -> (b, svcs) : runHASS m' as + +services :: [(b, [Service])] -> [[Service]] +services = map snd + +-- | Build a state-change event payload matching `entityChangeEvent'` / `entityBool'` lenses. +stateEvent :: T.Text -> T.Text -> Value +stateEvent entityId state = object + [ "event" .= object + [ "data" .= object + [ "entity_id" .= entityId + , "new_state" .= object [ "state" .= state ] + ] + ] + ] + +-- | Build an Ikea button event payload matching `ikeaQuickButton` lenses. +buttonEvent :: T.Text -> T.Text -> Value +buttonEvent entityId eventType = object + [ "event" .= object + [ "data" .= object + [ "entity_id" .= entityId + , "new_state" .= object + [ "attributes" .= object [ "event_type" .= eventType ] ] + ] + ] + ]