MasseR/home-assistant-controller
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Control the kitchen lights

Browse Source
This commit is contained in:
MasseR
2026-09-14 14:45:45 +03:00
parent aaba917a9b
commit 0f7c6ff98a
9 changed files with 167 additions and 33 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/AFRP.hs
+56 -16
View File
@@ -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 ()
Stateful Codec{putter} s _ -> runPut $ putter (state s)
Fun _ -> CC.sourcePut (put ())
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} _ ->
utcToLocalTime requestTimeZone requestTime
currentTime = Mealy mempty $ \_nt -> Fun $ \req _ ->
requestLocalTime req
stepAuto :: Monad m => Auto m a b -> Request -> a -> m (b, Auto m a b)
src/HomeAssistant/Controller.hs
+7 -1
View File
@@ -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
+1 -1
View File
@@ -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
+59
View File
@@ -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
+8 -3
View File
@@ -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