Explicit state

src/HomeAssistant/Controller.hs

@@ -27,7 +27,7 @@ module HomeAssistant.Controller
   , Light(..)
   ) where
 
-import AFRP (Mealy (..), Pair (..), eff, Event(..), events, filterA, (>>|), toEvent, Request)
+import AFRP (Mealy (..), eff, Event(..), events, filterA, (>>|), toEvent, Request)
 import Control.Arrow (Arrow(..), returnA)
 import Control.Category ((>>>))
 import Data.Aeson (Value, object, (.=))
@@ -37,6 +37,8 @@ import Control.Lens (has, only, (^?), to)
 import Data.Aeson.Lens (key, _String, _Integral)
 import qualified Data.Text.Lens as TL
 import Data.Bool (bool)
+import Data.Serialize (Serialize)
+import GHC.Generics (Generic)
 
 data Target = EntityId !T.Text | AreaId !T.Text
   deriving (Show,Eq,Ord)
@@ -65,11 +67,11 @@ debug = proc x -> do
   returnA -< x
 
 traceEvent :: Show a => HASS (Event a) (Event a)
-traceEvent = m
-  where
-    m = Mealy mempty $ \nt req -> \case
-      Event a -> nt (Trace req a) >>= \() -> pure (Pair (Event a) m)
-      Tick -> pure (Pair Tick m)
+traceEvent = proc ev -> do
+  case ev of
+       Event a -> eff Trace -< a
+       Tick -> returnA -< ()
+  returnA -< ev
 
 traceValue :: Show a => HASS a a
 traceValue = proc x -> do
@@ -77,7 +79,9 @@ traceValue = proc x -> do
   returnA -< x
 
 data DoorState = Open | Closed
-  deriving (Show, Eq)
+  deriving (Show, Eq, Generic)
+
+instance Serialize DoorState
 
 data Presence = Occupied | Unoccupied
   deriving (Show, Eq)

src/HomeAssistant/Controller/Ruuvi.hs

@@ -13,6 +13,8 @@ import Control.Category ((>>>))
 import Data.Aeson (Value)
 import HomeAssistant.Controller (entityRead, traceEvent, HASS)
 import Control.Arrow (Arrow(..))
+import GHC.Generics (Generic)
+import Data.Serialize (Serialize)
 
 ruuviTemperatures :: Mealy eff (Event Value) Double
 ruuviTemperatures = entityRead @Double "sensor.ruuvitag_b168_temperature" >>> hold 0
@@ -21,7 +23,9 @@ ruuviPressures :: Mealy eff (Event Value) Double
 ruuviPressures = entityRead "sensor.ruuvitag_b168_pressure" >>> hold 0
 
 data Ruuvi = Ruuvi { ruuviTemperature :: Double, ruuviPressure :: Double }
-            deriving (Show, Eq)
+            deriving (Show, Eq, Generic)
+
+instance Serialize Ruuvi
 
 ruuvi :: Mealy eff (Event Value) (Event Ruuvi)
 ruuvi = (Ruuvi <$> ruuviTemperatures <*> ruuviPressures) >>> changes

src/HomeAssistant/Runtime.hs

@@ -13,7 +13,7 @@ module HomeAssistant.Runtime
   , runController
   ) where
 
-import AFRP (Event (..), Mealy (..), Pair (..), Request (..))
+import AFRP (Event (..), Mealy (..), Request (..), Auto, stepAutoSerializing)
 import Control.Concurrent.Async (async, waitAny)
 import Control.Concurrent.STM (atomically, dupTChan, readTChan)
 import Data.Aeson (Value)
@@ -31,18 +31,19 @@ import Data.UUID (UUID, toText)
 import qualified Data.UUID.V4 as UUID.V4
 import Katip (runKatipT, logF, sl, Severity (..), ls, Namespace (Namespace), runKatipContextT)
 import Control.Monad.IO.Class (liftIO, MonadIO)
-import Control.Monad.Fix (MonadFix)
 import HomeAssistant.Controller.Ruuvi (ruuviController)
 import HomeAssistant.Controller.Children (schoolLightController)
 import Data.Maybe (fromMaybe)
 import qualified System.Metrics
 import qualified HomeAssistant.Runtime.Metrics
+import System.FilePath ((</>))
 
-step :: (MonadFix m, MonadIO m) => (forall x. eff x -> m x) -> UUID -> Mealy eff a b -> a -> m (Pair b (Mealy eff a b))
-step nt trace (Mealy _ f) a = do
+step :: (MonadIO m) => FilePath -> UUID -> Auto m a b -> a -> m (b, Auto m a b)
+step path trace st a = do
   now <- liftIO getCurrentTime
   tz <- liftIO getCurrentTimeZone
-  f nt (Request now tz trace) a
+  let req = Request now tz trace
+  stepAutoSerializing path st req a
 
 data Controller = forall b. Controller T.Text (HASS (Event Value) b) Bool
 
@@ -59,17 +60,19 @@ controllers =
 -- | Steps the machine for every inbound message; service calls go to the
 -- bus. A restart re-dups the inbound channel and starts from the machine's
 -- initial state; messages broadcast during the restart window are lost.
-runController :: Bus -> Controller -> IO Void
-runController bus (Controller name machine _enabled) = do
+runController :: FilePath -> Bus -> Controller -> IO Void
+runController rootDir bus (Controller name machine _enabled) = do
   inbound <- atomically (dupTChan (busInbound bus))
-  go inbound machine
+  let ns = Namespace [name]
+  let worker = runMealy machine (runKatipContextT (busLogEnv bus) () ns . channelHassEval bus)
+  let path  = rootDir </> T.unpack name
+  go path inbound worker
   where
-    go inbound f = do
+    go path inbound f = do
       msg <- atomically (readTChan inbound)
       uuid <- UUID.V4.nextRandom
-      let ns = Namespace [name]
-      Pair _ f' <- step (runKatipContextT (busLogEnv bus) () ns . channelHassEval bus) uuid f msg
-      go inbound f'
+      (_, next) <- step path uuid f msg
+      go path inbound next
 
 defaultMain :: IO ()
 defaultMain = withSocketsDo $ do
@@ -77,6 +80,7 @@ defaultMain = withSocketsDo $ do
   withBus severity $ \bus -> do
     token <- getEnv "HA_TOKEN"
     host <- getEnv "HA_HOST"
+    rootPath <- fromMaybe "/tmp/" <$> lookupEnv "HA_LIB_DIR"
     store <- System.Metrics.newStore
     System.Metrics.registerGcMetrics store
     rrdPath <- fromMaybe "hass-controller.rrd" <$> lookupEnv "HA_RRD_PATH"
@@ -86,7 +90,7 @@ defaultMain = withSocketsDo $ do
         workers =
           [ ("reader", readerAction host 8123 token ents bus)
           , ("writer", writerAction bus)
-          ] ++ [ (name, runController bus c) | c@(Controller name _ True) <- controllers ]
+          ] ++ [ (name, runController rootPath bus c) | c@(Controller name _ True) <- controllers ]
             ++ [("metrics", HomeAssistant.Runtime.Metrics.metricsAction store rrdPath rrdtool)]
     as <- mapM (\(name, act) -> async (supervised name defaultBackoff act)) workers
     (_, v) <- waitAny as