HUmidifier logic with some extra new primitives

src/AFRP.hs

@@ -19,12 +19,18 @@ module AFRP
   , toEvent
   , lMerge
   , Request(..)
+  , edge
+  , duration
+  , tag
+  , isEvent
+  , delayEvent
+  , sample
   ) where
 
 import Control.Category (Category(..), (>>>))
 import Prelude hiding ((.), id)
 import Control.Arrow (Arrow(..), ArrowChoice(..), ArrowLoop(..))
-import Data.Time (UTCTime)
+import Data.Time (UTCTime, NominalDiffTime, diffUTCTime, addUTCTime)
 import Control.Monad.Fix (MonadFix (mfix))
 import Data.Either (fromLeft)
 import Data.Bool (bool)
@@ -95,6 +101,13 @@ events = arr $ \case
   Tick -> Left ()
   Event a -> Right a
 
+isEvent :: Event a -> Bool
+isEvent Tick = False
+isEvent _ = True
+
+tag :: b -> Event a -> Event b
+tag b ev = b <$ ev
+
 switch :: Mealy eff a (b, Event c) -> (c -> Mealy eff a b) -> Mealy eff a b
 switch (Mealy f) s = Mealy $ \nt t a -> do
   ((b, ev), f') <- f nt t a
@@ -102,6 +115,9 @@ switch (Mealy f) s = Mealy $ \nt t a -> do
           Tick -> pure (b, switch f' s)
           Event x -> runMealy (s x) nt t a
 
+sample :: Mealy eff (a, Event b) (Event a)
+sample = arr (uncurry tag)
+
 preMapAccum :: (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
 preMapAccum f x extract = go x
   where
@@ -130,6 +146,34 @@ mapAccumRequest f x extract = go x
       let next = f t b a
       in pure (extract next, go next)
 
+data DelayState a = DelayState
+  { pending :: [(UTCTime, a)]
+  , output  :: Event a
+  }
+
+
+delayEvent :: NominalDiffTime -> Mealy eff (Event a) (Event a)
+delayEvent delay =
+  mapAccumRequest step initial output
+  where
+    initial = DelayState [] Tick
+
+    step req st input =
+      let now = requestTime req
+
+          queued =
+            case input of
+              Tick    -> pending st
+              Event x -> pending st ++ [(delay `addUTCTime` now, x)]
+
+      in case queued of
+           (due, x) : rest
+             | due <= now ->
+                 DelayState rest (Event x)
+
+           _ ->
+                 DelayState queued Tick
+
 changes :: Eq a => Mealy eff a (Event a)
 changes = mapAccum go Nothing (maybe Tick snd)
   where
@@ -161,3 +205,21 @@ lMerge :: Event a -> Event a -> Event a
 lMerge Tick Tick = Tick
 lMerge (Event a) _ = Event a
 lMerge Tick (Event a) = Event a
+
+edge :: Mealy eff Bool (Event ())
+edge = go False
+  where
+    go True = Mealy $ \_ _ -> \case
+      True -> pure (Tick, go True)
+      False -> pure (Tick, go False)
+    go False = Mealy $ \_ _ -> \case
+      True -> pure (Event (), go True)
+      False -> pure (Tick, go False)
+
+
+duration :: forall eff a. Mealy eff a NominalDiffTime
+duration = mapAccumRequest go (Nothing @(UTCTime, NominalDiffTime)) (maybe 0 snd)
+  where
+    go :: Request -> Maybe (UTCTime, NominalDiffTime) -> a -> Maybe (UTCTime, NominalDiffTime)
+    go req Nothing _ = Just $ (requestTime req, requestTime req `diffUTCTime` requestTime req)
+    go req (Just (startTime, _)) _ = Just (startTime, requestTime req `diffUTCTime` startTime)

src/HomeAssistant/Controller.hs

@@ -19,13 +19,12 @@ module HomeAssistant.Controller
   , ruuviTemperatures
   , ruuviPressures
   , DoorState(..)
-  , door
   , light
-  , lightController
   , Presence(..)
   , presence
   , debug
   , traceEvent
+  , traceValue
   , switch
   , Target(..)
   ) where
@@ -71,6 +70,11 @@ traceEvent = Mealy $ \nt req -> \case
   Event a -> nt (Trace req a) >>= \() -> pure (Event a, traceEvent)
   Tick -> pure (Tick, traceEvent)
 
+traceValue :: Show a => HASS a a
+traceValue = proc x -> do
+  eff Trace -< x
+  returnA -< x
+
 ruuviTemperatures :: Mealy eff (Event Value) Double
 ruuviTemperatures = entityRead @Double "sensor.ruuvitag_b168_temperature" >>> hold 0
 
@@ -95,11 +99,6 @@ presence entityId =entityBool entityId
 
 
 
-door :: HASS (Event Value) (Event DoorState)
-door = entityBool "binary_sensor.makuuhuone_ovi_contact"
-  >>> arr (fmap (bool Closed Open))
-  >>> hold Open
-  >>> changes
 
 -- Turn off lights when door is closed
 light :: [Target] -> Bool -> Service
@@ -119,14 +118,6 @@ switch targets b = Service
   , serviceTarget=targets
   }
 
-lightController :: HASS (Event Value) (Event DoorState)
-lightController = proc ev -> do
-  doorState <- door -< ev
-  case doorState of
-       Event Open -> callService (light [EntityId "light.bedroom_masse"] False) -< ()
-       Event Closed -> callService (light [EntityId "light.bedroom_masse"] True) -< ()
-       _ -> returnA -< ()
-  returnA -< doorState
 
 entityChangeEvent :: T.Text -> Mealy eff (Event Value) (Event Value)
 entityChangeEvent entityId = entityChangeEvent' entityId >>> toEvent

src/HomeAssistant/Controller/Bedroom.hs

@@ -4,12 +4,14 @@ module HomeAssistant.Controller.Bedroom where
 
 import HomeAssistant.Controller
 import qualified Data.Text as T
-import AFRP (Event (..), (>>|), toEvent, lMerge)
+import AFRP (Event (..), (>>|), toEvent, 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
 
 
 
@@ -121,3 +123,33 @@ bedroomDrawerController = proc x -> do
        _ -> returnA -< ()
   where
     entity = EntityId "switch.bedroom_drawer_light_masse"
+
+door :: HASS (Event Value) (Event DoorState)
+door = entityBool "binary_sensor.makuuhuone_ovi_contact"
+  >>> arr (fmap (bool Closed Open))
+
+waitFor :: NominalDiffTime -> HASS a (Event ())
+waitFor n = duration >>> arr (> n) >>> edge
+
+delayedDoor :: HASS (Event Value) (Event DoorState)
+delayedDoor = door
+  >>> (AFRP.hold Open &&& AFRP.delayEvent 15)
+  >>> AFRP.sample
+  >>> traceEvent
+
+humidifierController :: HASS (Event Value) ()
+humidifierController = proc x -> do
+  st <- delayedDoor -< x
+  case st of
+       -- Turn the humidifier on when the door is closed
+       -- the humidifier is low-powered, no point in losing all the humidity
+       Event Open -> callService (humidifier False) -< ()
+       Event Closed -> callService (humidifier True) -< ()
+       _ -> returnA -< ()
+  where
+    humidifier state = Service
+      { serviceDomain="humidifier"
+      , serviceName= bool "turn_off" "turn_on" state
+      , serviceData= Nothing
+      , serviceTarget= [EntityId "humidifier.makuuhuone_ilmankostutin"]
+      }

src/HomeAssistant/Runtime.hs

@@ -25,8 +25,8 @@ import HomeAssistant.Runtime.Bus
 import HomeAssistant.Runtime.Connection (readerAction, writerAction)
 import HomeAssistant.Runtime.Supervisor (defaultBackoff, supervised)
 import Network.Socket (withSocketsDo)
-import System.Environment (getEnv)
+import System.Environment (getEnv, lookupEnv)
-import HomeAssistant.Controller.Bedroom (bedroomPresenceController, bedroomButtonController, bedroomDrawerController)
+import HomeAssistant.Controller.Bedroom (bedroomPresenceController, bedroomButtonController, bedroomDrawerController, humidifierController)
 import Data.UUID (UUID, toText)
 import qualified Data.UUID.V4 as UUID.V4
 import Katip (runKatipT, logF, sl, Severity (..), ls, Namespace (Namespace), runKatipContextT)
@@ -45,6 +45,7 @@ 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
   ]
 
 -- | Steps the machine for every inbound message; service calls go to the
@@ -63,16 +64,18 @@ runController bus (Controller name machine _enabled) = do
       go inbound f'
 
 defaultMain :: IO ()
-defaultMain = withSocketsDo $ withBus $ \bus -> do
+defaultMain = withSocketsDo $ do
-  token <- getEnv "HA_TOKEN"
+  severity <- maybe InfoS (const DebugS) <$> lookupEnv "HA_DEBUG"
-  host <- getEnv "HA_HOST"
+  withBus severity $ \bus -> do
-  let workers =
+    token <- getEnv "HA_TOKEN"
-        [ ("reader", readerAction host 8123 token bus)
+    host <- getEnv "HA_HOST"
-        , ("writer", writerAction bus)
+    let workers =
-        ] ++ [ (name, runController bus c) | c@(Controller name _ True) <- controllers ]
+          [ ("reader", readerAction host 8123 token bus)
-  as <- mapM (\(name, act) -> async (supervised name defaultBackoff act)) workers
+          , ("writer", writerAction bus)
-  (_, v) <- waitAny as
+          ] ++ [ (name, runController bus c) | c@(Controller name _ True) <- controllers ]
-  absurd v
+    as <- mapM (\(name, act) -> async (supervised name defaultBackoff act)) workers
+    (_, v) <- waitAny as
+    absurd v
 
 dryRunHassEval :: Namespace -> Bus -> HASSEff a -> IO a
 dryRunHassEval ns bus = \case

src/HomeAssistant/Runtime/Bus.hs

@@ -40,9 +40,9 @@ data Bus = Bus
   , busLogEnv   :: LogEnv
   }
 
