Add metricsAction: supervised loop sampling ekg store to rrd via rrdtool

src/HomeAssistant/Runtime/Metrics.hs

@@ -8,15 +8,23 @@ module HomeAssistant.Runtime.Metrics
   , buildSchema
   , buildCreateArgs
   , buildUpdateArgs
+  , ensureRrd
+  , sampleAndUpdate
+  , metricsAction
   ) where
 
+import Control.Concurrent (threadDelay)
+import Control.Monad (forever, unless)
 import Data.Int (Int64)
 import Data.List (intercalate, sortBy)
 import Data.Ord (comparing)
 import Data.Text (Text)
+import Data.Void (Void)
 import qualified Data.Text as T
 import qualified Data.HashMap.Strict as HM
-import qualified System.Metrics as M (Value (..), Sample)
+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)
@@ -70,3 +78,32 @@ buildUpdateArgs path names 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/MetricsSpec.hs

@@ -14,9 +14,19 @@ import HomeAssistant.Runtime.Metrics
   , 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
@@ -96,3 +106,26 @@ spec = do
           , "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 ()