Merge branch 'mem-leak'

- Tuple to strict pair
- Self-recursive loops with more knot tying <- this was the thing

default.nix

@@ -1,6 +1,7 @@
 { mkDerivation, aeson, annotated-exception, async, base, bytestring
-, containers, hedgehog, hspec, hspec-hedgehog, katip, lens
+, containers, directory, ekg-core, hedgehog, hspec, hspec-hedgehog
-, lens-aeson, lib, network, stm, text, time, uuid, websockets
+, katip, lens, lens-aeson, lib, network, process, stm, text, time
+, unordered-containers, uuid, websockets
 }:
 mkDerivation {
   pname = "home-assistant-controller";
@@ -9,13 +10,15 @@ mkDerivation {
   isLibrary = true;
   isExecutable = true;
   libraryHaskellDepends = [
-    aeson annotated-exception async base bytestring containers katip
+    aeson annotated-exception async base bytestring containers
-    lens lens-aeson network stm text time uuid websockets
+    directory ekg-core katip lens lens-aeson network process stm text
+    time unordered-containers uuid websockets
   ];
   executableHaskellDepends = [ base ];
   testHaskellDepends = [
-    aeson annotated-exception async base containers hedgehog hspec
+    aeson annotated-exception async base containers directory ekg-core
-    hspec-hedgehog katip stm text time uuid
+    hedgehog hspec hspec-hedgehog katip process stm text time
+    unordered-containers uuid
   ];
   license = lib.meta.getLicenseFromSpdxId "BSD-3-Clause";
   mainProgram = "home-assistant-controller";

flake.nix

@@ -20,7 +20,15 @@
       });
     });
     in rec {
-      packages.home-assistant-controller = pkgs.haskell.lib.justStaticExecutables hp.home-assistant-controller;
+      packages.home-assistant-controller = pkgs.symlinkJoin {
+        name = "home-assistant-controller";
+        paths = [ (pkgs.haskell.lib.justStaticExecutables hp.home-assistant-controller) ];
+        nativeBuildInputs = [ pkgs.makeWrapper ];
+        postBuild = ''
+          wrapProgram $out/bin/home-assistant-controller \
+            --set HA_RRDTOOL ${pkgs.lib.getBin pkgs.rrdtool}/bin/rrdtool
+        '';
+      };
       defaultPackage = packages.home-assistant-controller;
       devShell = hp.shellFor {
         packages = h: [h.home-assistant-controller];
@@ -34,6 +42,8 @@
           hp.graphmod
 
           hp.haskell-language-server
+
+          rrdtool
         ];
       };
     }

home-assistant-controller.cabal

@@ -67,6 +67,7 @@ library
                     , HomeAssistant.Runtime
                     , HomeAssistant.Runtime.Bus
                     , HomeAssistant.Runtime.Connection
+                    , HomeAssistant.Runtime.Metrics
                     , HomeAssistant.Runtime.Supervisor
 
     -- Modules included in this library but not exported.
@@ -91,6 +92,10 @@ library
                     , uuid
                     , katip
                     , containers
+                    , ekg-core
+                    , unordered-containers
+                    , process
+                    , directory
 
     -- Directories containing source files.
     hs-source-dirs:   src
@@ -121,7 +126,7 @@ executable home-assistant-controller
 
     -- Base language which the package is written in.
     default-language: GHC2024
-    ghc-options: -threaded
+    ghc-options: -threaded -with-rtsopts=-T
 
 test-suite home-assistant-controller-test
     -- Import common warning flags.
@@ -136,6 +141,7 @@ test-suite home-assistant-controller-test
                     , BedroomSpec
                     , BusSpec
                     , ConnectionSpec
+                    , MetricsSpec
                     , RuntimeSpec
                     , SupervisorSpec
                     , Support
@@ -167,4 +173,8 @@ test-suite home-assistant-controller-test
         time,
         uuid,
         katip,
-        containers
+        containers,
+        ekg-core,
+        unordered-containers,
+        process,
+        directory

src/AFRP.hs

