Explicit state

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