Store a custom snapshot of lights

default.nix

@@ -1,9 +1,10 @@
 { mkDerivation, aeson, annotated-exception, async, base, bytestring
-, cereal, cereal-conduit, conduit, containers, directory, ekg-core
-, exceptions, filepath, hedgehog, hspec, hspec-hedgehog, http-media
-, http-types, katip, lens, lens-aeson, lib, network, process, retry
-, servant, servant-server, stm, temporary, text, time, unliftio
-, unordered-containers, uuid, wai, warp, websockets
+, cereal, cereal-conduit, cereal-text, conduit, containers
+, directory, ekg-core, exceptions, filepath, hedgehog, hspec
+, hspec-hedgehog, http-media, http-types, katip, lens, lens-aeson
+, lib, network, process, retry, servant, servant-server, stm
+, temporary, text, time, unliftio, unordered-containers, uuid, wai
+, warp, websockets
 }:
 mkDerivation {
   pname = "home-assistant-controller";
@@ -13,9 +14,9 @@ mkDerivation {
   isExecutable = true;
   libraryHaskellDepends = [
     aeson annotated-exception async base bytestring cereal
-    cereal-conduit conduit containers directory ekg-core exceptions
-    filepath http-media http-types katip lens lens-aeson network
-    process retry servant servant-server stm text time unliftio
+    cereal-conduit cereal-text conduit containers directory ekg-core
+    exceptions filepath http-media http-types katip lens lens-aeson
+    network process retry servant servant-server stm text time unliftio
     unordered-containers uuid wai warp websockets
   ];
   executableHaskellDepends = [ base ];

home-assistant-controller.cabal

@@ -107,7 +107,9 @@ library
                     , process
                     , directory
                     , cereal
+                    , cereal-text
                     , containers
+                    , data-default
                     , filepath
                     , conduit
                     , cereal-conduit
@@ -169,6 +171,7 @@ test-suite home-assistant-controller-test
                       , MetricsSpec
                       , RuntimeSpec
                       , Support
+                      , ControllerSpec
 
     -- LANGUAGE extensions used by modules in this package.
     -- other-extensions:
@@ -187,6 +190,7 @@ test-suite home-assistant-controller-test
         base ^>=4.20.2.0,
         home-assistant-controller,
         bytestring,
+        data-default,
         hspec,
         stm,
         servant,

src/AFRP.hs

@@ -42,6 +42,7 @@ module AFRP
   , load
   , stepAuto
   , stepAutoSerializing
+  , snapshot
   ) where
 
 import Control.Category (Category(..), (>>>))
@@ -325,6 +326,11 @@ hold def = mapAccum step def id
       Tick -> prev
       Event new -> new
 
+snapshot :: (Serialize a, Eq a) => a -> Mealy m (Event (), a) a
+snapshot def = mapAccum step def id
+  where
+    step prev (Tick, _) = prev
+    step _prev (Event _, a) = a
 
 events :: Mealy eff (Event a) (Either () a)
 events = arr $ \case

src/HomeAssistant/Controller.hs

@@ -2,13 +2,16 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE MonadComprehensions #-}
 
 module HomeAssistant.Controller
   ( Service(..)
   , HASSEff(..)
   , HASS
   , callService
+  , callServices
   , callServiceDyn
+  , callServicesDyn
   , entityChangeEvent
   , entityChangeEvent'
   , entityRead
@@ -28,6 +31,8 @@ module HomeAssistant.Controller
   , Target(..)
   , brightness
   , Light(..)
+  , lightSignal
+  , LightStatus(..)
   , ikeaQuickButton
   , IkeaButton(..)
   , IkeaGesture(..)
@@ -35,11 +40,15 @@ module HomeAssistant.Controller
   , activateSceneWith
   , ikeaBoxRemote
   , IkeaController(..)
+  , LightSettings(..)
+  , BrightnessSettings(..)
+  , formatLightSettings
   ) where
 
 import AFRP (Mealy (..), eff, Event(..), events, filterA, (>>|), toEvent, Request, hold, lMerge, waitFor, tag, edge)
 import Control.Arrow (Arrow(..), returnA)
-import Control.Category ((>>>))
+import Control.Category ((>>>), (.))
+import Prelude hiding ((.))
 import Data.Aeson (Value, object, (.=))
 import qualified Data.Text as T
 import qualified Data.Set as S
@@ -50,6 +59,9 @@ import Data.Bool (bool)
 import Data.Serialize (Serialize)
 import GHC.Generics (Generic)
 import Data.Time (NominalDiffTime)
+import Data.Default (Default)
+import Data.Aeson.Types (Pair)
+import Data.Maybe (catMaybes)
 
 data Target = EntityId !T.Text | AreaId !T.Text
   deriving (Show,Eq,Ord)
@@ -64,6 +76,7 @@ data Service = Service
 
 data HASSEff a where
   CallService :: Request -> Service -> HASSEff ()
+  CallServices :: Request -> [Service] -> HASSEff ()
   Debug :: Show a => a -> HASSEff ()
   Trace :: Show a => Request -> a -> HASSEff ()
 
@@ -72,9 +85,15 @@ type HASS a b = Mealy HASSEff a b
 callService :: Service -> HASS a ()
 callService service = eff (\req _ -> CallService req service)
 
+callServices :: [Service] -> HASS a ()
+callServices service = eff (\req _ -> CallServices req service)
+
 callServiceDyn :: (a -> Service) -> HASS a ()
 callServiceDyn mkService = eff (\req a -> CallService req (mkService a))
 
+callServicesDyn :: (a -> [Service]) -> HASS a ()
+callServicesDyn mkService = eff (\req a -> CallServices req (mkService a))
+
 debug :: Show a => HASS a a
 debug = proc x -> do
   eff (const Debug) -< x
@@ -133,16 +152,44 @@ motionToPresence delay = (eventOccupied &&& eventUnoccupied)
 
 instance Serialize Motion
 
+data BrightnessSettings = BrightnessPercentage Double | Brightness Int
+                     deriving (Show, Generic)
+instance Default BrightnessSettings where
+
+data LightSettings = LightSettings
+  { lightSettingsBrightness :: Maybe BrightnessSettings
+  , lightSettingsTemperature :: Maybe Int
+  , lightSettingsTransition :: Maybe Double
+  }
+                     deriving (Show, Generic)
+
+
+instance Default LightSettings where
+
+
+formatLightSettings :: LightSettings -> Maybe Value
+formatLightSettings s = toObject $ catMaybes
+  [ ["transition" .= x | x <- lightSettingsTransition s]
+  , ["color_temp_kelvin" .= k | k <- lightSettingsTemperature s]
+  , ["brightness" .= b | Brightness b <- lightSettingsBrightness s]
+  , ["brightness_pct" .= b | BrightnessPercentage b <- lightSettingsBrightness s]
+  ]
+  where
+    toObject :: [Pair] -> Maybe Value
+    toObject [] = Nothing
+    toObject xs = Just $ object xs
+
 data Light
   = Off
-  | On { brightnessPercentage :: Maybe Double }
+  | On LightSettings
 
 -- Turn off lights when door is closed
 light :: [Target] -> Light -> Service
-light targets (On {brightnessPercentage}) = Service
+light targets (On settings) = Service
   { serviceDomain="light"
   , serviceName= "turn_on"
-  , serviceData=fmap (\pct -> object ["brightness_pct" .= pct]) brightnessPercentage
+  -- , serviceData= fmap (\pct -> object ["brightness_pct" .= pct]) brightnessPercentage
+  , serviceData= formatLightSettings settings
   , serviceTarget=targets
   }
 light targets Off = Service
@@ -199,6 +246,30 @@ brightness entityId =
   where
     eventBrightness v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "attributes" . key "brightness" . _Integral
 
+temperature :: T.Text -> HASS (Event Value) (Event Int)
+temperature entityId =
+  entityChangeEvent' entityId
+  >>| arr (maybe (Left ()) Right . eventTemperature)
+  >>> AFRP.toEvent
+  where
+    eventTemperature v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "attributes" . key "color_temp_kelvin" . _Integral
+
+-- XXX: Needs better name
+data LightStatus = LightStatus
+  { lightEnabled :: Bool
+  , lightBrightness :: Int
+  , lightTemperature :: Int
+  }
+  deriving (Show, Generic, Eq)
+instance Serialize LightStatus
+
+lightSignal :: T.Text -> HASS (Event Value) LightStatus
+lightSignal entityId = proc ev -> do
+  e <- hold False . entityBool entityId -< ev
+  b <- hold 0 . brightness entityId -< ev
+  t <- hold 0 . temperature entityId -< ev
+  returnA -< LightStatus e b t
+
 data IkeaGesture
   = ShortClick
   | ShortRelease

src/HomeAssistant/Controller/Bedroom.hs

@@ -10,6 +10,11 @@ import Control.Arrow ((>>>), returnA, arr, Arrow (..))
 import Data.Bool (bool)
 import Data.Time (NominalDiffTime)
 import qualified AFRP
+import Data.Map (Map)
+import qualified Data.Map.Strict as M
+import Data.Serialize.Text ()
+import Data.Foldable (traverse_)
+import Data.Default (def)
 
 
 
@@ -31,7 +36,7 @@ data PresenceLights
   = LightsOn -- Restore lights
   | LightsOff -- Timer expired, darkness
   | LightsSleep -- No presence detected, sleep mode
-  deriving Show
+  deriving (Eq, Show)
 
 -- Bedroom presence
 bedroomPresence :: HASS (Event Value) (Event Presence)
@@ -49,19 +54,36 @@ presenceLightEvents =
     onEvent = AFRP.edge >>> arr (AFRP.tag LightsOn)
     offEvent = arr not >>> AFRP.waitFor 300 >>> arr (AFRP.tag LightsOff)
 
+
+bedroomLightsSignal :: HASS (Event Value) (Map T.Text LightStatus)
+bedroomLightsSignal = M.fromList <$> traverse (\e -> (e,) <$> lightSignal e) [e | EntityId e <- bedroomLights]
+
 bedroomPresenceController :: HASS (Event Value) ()
 bedroomPresenceController = proc x -> do
   p <- presenceLightEvents >>> traceEvent -< x
+  snap <- (doSnapshot &&& bedroomLightsSignal) >>> AFRP.snapshot M.empty >>> traceValue -< x
   case p of
        Event LightsOff -> do
          callService (light bedroomLights Off) -< ()
        Event LightsOn -> do
-         callService (activateSceneWith "scene.makuuhuone_lights_snapshot" transition) -< ()
+         -- callService (activateSceneWith "scene.makuuhuone_lights_snapshot" transition) -< ()
+         callServicesDyn (concatMap (uncurry toLight)) -< M.toList snap
+         returnA -< ()
        Event LightsSleep -> do
          callService createBedroomScene -< ()
          callService (activateSceneWith "scene.makuuhuone_lepotila" transition) -< ()
        _ -> returnA -< ()
   where
+    -- This is the meat of this change. To support transitioning the brightness, exactly,
+    -- we need to do the brightness call separately and last
+    toLight :: T.Text -> LightStatus -> [Service]
+    toLight entityId LightStatus{lightEnabled=False} = [light [EntityId entityId] Off]
+    toLight entityId LightStatus{lightEnabled=True, lightTemperature=t, lightBrightness=b} =
+      [ light [EntityId entityId] (On def{lightSettingsTemperature=Just t})
+      , light [EntityId entityId] (On def{lightSettingsTransition=Just 5, lightSettingsBrightness=Just (Brightness b)})
+      ]
+    doSnapshot = presenceLightEvents
+      >>> arr (\ev -> if ev == Event LightsSleep then Event () else Tick)
     transition = Just $ object ["transition" .= (1:: Int)]
 
 

src/HomeAssistant/Controller/Children.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE Arrows #-}
 {-# LANGUAGE OverloadedStrings #-}
 module HomeAssistant.Controller.Children where
-import HomeAssistant.Controller (HASS, callService, Target (AreaId), light, Light(..), ikeaQuickButton, IkeaGesture (..), IkeaButton (..), traceEvent, activateScene)
+import HomeAssistant.Controller (HASS, callService, Target (AreaId), light, Light(..), ikeaQuickButton, IkeaGesture (..), IkeaButton (..), traceEvent, activateScene, LightSettings (..), BrightnessSettings (..))
 import AFRP (Event (..))
 import qualified AFRP
 import Control.Arrow (Arrow(..), (>>>), returnA)
@@ -9,6 +9,7 @@ import Data.Time (Day, TimeOfDay (..), localDay, LocalTime (..))
 import Data.Time.Calendar.OrdinalDate (WeekOfYear, mondayStartWeek)
 import Data.Functor.Contravariant (Predicate (..), (>$<))
 import Data.Aeson (Value)
+import Data.Default (Default(..))
 
 -- Let's see building some reasonable interface for utctime
 dow :: Day -> (WeekOfYear, Int)
@@ -74,7 +75,7 @@ schoolLightController = lightsOn <> lightsOff
 
 lightsOn :: HASS a ()
 lightsOn = foldMap atTime timersOn
-  >>> AFRP.onEvent (callService (light [AreaId "lasten_makuuhuone"] On{brightnessPercentage = Just 100}))
+  >>> AFRP.onEvent (callService (light [AreaId "lasten_makuuhuone"] (On def{lightSettingsBrightness=Just $ BrightnessPercentage 100} )))
 
 lightsOff :: HASS a ()
 lightsOff = foldMap atTime timersOff

src/HomeAssistant/Controller/Hallway.hs

@@ -8,6 +8,7 @@ import qualified AFRP
 import Data.Aeson (Value)
 import Control.Arrow ((>>>), Arrow (..), returnA)
 import Data.Time (LocalTime(..), TimeOfDay (..))
+import Data.Default (def)
 
 
 
@@ -31,7 +32,7 @@ hallwayLightsController = proc x -> do
   traceEvent -< ev
   case ev of
        -- The lights entity is a "group of lights" in hass
-       Event LightsOn | lightsAllowed now -> callServiceDyn (light [EntityId "light.hallway_lights"]) -< On Nothing
+       Event LightsOn | lightsAllowed now -> callServiceDyn (light [EntityId "light.hallway_lights"]) -< On def
        Event LightsOff -> callServiceDyn (light [EntityId "light.hallway_lights"]) -< Off
        _ -> returnA -< ()
   where

src/HomeAssistant/Controller/Kitchen.hs

@@ -8,6 +8,7 @@ import Data.Aeson (Value)
 import Control.Arrow ((>>>), Arrow (..), returnA)
 import Prelude hiding (id)
 import Data.Time (LocalTime(..), TimeOfDay (..))
+import Data.Default (def)
 
 
 -- Kitchen has two "presence" sensors. One IKEA motion sensor and one SwitchBot presence sensor
@@ -31,7 +32,7 @@ kitchenCeilingController = proc x -> do
   ev <- eventLights -< p
   traceEvent -< ev
   case ev of
-       Event LightsOn | lightsAllowed now -> callServiceDyn (light [EntityId "light.kitchen_ceiling"]) -< On Nothing
+       Event LightsOn | lightsAllowed now -> callServiceDyn (light [EntityId "light.kitchen_ceiling"]) -< On def
        Event LightsOff -> callServiceDyn (light [EntityId "light.kitchen_ceiling"]) -< Off
        _ -> returnA -< ()
   where
@@ -73,7 +74,7 @@ dinnerTableController = proc x -> do
   case ev of
        Event LightsOn -> do
          sleep -< False
-         callServiceDyn (light [EntityId "light.kitchen_dining_large"]) -< On Nothing
+         callServiceDyn (light [EntityId "light.kitchen_dining_large"]) -< On def
        Event LightsOff -> do
          sleep -< False
          callServiceDyn (light [EntityId "light.kitchen_dining_large"]) -< Off

src/HomeAssistant/Controller/Livingroom.hs

@@ -9,6 +9,7 @@ import Data.Aeson (Value)
 import Prelude hiding ((.))
 import Control.Category ((.))
 import Data.Time (LocalTime(..), toGregorian, TimeOfDay (..))
+import Data.Default (def)
 
 data Lights = LightsOn | LightsOff
   deriving (Show)
@@ -46,7 +47,7 @@ livingroomPresenceController = proc x -> do
   ev <- eventLights . livingroomPresence -< x
   traceEvent -< ev
   case ev of
-       AFRP.Event LightsOn -> callServiceDyn (light lights) -< On Nothing
+       AFRP.Event LightsOn -> callServiceDyn (light lights) -< On def
        AFRP.Event LightsOff -> callServiceDyn (light lights) -< Off
        _ -> returnA -< ()
   returnA -< ()

src/HomeAssistant/Runtime.hs

@@ -43,6 +43,7 @@ import UnliftIO.Async
 import HomeAssistant.Runtime.Supervisor (supervised)
 import HomeAssistant.Controller.Hallway (hallwayLightsController)
 import qualified HttpServer
+import Data.Foldable (forM_)
 
 step :: (MonadIO m) => FilePath -> T.Text -> UUID -> Auto m a b -> a -> m (b, Auto m a b)
 step path name trace st a = do
@@ -128,6 +129,9 @@ dryRunHassEval ns bus = \case
   CallService req x -> runKatipT (busLogEnv bus) $ do
     callId <- liftIO $ generateCallId (busGen bus)
     logF (sl "traceId" (toText (requestTraceId req))) ns DebugS (ls $ show (callId, x))
+  CallServices req xs -> runKatipT (busLogEnv bus) $ forM_ xs $ \x -> do
+    callId <- liftIO $ generateCallId (busGen bus)
+    logF (sl "traceId" (toText (requestTraceId req))) ns DebugS (ls $ show (callId, x))
   Debug x -> runKatipT (busLogEnv bus) $ do
     logF () ns DebugS (ls $ show x)
   Trace req x -> runKatipT (busLogEnv bus) $ do

src/HomeAssistant/Runtime/Bus.hs

@@ -34,6 +34,7 @@ import AFRP (Request(..), Event(..))
 import Control.Monad (when)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import HomeAssistant.Runtime.Flags (Flags, isEnabled)
+import Data.Foldable (forM_)
 
 -- | Shared runtime state: inbound is a broadcast channel (controllers
 -- read from 'dupTChan' copies), outbound queues service calls for the
@@ -76,6 +77,10 @@ channelHassEval bus = \case
     logFM DebugS (ls $ show svc)
     enabled <- isEnabled (busFlags bus) (requestHandler req)
     when enabled $ liftIO $ atomically $ writeTChan (busOutbound bus) (req, svc)
+  CallServices req svcs -> katipAddContext (sl "traceId" (toText (requestTraceId req))) $ forM_ svcs $ \svc -> do
+    logFM DebugS (ls $ show svc)
+    enabled <- isEnabled (busFlags bus) (requestHandler req)
+    when enabled $ liftIO $ atomically $ writeTChan (busOutbound bus) (req, svc)
   Debug x -> logFM DebugS (ls $ show x)
   Trace req x -> katipAddContext (sl "traceId" (toText (requestTraceId req))) $
     logFM InfoS (ls $ show x)

test/BedroomSpec.hs

@@ -49,8 +49,8 @@ entitySpec = describe "entities" $ do
         ]
 
   it "bedroomPresenceController subscribes to the presence sensor" $
-    entities bedroomPresenceController
-      `shouldBe` S.singleton "binary_sensor.presence_sensor_bedroom_occupancy"
+    S.toList (entities bedroomPresenceController)
+      `shouldContain` [ "binary_sensor.presence_sensor_bedroom_occupancy" ]
 
   it "humidifierController subscribes to the door sensor" $
     entities humidifierController

test/ControllerSpec.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE OverloadedStrings #-}
+module ControllerSpec where
+import Test.Hspec
+import Data.Default (def)
+import HomeAssistant.Controller (BrightnessSettings(..), formatLightSettings, LightSettings(..))
+import Data.Aeson (object, (.=))
+import HomeAssistant.Controller ()
+
+
+spec :: Spec
+spec = describe "Generic controller" $
+  describe "Light settings" $ do
+    it "formats the default as empty" $
+      formatLightSettings def `shouldBe` Nothing
+    it "formats the transition" $
+      formatLightSettings def{lightSettingsTransition=Just 5} `shouldBe`
+        Just (object ["transition" .= (5 :: Int)])
+    it "formats the temperature" $
+      formatLightSettings def{lightSettingsTemperature=Just 5} `shouldBe`
+        Just (object ["color_temp_kelvin" .= (5 :: Int)])
+    it "formats the  brightness as percentage" $
+      formatLightSettings def{lightSettingsBrightness=Just (BrightnessPercentage 100)} `shouldBe`
+        Just (object ["brightness_pct" .= (100 :: Int)])
+    it "formats the  brightness as absolute" $
+      formatLightSettings def{lightSettingsBrightness=Just (Brightness 200)} `shouldBe`
+        Just (object ["brightness" .= (200 :: Int)])
+    it "formats multiple values" $
+      formatLightSettings def{lightSettingsTransition = Just 5, lightSettingsBrightness=Just (Brightness 200)} `shouldBe`
+        Just (object ["brightness" .= (200 :: Int), "transition" .= (5 :: Int)])

test/KitchenSpec.hs

@@ -10,6 +10,7 @@ import HomeAssistant.Controller
 import HomeAssistant.Controller.Kitchen
 import Support
 import Test.Hspec
+import Data.Default (def)
 
 -- Helper functions for creating test events
 testDinnerLightLevel :: Int -> Event Value
@@ -34,7 +35,7 @@ dinnerTableSpec = describe "dinnerTableController" $ do
 
   it "turns lights on when presence is occupied and light level is low" $ do
     services (runHASS dinnerTableController [testDinnerLightLevel 10, testDinnerPresence "on"])
-      `shouldBe` [[switch [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"] True], [switch [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"] False, light [EntityId "light.kitchen_dining_large"] (On Nothing)]]
+      `shouldBe` [[switch [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"] True], [switch [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"] False, light [EntityId "light.kitchen_dining_large"] (On def)]]
 
   it "turns lights off when presence is unoccupied" $ do
     services (runHASS dinnerTableController [testDinnerLightLevel 10, testDinnerPresence "off"])

test/Main.hs

@@ -12,6 +12,7 @@ import qualified KitchenSpec
 import qualified LivingroomSpec
 import qualified MetricsSpec
 import qualified RuntimeSpec
+import qualified ControllerSpec
 
 main :: IO ()
 main = hspec $ do
@@ -26,3 +27,4 @@ main = hspec $ do
   LivingroomSpec.spec
   MetricsSpec.spec
   RuntimeSpec.spec
+  ControllerSpec.spec