Control the kitchen lights

.gitignore

@@ -5,3 +5,8 @@ dist-newstyle
 .worktrees/
 
 docs/superpowers
+
+*.hp
+*.eventlog
+*.eventlog.html
+*.rrd

default.nix

@@ -1,7 +1,8 @@
 { mkDerivation, aeson, annotated-exception, async, base, bytestring
-, cereal, containers, directory, ekg-core, filepath, hedgehog
+, cereal, cereal-conduit, conduit, containers, directory, ekg-core
-, hspec, hspec-hedgehog, katip, lens, lens-aeson, lib, network
+, filepath, hedgehog, hspec, hspec-hedgehog, katip, lens
-, process, stm, text, time, unordered-containers, uuid, websockets
+, lens-aeson, lib, network, process, stm, text, time
+, unordered-containers, uuid, websockets
 }:
 mkDerivation {
   pname = "home-assistant-controller";
@@ -10,9 +11,10 @@ mkDerivation {
   isLibrary = true;
   isExecutable = true;
   libraryHaskellDepends = [
-    aeson annotated-exception async base bytestring cereal containers
+    aeson annotated-exception async base bytestring cereal
-    directory ekg-core filepath katip lens lens-aeson network process
+    cereal-conduit conduit containers directory ekg-core filepath katip
-    stm text time unordered-containers uuid websockets
+    lens lens-aeson network process stm text time unordered-containers
+    uuid websockets
   ];
   executableHaskellDepends = [ base ];
   testHaskellDepends = [

home-assistant-controller.cabal

@@ -62,6 +62,7 @@ library
     exposed-modules:  AFRP
                     , HomeAssistant.Controller
                     , HomeAssistant.Controller.Bedroom
+                    , HomeAssistant.Controller.Kitchen
                     , HomeAssistant.Controller.Children
                     , HomeAssistant.Controller.Ruuvi
                     , HomeAssistant.Runtime
@@ -99,6 +100,8 @@ library
                     , cereal
                     , containers
                     , filepath
+                    , conduit
+                    , cereal-conduit
 
     -- Directories containing source files.
     hs-source-dirs:   src

src/AFRP.hs

@@ -4,6 +4,7 @@
 module AFRP
   ( Mealy(..)
   , Auto(..)
+  , DecodedAuto(..)
   , eff
   , withEntities
   , Event(..)
@@ -24,7 +25,9 @@ module AFRP
   , Pair(..)
   , Request(..)
   , SerializeUTCTime(..)
+  , SerializeLocalTime(..)
   , edge
+  , waitFor
   , duration
   , tag
   , isEvent
@@ -44,13 +47,13 @@ module AFRP
 import Control.Category (Category(..), (>>>))
 import Prelude hiding ((.), id)
 import Control.Arrow (Arrow(..), ArrowChoice(..))
-import Data.Time (UTCTime (UTCTime), NominalDiffTime, diffUTCTime, addUTCTime, TimeZone, LocalTime, utcToLocalTime, Day (..), diffTimeToPicoseconds, picosecondsToDiffTime)
+import Data.Time (UTCTime (UTCTime), NominalDiffTime, diffUTCTime, addUTCTime, TimeZone, LocalTime (LocalTime), utcToLocalTime, Day (..), diffTimeToPicoseconds, picosecondsToDiffTime, TimeOfDay (TimeOfDay), diffLocalTime)
 import Data.Either (fromLeft)
 import Data.Bool (bool)
 import Data.UUID (UUID)
 import qualified Data.Set as S
 import qualified Data.Text as T
-import Data.Serialize (Get, Putter, runPut, Serialize (put), runGet, get)
+import Data.Serialize (Get, Putter, Serialize (put), runGet, get)
 import qualified Data.ByteString as B
 import Control.Exception (IOException, handle, throwIO)
 import System.IO.Error (isDoesNotExistError)
@@ -58,6 +61,9 @@ import GHC.Generics (Generic)
 import Data.Sequence (Seq, (|>))
 import qualified Data.Foldable as F
 import Control.Monad.IO.Class (MonadIO, liftIO)
+import Conduit (ConduitT, (.|))
+import qualified Data.Conduit.Cereal as CC
+import qualified Conduit as C
 
 
 data Codec s = Codec { getter :: !(Get s), putter :: !(Putter s) }
@@ -203,10 +209,11 @@ instance Monad m => ArrowChoice (Auto m) where
         (c, s'') <- f s' req b
         pure (Left c, s'')
 
-serialize :: Auto m a b -> B.ByteString
+
+serialize :: Monad m => Auto eff a b -> ConduitT i B.ByteString m ()
 serialize = \case
-  Fun _ -> runPut $ put ()
+  Fun _ -> CC.sourcePut (put ())
-  Stateful Codec{putter} s _ -> runPut $ putter (state s)
+  Stateful Codec{putter} s _ -> CC.sourcePut (putter (state s))
 
 data DecodedAuto m a b
   = Decoded (Auto m a b) -- decoded from serialized state
@@ -221,10 +228,12 @@ deserialize bs = \case
       (\s' -> Decoded $ Stateful codec (pure s') f)
       $ runGet (getter codec) bs
 
+
 save :: FilePath -> Auto m a b -> IO (Auto m a b)
 save path s
   | isDirty s = do
-    _ <- B.writeFile path $ serialize s
+    -- Using conduit  machinery as it handles the exception handling for me
+    () <- C.runResourceT $ C.runConduit (serialize s .| C.sinkFileCautious path)
     pure $ cleanDirty s
   | otherwise = pure s
   where
@@ -241,7 +250,7 @@ load path a = handle defaultOnMissingFile (flip deserialize a <$> B.readFile pat
   where
     defaultOnMissingFile :: IOException -> IO (DecodedAuto m a b)
     defaultOnMissingFile e
-      | isDoesNotExistError e = pure $ FailDecode "State doesn't exist eyt" a
+      | isDoesNotExistError e = pure $ FailDecode "State doesn't exist yet" a
       | otherwise = throwIO e
 
 -- | The set of entity ids an arrow subscribes to. Static: it does not
@@ -316,11 +325,6 @@ hold def = mapAccum step def id
       Event new -> new
 
 
--- hold :: a -> Mealy eff (Event a) a
--- hold a = Mealy mempty $ \_ _ -> \case
---   Tick -> pure (Pair a (hold a))
---   Event a' -> pure (Pair a' (hold a'))
-
 events :: Mealy eff (Event a) (Either () a)
 events = arr $ \case
   Tick -> Left ()
@@ -345,7 +349,7 @@ sample = arr (uncurry tag)
 
 
 preMapAccum' :: forall m x a b. (Monad m, Eq x, Serialize x) => (x -> a -> x) -> x -> (x -> b) -> Auto m a b
-preMapAccum' f x extract = Stateful (Codec get put) (State x False) (\s _req a -> pure $ step s a)
+preMapAccum' f x extract = Stateful (Codec get put) (pure x) (\s _req a -> pure $ step s a)
   where
     step :: State x -> a -> (b, State x)
     step s a = let s' = f (state s) a in (extract (state s), State s' (dirty s || state s /= s'))
@@ -358,7 +362,7 @@ preMapAccum :: (Eq x, Serialize x) => (x -> a -> x) -> x -> (x -> b) -> Mealy ef
 preMapAccum step x extract = Mealy mempty $ \_nt -> preMapAccum' step x extract
 
 mapAccum' :: forall m x a b. (Monad m, Eq x, Serialize x) => (x -> a -> x) -> x -> (x -> b) -> Auto m a b
-mapAccum' f x extract = Stateful (Codec get put) (State x False) (\s _req a -> pure $ step s a)
+mapAccum' f x extract = Stateful (Codec get put) (pure x) (\s _req a -> pure $ step s a)
   where
     step :: State x -> a -> (b, State x)
     step s a = let s' = f (state s) a in (extract s', State s' (dirty s || state s /= s'))
@@ -402,6 +406,19 @@ instance Serialize SerializeUTCTime where
     time <- picosecondsToDiffTime <$> get
     pure $ SerializeUTCTime (UTCTime day time)
 
+newtype SerializeLocalTime = SerializeLocalTime LocalTime
+  deriving (Eq, Show)
+
+instance Serialize SerializeLocalTime where
+  put (SerializeLocalTime (LocalTime day time)) = do
+    put (toModifiedJulianDay day)
+    let TimeOfDay h m s = time
+    put (h,m, toRational s)
+  get = do
+    day  <- ModifiedJulianDay <$> get
+    (h,m,s) <- get
+    pure $ SerializeLocalTime (LocalTime day (TimeOfDay h m (fromRational s)))
+
 delayEvent :: (Eq a, Serialize a) => NominalDiffTime -> Mealy eff (Event a) (Event a)
 delayEvent delay =
   mapAccumRequest step initial output
@@ -483,7 +500,28 @@ edge =
 
 
 
+data WaitingFor
+  = Waiting
+  | Pending { waitingForStart :: SerializeLocalTime, waitingForCurrent :: SerializeLocalTime }
+  deriving (Show, Eq, Generic)
 
+instance Serialize WaitingFor
+
+waitFor :: NominalDiffTime -> Mealy eff Bool (Event ())
+waitFor delta =
+  mapAccumRequest step Waiting extract >>> edge
+  where
+    extract :: WaitingFor -> Bool
+    extract Waiting = False
+    extract Pending{waitingForStart=SerializeLocalTime s, waitingForCurrent=SerializeLocalTime e} =
+      e `diffLocalTime` s >= delta
+    step :: Request -> WaitingFor -> Bool -> WaitingFor
+    step _req _prev False = Waiting
+    step req prev True =
+      let now = SerializeLocalTime $ requestLocalTime req
+      in case prev of
+              Waiting -> Pending now now
+              pending -> pending{waitingForCurrent = now}
 
 duration :: forall eff a. Mealy eff a NominalDiffTime
 duration = mapAccumRequest go (Nothing @(SerializeUTCTime, SerializeUTCTime)) (maybe 0 delta)
@@ -551,10 +589,12 @@ sliding size = mapAccum go [] id
     go acc (Event a) = let xs = acc ++ [a] in drop (max 0 (length xs - size)) xs
 
 
+requestLocalTime :: Request -> LocalTime
+requestLocalTime Request{requestTime, requestTimeZone} = utcToLocalTime requestTimeZone requestTime
 
 currentTime :: Mealy eff a LocalTime
-currentTime = Mealy mempty $ \_nt -> Fun $ \Request{requestTime, requestTimeZone} _ ->
+currentTime = Mealy mempty $ \_nt -> Fun $ \req _ ->
-  utcToLocalTime requestTimeZone requestTime
+  requestLocalTime req
 
 
 stepAuto :: Monad m => Auto m a b -> Request -> a -> m (b, Auto m a b)

src/HomeAssistant/Controller.hs

@@ -8,6 +8,7 @@ module HomeAssistant.Controller
   , HASSEff(..)
   , HASS
   , callService
+  , callServiceDyn
   , entityChangeEvent
   , entityChangeEvent'
   , entityRead
@@ -61,6 +62,9 @@ type HASS a b = Mealy HASSEff a b
 callService :: Service -> HASS a ()
 callService service = eff (\req _ -> CallService req service)
 
+callServiceDyn :: (a -> Service) -> HASS a ()
+callServiceDyn mkService = eff (\req a -> CallService req (mkService a))
+
 debug :: Show a => HASS a a
 debug = proc x -> do
   eff (const Debug) -< x
@@ -84,7 +88,9 @@ data DoorState = Open | Closed
 instance Serialize DoorState
 
 data Presence = Occupied | Unoccupied
-  deriving (Show, Eq)
+  deriving (Show, Eq, Generic)
+
+instance Serialize Presence
 
 presence :: T.Text -> HASS (Event Value) (Event Presence)
 presence entityId =entityBool entityId

src/HomeAssistant/Controller/Bedroom.hs

@@ -131,12 +131,12 @@ door = entityBool "binary_sensor.makuuhuone_ovi_contact"
 waitFor :: NominalDiffTime -> HASS a (Event ())
 waitFor n = duration >>> arr (> n) >>> edge
 
+
 delayedDoor :: HASS (Event Value) (Event DoorState)
 delayedDoor = door
   >>> AFRP.debounce 15
   >>> AFRP.hold Open
   >>> AFRP.changes
-  >>> traceEvent
 
 humidifierController :: HASS (Event Value) ()
 humidifierController = proc x -> do

src/HomeAssistant/Controller/Kitchen.hs

@@ -0,0 +1,59 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Arrows #-}
+module HomeAssistant.Controller.Kitchen where
+import HomeAssistant.Controller
+import AFRP (Event (..))
+import qualified AFRP
+import Data.Aeson (Value)
+import Control.Arrow ((>>>), Arrow (..), returnA)
+import Data.Bool (bool)
+import GHC.Generics (Generic)
+import Data.Serialize (Serialize)
+import Prelude hiding (id)
+import Data.Time (LocalTime(..), TimeOfDay (..))
+
+
+-- Kitchen has two "presence" sensors. One IKEA motion sensor and one SwitchBot presence sensor
+data Motion = MotionDetected | MotionNotDetected | MotionUnknown
+  deriving (Show, Eq, Generic)
+
+instance Serialize Motion
+
+data Lights = LightsOn | LightsOff
+  deriving (Show)
+
+kitchenMotion :: HASS (Event Value) Motion
+kitchenMotion = entityBool "binary_sensor.kitchen_movement_occupancy"
+  >>> arr (fmap (bool MotionNotDetected MotionDetected))
+  >>> traceEvent
+  >>> AFRP.hold MotionUnknown
+
+
+kitchenPresence :: HASS Motion Presence
+kitchenPresence = (eventOccupied &&& eventUnoccupied)
+  >>> arr (uncurry AFRP.lMerge) >>> traceEvent
+  >>> AFRP.hold Unoccupied
+  where
+    eventOccupied :: HASS Motion (Event Presence)
+    eventOccupied = arr (== MotionDetected) >>> AFRP.edge >>> arr (fmap (const Occupied))
+    eventUnoccupied :: HASS Motion (Event Presence)
+    eventUnoccupied = arr (== MotionNotDetected) >>> AFRP.waitFor 300 >>> arr (AFRP.tag Unoccupied)
+
+eventLights :: HASS Presence (Event Lights)
+eventLights = AFRP.changes >>> arr (fmap presenceLights)
+  where
+    presenceLights Occupied = LightsOn
+    presenceLights Unoccupied = LightsOff
+
+kitchenMotionController :: HASS (Event Value) ()
+kitchenMotionController = proc x -> do
+  now <- AFRP.currentTime -< ()
+  p <- kitchenMotion >>> kitchenPresence -< x
+  ev <- eventLights -< p
+  traceEvent -< ev
+  case ev of
+       Event LightsOn | lightsAllowed now -> callServiceDyn (light [EntityId "light.kitchen_ceiling"]) -< On Nothing
+       Event LightsOff -> callServiceDyn (light [EntityId "light.kitchen_ceiling"]) -< Off
+       _ -> returnA -< ()
+  where
+    lightsAllowed (LocalTime _ tod) = not (tod > TimeOfDay 1 45 0 && tod < TimeOfDay 5 0 0)

src/HomeAssistant/Runtime.hs

@@ -13,7 +13,7 @@ module HomeAssistant.Runtime
   , runController
   ) where
 
-import AFRP (Event (..), Mealy (..), Request (..), Auto, stepAutoSerializing)
+import AFRP (Event (..), Mealy (..), Request (..), Auto, stepAutoSerializing, load, DecodedAuto (..))
 import Control.Concurrent.Async (async, waitAny)
 import Control.Concurrent.STM (atomically, dupTChan, readTChan)
 import Data.Aeson (Value)
@@ -37,6 +37,7 @@ import Data.Maybe (fromMaybe)
 import qualified System.Metrics
 import qualified HomeAssistant.Runtime.Metrics
 import System.FilePath ((</>))
+import HomeAssistant.Controller.Kitchen (kitchenMotionController)
 
 step :: (MonadIO m) => FilePath -> UUID -> Auto m a b -> a -> m (b, Auto m a b)
 step path trace st a = do
@@ -52,9 +53,10 @@ 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 False
+  , Controller "bedroom-humidifier" humidifierController True
   , Controller "ruuvi-controller" ruuviController False
   , Controller "school-light-controller" schoolLightController True
+  , Controller "kitchen-motion-controller" kitchenMotionController True
   ]
 
 -- | Steps the machine for every inbound message; service calls go to the
@@ -64,8 +66,11 @@ runController :: FilePath -> Bus -> Controller -> IO Void
 runController rootDir bus (Controller name machine _enabled) = do
   inbound <- atomically (dupTChan (busInbound bus))
   let ns = Namespace [name]
-  let worker = runMealy machine (runKatipContextT (busLogEnv bus) () ns . channelHassEval bus)
+  let workerDefinition = runMealy machine (runKatipContextT (busLogEnv bus) () ns . channelHassEval bus)
   let path  = rootDir </> T.unpack name
+  worker <- load path workerDefinition >>= \case
+    Decoded a -> pure a
+    FailDecode err a -> a <$ putStrLn ("Failed to load (" <> T.unpack name <> "): " <> err)
   go path inbound worker
   where
     go path inbound f = do

test/AFRPSpec.hs

@@ -12,7 +12,7 @@ import Data.List (sort)
 import Data.Serialize (get, put, runGet, runPut)
 import qualified Data.Set as S
 import qualified Data.Text as T
-import Data.Time (Day (..), NominalDiffTime, UTCTime (..), picosecondsToDiffTime, utc)
+import Data.Time (Day (..), NominalDiffTime, LocalTime(..), TimeOfDay(..), UTCTime (..), picosecondsToDiffTime, utc)
 import Data.UUID (nil)
 import Hedgehog
 import qualified Hedgehog.Gen as Gen
@@ -413,12 +413,26 @@ timeGen = do
     <$> Gen.int (Range.linear 0 (86400 * 10 ^ (12 :: Int) - 1))
   pure $ SerializeUTCTime (UTCTime day pico)
 
+localTimeGen :: Gen SerializeLocalTime
+localTimeGen = do
+  day <- ModifiedJulianDay . fromIntegral <$> genInt 0 100000
+  tod <- TimeOfDay <$> genInt 0 23 <*> genInt 0 59 <*> (fromIntegral <$> genInt 0 60)
+  pure $ SerializeLocalTime (LocalTime day tod)
+  where
+    genInt a b = Gen.int (Range.linear a b)
+
 serializeSpec :: Spec
-serializeSpec = describe "SerializeUTCTime" $ do
+serializeSpec = do
+  describe "SerializeUTCTime" $ do
     it "get (put x) == pure x" $
       hedgehog $ do
         x <- forAll timeGen
         tripping x (runPut . put) (runGet get)
+  describe "SerializeLocalTime" $ do
+    it "get (put x) == pure x" $
+      hedgehog $ do
+        x <- forAll localTimeGen
+        tripping x (runPut . put) (runGet get)
 
 effSpec :: Spec
 effSpec = describe "eff" $ do