Test the bedroom spec

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:

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 ())

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 "bedroom-humidifier" humidifierController False
-  , Controller "ruuvi-controller" ruuviController True
+  , Controller "ruuvi-controller" ruuviController False
   ]
 
 -- | Steps the machine for every inbound message; service calls go to the

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` [[]]

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

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 ] ]
+      ]
+    ]
+  ]