@@ -20,6 +20,7 @@ module AFRP
   , (>>|)
   , toEvent
   , lMerge
+  , Pair(..)
   , Request(..)
   , edge
   , dropFirst
@@ -48,6 +49,8 @@ import Data.UUID (UUID)
 import qualified Data.Set as S
 import qualified Data.Text as T
 
+data Pair a b = Pair !a !b
+
 data Request = Request
   { requestTime :: !UTCTime
   , requestTimeZone :: !TimeZone
@@ -59,23 +62,27 @@ data Request = Request
 -- trigger subscriptions.
 data Mealy eff a b = Mealy
   { entities :: S.Set T.Text
-  , runMealy :: forall m. MonadFix m => (forall x. eff x -> m x) -> Request -> a -> m (b, Mealy eff a b)
+  , runMealy :: forall m. MonadFix m => (forall x. eff x -> m x) -> Request -> a -> m (Pair b (Mealy eff a b))
   }
 
 
 instance Semigroup b => Semigroup (Mealy eff a b) where
   Mealy ast af <> Mealy bst bf = Mealy (ast <> bst) $ \nt r a -> do
-    (x, af') <- af nt r a
+    Pair x af' <- af nt r a
-    (x', bf') <- bf nt r a
+    Pair x' bf' <- bf nt r a
-    pure (x <> x', af' <> bf')
+    pure (Pair (x <> x') (af' <> bf'))
 
 
 instance Monoid b => Monoid (Mealy eff a b) where
-  mempty = Mealy mempty $ \_ _ _ -> pure (mempty, mempty)
+  mempty = m
+    where
+      m = Mealy mempty $ \_ _ _ -> pure (Pair mempty m)
 
 eff :: (Request -> a -> eff b) -> Mealy eff a b
-eff f = Mealy mempty $ \nt req x ->
+eff f = m
-  nt (f req x) >>= \b -> pure (b, eff f)
+  where
+    m = Mealy mempty $ \nt req x ->
+      nt (f req x) >>= \b -> pure (Pair b m)
 
 -- | Override the static entity set of an arrow. Use when a combinator
 -- (e.g. 'switch') hides continuation entities from the runtime's
@@ -84,41 +91,48 @@ withEntities :: S.Set T.Text -> Mealy eff a b -> Mealy eff a b
 withEntities es (Mealy _ f) = Mealy es f
 
 instance Category (Mealy eff) where
-  id = Mealy mempty (\_ _ x -> pure (x, id))
+  id = Mealy mempty (\_ _ x -> pure (Pair x id))
   (Mealy ast f) . (Mealy bst g) = Mealy (ast <> bst) $ \nt t a -> do
-    (b, g') <- g nt t a
+    Pair b g' <- g nt t a
-    (c, f') <- f nt t b
+    Pair c f' <- f nt t b
-    pure (c, f' . g')
+    pure (Pair c (f' . g'))
 
 instance Arrow (Mealy eff) where
-  arr f = Mealy mempty $ \_ _ b -> pure (f b, arr f)
+  arr f = mealy
+    where
+      mealy = Mealy mempty $ \_ _ b -> pure (Pair (f b) mealy)
   first (Mealy st f) = Mealy st $ \nt t (b,d) -> do
-    (c, f') <- f nt t b
+    Pair c f' <- f nt t b
-    pure ((c, d), first f')
+    pure (Pair (c, d) (first f'))
 
 instance ArrowChoice (Mealy eff) where
-  left m@(Mealy st f) = Mealy st $ \nt t -> \case
+  left (Mealy st f) = lm
-    Left b -> do
+    where
-      (c, f') <- f nt t b
+      lm = Mealy st $ \nt t -> \case
-      pure (Left c, left f')
+        Left b -> do
-    Right d -> pure (Right d, left m)
+          Pair c f' <- f nt t b
+          pure (Pair (Left c) (left f'))
+        Right d -> pure (Pair (Right d) lm)
 
-instance ArrowLoop (Mealy eff) where
+-- ArrowLoop is incompatible with strict Pair (strict fields prevent
-  loop (Mealy st f) = Mealy st $ \nt t b -> do
+-- the lazy knot-tying that mfix requires with loop).
-    ((c,_), f') <- mfix $ \((_,d), _) -> f nt t (b,d)
+-- instance ArrowLoop (Mealy eff) where
-    pure (c, loop f')
+--   loop (Mealy st f) = Mealy st $ \nt t b -> do
+--     Pair (c,_) f' <- mfix $ \(Pair (_,d) _) -> f nt t (b,d)
+--     pure (Pair c (loop f'))
 
 instance Functor (Mealy eff a) where
   fmap f (Mealy st g) = Mealy st $ \nt t a -> do
-    (b, g') <- g nt t a
+    Pair b g' <- g nt t a
-    pure (f b, fmap f g')
+    pure (Pair (f b) (fmap f g'))
 
 instance Applicative (Mealy eff a) where
-  pure b = Mealy mempty $ \_ _ _ -> pure (b, pure b)
+  pure b = Mealy mempty $ \_ _ _ -> pure (Pair b (pure b))
   Mealy ast f <*> Mealy bst x = Mealy (ast <> bst) $ \nt t a -> do
-    (f', fNext) <- f nt t a
+    b' <- x nt t a
-    (x', xNext) <- x nt t a
+    let Pair x' xNext = b'
-    pure (f' x', fNext <*> xNext)
+    Pair f' fNext <- f nt t a
+    pure (Pair (f' x') (fNext <*> xNext))
 
 data Event a
   = Tick
@@ -133,8 +147,8 @@ instance Monoid (Event a) where
 
 hold :: a -> Mealy eff (Event a) a
 hold a = Mealy mempty $ \_ _ -> \case
-  Tick -> pure (a, hold a)
+  Tick -> pure (Pair a (hold a))
-  Event a' -> pure (a', hold a')
+  Event a' -> pure (Pair a' (hold a'))
 
 events :: Mealy eff (Event a) (Either () a)
 events = arr $ \case
@@ -150,9 +164,9 @@ tag b ev = b <$ ev
 
 switch :: Mealy eff a (b, Event c) -> (c -> Mealy eff a b) -> Mealy eff a b
 switch (Mealy st f) s = Mealy st $ \nt t a -> do
-  ((b, ev), f') <- f nt t a
+  Pair (b, ev) f' <- f nt t a
   case ev of
-          Tick -> pure (b, switch f' s)
+          Tick -> pure (Pair b (switch f' s))
           Event x -> runMealy (s x) nt t a
 
 sample :: Mealy eff (a, Event b) (Event a)
@@ -163,28 +177,28 @@ preMapAccum f x extract = go x
   where
     go b = Mealy mempty $ \_ _ a ->
       let next = f b a
-      in pure (extract b, go next)
+      in pure (Pair (extract b) (go next))
 
 preMapAccumRequest :: (Request -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
 preMapAccumRequest f x extract = go x
   where
     go b = Mealy mempty $ \_ t a ->
       let next = f t b a
-      in pure (extract b, go next)
+      in pure (Pair (extract b) (go next))
 
 mapAccum :: (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
 mapAccum f x extract = go x
   where
     go b = Mealy mempty $ \_ _ a ->
       let next = f b a
-      in pure (extract next, go next)
+      in pure (Pair (extract next) (go next))
 
 mapAccumRequest :: (Request -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
 mapAccumRequest f x extract = go x
   where
     go b = Mealy mempty $ \_ t a ->
       let next = f t b a
-      in pure (extract next, go next)
+      in pure (Pair (extract next) (go next))
 
 data DelayState x a = DelayState
   { pending :: x
@@ -265,11 +279,11 @@ edge :: Mealy eff Bool (Event ())
 edge = go False
   where
     go True = Mealy mempty $ \_ _ -> \case
-      True -> pure (Tick, go True)
+      True -> pure (Pair Tick (go True))
-      False -> pure (Tick, go False)
+      False -> pure (Pair Tick (go False))
     go False = Mealy mempty $ \_ _ -> \case
-      True -> pure (Event (), go True)
+      True -> pure (Pair (Event ()) (go True))
-      False -> pure (Tick, go False)
+      False -> pure (Pair Tick (go False))
 
 
 -- | Drop the first 'Event' and pass through everything after. Useful for
@@ -280,8 +294,8 @@ dropFirst = go False
   where
     go seen = Mealy mempty $ \_ _ input ->
       case input of
-        Event _ | not seen -> pure (Tick, go True)
+        Event _ | not seen -> pure (Pair Tick (go True))
-        _ -> pure (input, go seen)
+        _ -> pure (Pair input (go seen))
 
 
 duration :: forall eff a. Mealy eff a NominalDiffTime
@@ -340,7 +354,7 @@ fixed seconds = mapAccumRequest go Nothing (maybe [] ((`appEndo` []) . snd))
 
 currentTime :: Mealy eff a LocalTime
 currentTime = Mealy mempty $ \_ Request{requestTime, requestTimeZone} _ ->
-  pure (utcToLocalTime requestTimeZone requestTime, currentTime)
+  pure (Pair (utcToLocalTime requestTimeZone requestTime) currentTime)
 
 
 onEvent :: Mealy eff a () -> Mealy eff (Event a) ()

src/HomeAssistant/Controller.hs

@@ -27,7 +27,7 @@ module HomeAssistant.Controller
   , Light(..)
   ) where
 
-import AFRP (Mealy (..), eff, Event(..), events, filterA, (>>|), toEvent, Request)
+import AFRP (Mealy (..), Pair (..), eff, Event(..), events, filterA, (>>|), toEvent, Request)
 import Control.Arrow (Arrow(..), returnA)
 import Control.Category ((>>>))
 import Data.Aeson (Value, object, (.=))
@@ -65,9 +65,11 @@ debug = proc x -> do
   returnA -< x
 
 traceEvent :: Show a => HASS (Event a) (Event a)
-traceEvent = Mealy mempty $ \nt req -> \case
+traceEvent = m
-  Event a -> nt (Trace req a) >>= \() -> pure (Event a, traceEvent)
+  where
-  Tick -> pure (Tick, traceEvent)
+    m = Mealy mempty $ \nt req -> \case
+      Event a -> nt (Trace req a) >>= \() -> pure (Pair (Event a) m)
+      Tick -> pure (Pair Tick m)
 
 traceValue :: Show a => HASS a a
 traceValue = proc x -> do

src/HomeAssistant/Runtime.hs

@@ -13,7 +13,7 @@ module HomeAssistant.Runtime
   , runController
   ) where
 
-import AFRP (Event (..), Mealy (..), Request (..))
+import AFRP (Event (..), Mealy (..), Pair (..), Request (..))
 import Control.Concurrent.Async (async, waitAny)
 import Control.Concurrent.STM (atomically, dupTChan, readTChan)
 import Data.Aeson (Value)
@@ -34,8 +34,11 @@ 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
 
-step :: (MonadFix m, MonadIO m) => (forall x. eff x -> m x) -> UUID -> Mealy eff a b -> a -> m (b, Mealy eff a b)
+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
   now <- liftIO getCurrentTime
   tz <- liftIO getCurrentTimeZone
@@ -65,7 +68,7 @@ runController bus (Controller name machine _enabled) = do
       msg <- atomically (readTChan inbound)
       uuid <- UUID.V4.nextRandom
       let ns = Namespace [name]
-      (_, f') <- step (runKatipContextT (busLogEnv bus) () ns . channelHassEval bus) uuid f msg
+      Pair _ f' <- step (runKatipContextT (busLogEnv bus) () ns . channelHassEval bus) uuid f msg
       go inbound f'
 
 defaultMain :: IO ()
@@ -74,12 +77,17 @@ defaultMain = withSocketsDo $ do
   withBus severity $ \bus -> do
     token <- getEnv "HA_TOKEN"
     host <- getEnv "HA_HOST"
+    store <- System.Metrics.newStore
+    System.Metrics.registerGcMetrics store
+    rrdPath <- fromMaybe "hass-controller.rrd" <$> lookupEnv "HA_RRD_PATH"
+    rrdtool <- fromMaybe "rrdtool" <$> lookupEnv "HA_RRDTOOL"
     let active = [c | c@(Controller _ _ True) <- controllers]
         ents = foldMap (\(Controller _ m _) -> entities m) active
         workers =
           [ ("reader", readerAction host 8123 token ents bus)
           , ("writer", writerAction bus)
           ] ++ [ (name, runController 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
     absurd v

src/HomeAssistant/Runtime/Connection.hs

@@ -91,7 +91,7 @@ subscribe bus conn ents =
 -- even when no state changes arrive.
 receiveLoop :: Bus -> WS.Connection -> IO Void
 receiveLoop bus conn = forever $ do
-  winner <- race (threadDelay 1000000) (WS.receiveData conn)
+  winner <- race (threadDelay 1_000_000) (WS.receiveData conn)
   case winner of
     Left () -> atomically $ writeTChan (busInbound bus) Tick
     Right msg -> case eitherDecode msg of

src/HomeAssistant/Runtime/Metrics.hs

@@ -0,0 +1,119 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module HomeAssistant.Runtime.Metrics
+  ( DsType (..)
+  , DsSpec (..)
+  , dsTypeOf
+  , sanitizeName
+  , buildSchema
+  , buildCreateArgs
+  , buildUpdateArgs
+  , ensureRrd
+  , sampleAndUpdate
+  , metricsAction
+  ) where
+
+import Control.Concurrent (threadDelay)
+import Control.Monad (forever, unless)
+import Data.Char (ord)
+import Data.Int (Int64)
+import Data.List (intercalate, sortBy)
+import Data.Ord (comparing)
+import Data.Text (Text)
+import Data.Void (Void)
+import Numeric (showHex)
+import qualified Data.Text as T
+import qualified Data.HashMap.Strict as HM
+import qualified System.Metrics as M (Value (..), Sample, Store, sampleAll)
+import System.Directory (doesFileExist)
+import System.Process (callProcess)
+
+data DsType = Derive | Gauge
+  deriving (Eq, Show)
+
+data DsSpec = DsSpec
+  { dsEkgName :: Text
+  , dsName    :: String
+  , dsType    :: DsType
+  }
+  deriving (Eq, Show)
+
+dsTypeOf :: M.Value -> Maybe DsType
+dsTypeOf (M.Counter _) = Just Derive
+dsTypeOf (M.Gauge _)   = Just Gauge
+dsTypeOf _             = Nothing
+
+-- | Maps an ekg metric label to a valid rrd DS name (≤19 chars, [A-Za-z0-9_]).
+-- Long names keep the first 15 chars plus a 3-hex hash suffix for uniqueness.
+sanitizeName :: Text -> String
+sanitizeName name
+  | length sanitized <= 19 = sanitized
+  | otherwise = take 15 sanitized ++ "_" ++ paddedHash
+  where
+    sanitized = T.unpack (T.replace "." "_" name)
+    paddedHash = let h = showHex (sum (map ord sanitized) `mod` 4096) ""
+                 in replicate (3 - length h) '0' ++ h
+
+buildSchema :: M.Sample -> [DsSpec]
+buildSchema sample =
+  sortBy (comparing dsName)
+    [ DsSpec ekgName (sanitizeName ekgName) dt
+    | (ekgName, val) <- HM.toList sample
+    , Just dt <- [dsTypeOf val]
+    ]
+
+buildCreateArgs :: FilePath -> Int -> [(String, DsType)] -> [String]
+buildCreateArgs path step specs =
+  ["create", path, "--step", show step]
+  ++ concatMap dsArg specs
+  ++ rras
+  where
+    dsArg (name, Derive) = ["DS:" ++ name ++ ":DERIVE:20:0:U"]
+    dsArg (name, Gauge)  = ["DS:" ++ name ++ ":GAUGE:20:0:U"]
+    rras =
+      [ "RRA:AVERAGE:0.5:1:6000"
+      , "RRA:MAX:0.5:1:6000"
+      , "RRA:AVERAGE:0.5:360:1680"
+      , "RRA:MAX:0.5:360:1680"
+      ]
+
+buildUpdateArgs :: FilePath -> [String] -> [Maybe Int64] -> [String]
+buildUpdateArgs path names values =
+  [ "update"
+  , path
+  , "--template"
+  , intercalate ":" names
+  , "N:" ++ intercalate ":" (map renderValue values)
+  ]
+  where
+    renderValue Nothing  = "U"
+    renderValue (Just n) = show n
+
+lookupValue :: M.Sample -> Text -> Maybe Int64
+lookupValue sample name = case HM.lookup name sample of
+  Just (M.Counter n) -> Just n
+  Just (M.Gauge n)   -> Just n
+  _                  -> Nothing
+
+ensureRrd :: FilePath -> FilePath -> [DsSpec] -> IO ()
+ensureRrd rrdtool rrdPath schema = do
+  exists <- doesFileExist rrdPath
+  unless exists $
+    callProcess rrdtool (buildCreateArgs rrdPath 10 (map toPair schema))
+  where
+    toPair s = (dsName s, dsType s)
+
+sampleAndUpdate :: M.Store -> FilePath -> FilePath -> [DsSpec] -> IO ()
+sampleAndUpdate store rrdtool rrdPath schema = do
+  sample <- M.sampleAll store
+  let names = map dsName schema
+      values = map (lookupValue sample . dsEkgName) schema
+  callProcess rrdtool (buildUpdateArgs rrdPath names values)
+
+metricsAction :: M.Store -> FilePath -> FilePath -> IO Void
+metricsAction store rrdPath rrdtool = do
+  schema <- buildSchema <$> M.sampleAll store
+  ensureRrd rrdtool rrdPath schema
+  forever $ do
+    sampleAndUpdate store rrdtool rrdPath schema
+    threadDelay 10000000

test/AFRPSpec.hs

@@ -28,14 +28,14 @@ sec n = UTCTime (toEnum 0) (fromIntegral n)
 runPure :: Mealy Identity a b -> [a] -> [b]
 runPure _ [] = []
 runPure m (a : as) = case runIdentity (AFRP.runMealy m id fakeRequest a) of
-  (b, m') -> b : runPure m' as
+  Pair b m' -> b : runPure m' as
 
 -- | Run a Mealy with a per-step wall clock (seconds since the day-0 epoch).
 runTimed :: Mealy Identity a b -> [(Integer, a)] -> [b]
 runTimed _ [] = []
 runTimed m ((s, a) : as) =
   case runIdentity (AFRP.runMealy m id (Request (sec s) utc nil) a) of
-    (b, m') -> b : runTimed m' as
+    Pair b m' -> b : runTimed m' as
 
 -- | A minimal State monad for observing effectful arrows (e.g. whenA gating).
 newtype St a = St { unSt :: Int -> (a, Int) }
@@ -59,7 +59,7 @@ runStEff m s0 as = go m s0 as
     go _ s [] = ([], s)
     go m' s (a : rest) =
       case unSt (AFRP.runMealy m' id fakeRequest a) s of
-        ((b, m''), s') -> let (bs, s'') = go m'' s' rest in (b : bs, s'')
+        (Pair b m'', s') -> let (bs, s'') = go m'' s' rest in (b : bs, s'')
 
 spec :: Spec
 spec = describe "AFRP" $ do
@@ -569,11 +569,11 @@ sampleSpec = describe "sample" $ do
 
 -- | A stateless arrow carrying a fixed entity set, for testing propagation.
 subscribed :: S.Set T.Text -> Mealy Identity Int Int
-subscribed ents = Mealy ents $ \_ _ a -> pure (a, subscribed ents)
+subscribed ents = Mealy ents $ \_ _ a -> pure (Pair a (subscribed ents))
 
 -- | Same as 'subscribed' but yields a function, for testing '<*>'.
 subscribedF :: S.Set T.Text -> Mealy Identity Int (Int -> Int)
-subscribedF ents = Mealy ents $ \_ _ a -> pure ((a +), subscribedF ents)
+subscribedF ents = Mealy ents $ \_ _ a -> pure (Pair (a +) (subscribedF ents))
 
 entitiesSpec :: Spec
 entitiesSpec = describe "entities" $ do

test/Main.hs

@@ -6,6 +6,7 @@ import qualified BackoffProp
 import qualified BedroomSpec
 import qualified BusSpec
 import qualified ConnectionSpec
+import qualified MetricsSpec
 import qualified RuntimeSpec
 import qualified SupervisorSpec
 
@@ -15,6 +16,7 @@ main = hspec $ do
   BedroomSpec.spec
   BusSpec.spec
   ConnectionSpec.spec
+  MetricsSpec.spec
   RuntimeSpec.spec
   SupervisorSpec.spec
   BackoffProp.spec

test/MetricsSpec.hs

@@ -0,0 +1,150 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module MetricsSpec (spec) where
+
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HM
+import Data.Int (Int64)
+import Data.Text (Text)
+import HomeAssistant.Runtime.Metrics
+  ( DsType (..)
+  , DsSpec (..)
+  , dsTypeOf
+  , sanitizeName
+  , buildSchema
+  , buildCreateArgs
+  , buildUpdateArgs
+  , ensureRrd
+  , sampleAndUpdate
+  , metricsAction
+  )
+import qualified System.Metrics as M (Value (..))
+import Test.Hspec
+import Control.Exception (try, SomeException)
+import System.Directory (findExecutable, getTemporaryDirectory, removeFile)
+import System.Exit (ExitCode (ExitSuccess))
+import System.Process (readProcessWithExitCode)
+import qualified System.Metrics as Metrics
+import qualified System.Metrics.Counter as Counter
+import qualified System.Metrics.Gauge as Gauge
+
+spec :: Spec
+spec = do
+  describe "dsTypeOf" $ do
+    it "maps Counter to Derive" $
+      dsTypeOf (M.Counter 1000) `shouldBe` Just Derive
+
+    it "maps Gauge to Gauge" $
+      dsTypeOf (M.Gauge 500) `shouldBe` Just Gauge
+
+    it "maps Label to Nothing" $
+      dsTypeOf (M.Label "hello") `shouldBe` Nothing
+
+  describe "sanitizeName" $ do
+    it "replaces dots with underscores for short names" $
+      sanitizeName ("rts.gc.cpu_ms" :: Text) `shouldBe` "rts_gc_cpu_ms"
+
+    it "shortens names longer than 19 chars to 15 chars + _ + 3 hex" $ do
+      let result = sanitizeName ("rts.gc.par_balanced_bytes_copied" :: Text)
+      length result `shouldBe` 19
+      take 15 result `shouldBe` "rts_gc_par_bala"
+      drop 15 result `shouldBe` "_" ++ drop 16 result
+
+    it "is deterministic (same input -> same output)" $
+      sanitizeName ("rts.gc.peak_megabytes_allocated" :: Text)
+        `shouldBe` sanitizeName ("rts.gc.peak_megabytes_allocated" :: Text)
+
+  describe "buildSchema" $ do
+    it "builds sorted DsSpecs from counters and gauges, skipping labels" $
+      let sample :: HashMap Text M.Value
+          sample = HM.fromList
+            [ ("x.allocated", M.Counter 1000)
+            , ("a.bytes_used", M.Gauge 500)
+            , ("c.label_thing", M.Label "irrelevant")
+            ]
+      in buildSchema sample `shouldBe`
+           [ DsSpec "a.bytes_used" "a_bytes_used" Gauge
+           , DsSpec "x.allocated" "x_allocated" Derive
+           ]
+
+    it "produces dsName <= 19 chars for long ekg GC metric names" $
+      let sample :: HashMap Text M.Value
+          sample = HM.fromList
+            [ ("rts.gc.par_balanced_bytes_copied", M.Gauge 1)
+            , ("rts.gc.peak_megabytes_allocated", M.Gauge 2)
+            , ("rts.gc.cumulative_bytes_used", M.Counter 3)
+            ]
+      in map (length . dsName) (buildSchema sample) `shouldSatisfy` all (<= 19)
+
+  describe "buildCreateArgs" $ do
+    it "builds create argv with mixed DERIVE and GAUGE DSes and RRAs" $
+      buildCreateArgs "test.rrd" 10
+        [ ("ds1", Derive)
+        , ("ds2", Gauge)
+        ]
+        `shouldBe`
+          [ "create"
+          , "test.rrd"
+          , "--step"
+          , "10"
+          , "DS:ds1:DERIVE:20:0:U"
+          , "DS:ds2:GAUGE:20:0:U"
+          , "RRA:AVERAGE:0.5:1:6000"
+          , "RRA:MAX:0.5:1:6000"
+          , "RRA:AVERAGE:0.5:360:1680"
+          , "RRA:MAX:0.5:360:1680"
+          ]
+
+  describe "buildUpdateArgs" $ do
+    it "builds update argv with numeric values" $
+      buildUpdateArgs "test.rrd" ["ds1", "ds2"] [Just 100, Just 200]
+        `shouldBe`
+          [ "update"
+          , "test.rrd"
+          , "--template"
+          , "ds1:ds2"
+          , "N:100:200"
+          ]
+
+    it "renders Nothing as U (unknown)" $
+      buildUpdateArgs "test.rrd" ["ds1", "ds2"] [Just 100, Nothing]
+        `shouldBe`
+          [ "update"
+          , "test.rrd"
+          , "--template"
+          , "ds1:ds2"
+          , "N:100:U"
+          ]
+
+    it "renders all-Nothing as all-U" $
+      buildUpdateArgs "test.rrd" ["ds1"] [Nothing]
+        `shouldBe`
+          [ "update"
+          , "test.rrd"
+          , "--template"
+          , "ds1"
+          , "N:U"
+          ]
+
+  describe "end-to-end (rrdtool-gated)" $ do
+    it "creates an rrd, samples, and updates it" $ do
+      mRrdtool <- findExecutable "rrdtool"
+      case mRrdtool of
+        Nothing -> pendingWith "rrdtool not on PATH"
+        Just rrdtool -> do
+          store <- Metrics.newStore
+          c <- Metrics.createCounter "test.counter" store
+          g <- Metrics.createGauge "test.gauge" store
+          Counter.inc c
+          Gauge.set g 42
+          tmp <- getTemporaryDirectory
+          let rrdPath = tmp ++ "/hass-controller-metrics-test.rrd"
+          _ <- try (removeFile rrdPath) :: IO (Either SomeException ())
+          schema <- buildSchema <$> Metrics.sampleAll store
+          ensureRrd rrdtool rrdPath schema
+          sampleAndUpdate store rrdtool rrdPath schema
+          (rc, out, _) <- readProcessWithExitCode rrdtool ["fetch", rrdPath, "AVERAGE"] ""
+          rc `shouldBe` ExitSuccess
+          length out `shouldSatisfy` (> 0)
+          _ <- try (removeFile rrdPath) :: IO (Either SomeException ())
+          return ()

test/Support.hs

@@ -16,7 +16,7 @@ import Data.Aeson (Value, object, (.=))
 import qualified Data.Text as T
 import Data.Time (UTCTime (..), utc)
 import Data.UUID (nil)
-import AFRP (Mealy (..), Request (..))
+import AFRP (Mealy (..), Pair (..), Request (..))
 import HomeAssistant.Controller (HASSEff (..), Service)
 
 fakeRequest :: Request
@@ -52,7 +52,7 @@ runHASS :: Mealy HASSEff a b -> [a] -> [(b, [Service])]
 runHASS _ [] = []
 runHASS m (a : as) =
   case runAcc (runMealy m interp fakeRequest a) [] of
-    ((b, m'), svcs) -> (b, svcs) : runHASS m' as
+    (Pair b m', svcs) -> (b, svcs) : runHASS m' as
 
 services :: [(b, [Service])] -> [[Service]]
 services = map snd