-withBus :: (Bus -> IO a) -> IO a
+withBus :: Severity -> (Bus -> IO a) -> IO a
-withBus callback = do
+withBus severity callback = do
-  handleScribe <- mkHandleScribe ColorIfTerminal stdout (permitItem DebugS) V2
+  handleScribe <- mkHandleScribe ColorIfTerminal stdout (permitItem severity) V2
   let makeLogEnv = registerScribe "stdout" handleScribe defaultScribeSettings =<< initLogEnv "hass-controller" "production"
   -- closeScribes will stop accepting new logs, flush existing ones and clean up resources
   bracket makeLogEnv closeScribes $ \le -> do

test/BusSpec.hs

@@ -14,12 +14,12 @@ import Data.Time (UTCTime (..))
 import Data.UUID (nil)
 import HomeAssistant.Controller (HASSEff (..), Service (..), Target(..))
 import HomeAssistant.Runtime.Bus
-import Katip (Namespace (Namespace), runKatipContextT)
+import Katip (Namespace (Namespace), runKatipContextT, Severity (..))
 import Test.Hspec
 
 spec :: Spec
 spec = describe "Bus" $ do
-  it "broadcasts inbound messages to every dup'd channel in order" $ withBus $ \bus -> do
+  it "broadcasts inbound messages to every dup'd channel in order" $ withBus InfoS $ \bus -> do
     p1 <- atomically $ dupTChan (busInbound bus)
     p2 <- atomically $ dupTChan (busInbound bus)
     atomically $ writeTChan (busInbound bus) (Number 1)
@@ -29,7 +29,7 @@ spec = describe "Bus" $ do
     r1 `shouldBe` (Number 1, Number 2)
     r2 `shouldBe` (Number 1, Number 2)
 
-  it "channelHassEval writes CallService to the outbound channel" $ withBus $ \bus -> do
+  it "channelHassEval writes CallService to the outbound channel" $ withBus InfoS $ \bus -> do
     let req = Request (UTCTime (toEnum 0) 0) nil
         svc = Service "light" "turn_on" Nothing [EntityId "light.bedroom_masse"]
     runKatipContextT (busLogEnv bus) () (Namespace ["test"]) $

test/RuntimeSpec.hs

@@ -10,10 +10,11 @@ import HomeAssistant.Controller (light, lightController, Target (..))
 import HomeAssistant.Runtime (Controller (..), runController)
 import HomeAssistant.Runtime.Bus
 import Test.Hspec
+import Katip (Severity(..))
 
 spec :: Spec
 spec = describe "runController" $ do
-  it "feeds inbound events through the machine and forwards service calls" $ withBus $ \bus -> do
+  it "feeds inbound events through the machine and forwards service calls" $ withBus InfoS $ \bus -> do
     _ <- async (runController bus (Controller "test" lightController True))
     putStrLn "Before the delay"
     threadDelay 100000 -- let the controller dup its inbound channel