Add Metrics module: pure rrdtool argv builders for ekg samples

default.nix

@@ -1,6 +1,7 @@
 { mkDerivation, aeson, annotated-exception, async, base, bytestring
-, containers, hedgehog, hspec, hspec-hedgehog, katip, lens
-, lens-aeson, lib, network, stm, text, time, uuid, websockets
+, containers, directory, ekg-core, hedgehog, hspec, hspec-hedgehog
+, 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
-    lens lens-aeson network stm text time uuid websockets
+    aeson annotated-exception async base bytestring containers
+    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
-    hspec-hedgehog katip stm text time uuid
+    aeson annotated-exception async base containers directory ekg-core
+    hedgehog hspec hspec-hedgehog katip process stm text time
+    unordered-containers uuid
   ];
   license = lib.meta.getLicenseFromSpdxId "BSD-3-Clause";
   mainProgram = "home-assistant-controller";

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
@@ -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/HomeAssistant/Runtime/Metrics.hs

@@ -0,0 +1,72 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module HomeAssistant.Runtime.Metrics
+  ( DsType (..)
+  , DsSpec (..)
+  , dsTypeOf
+  , sanitizeName
+  , buildSchema
+  , buildCreateArgs
+  , buildUpdateArgs
+  ) where
+
+import Data.Int (Int64)
+import Data.List (intercalate, sortBy)
+import Data.Ord (comparing)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.HashMap.Strict as HM
+import qualified System.Metrics as M (Value (..), Sample)
+
+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
+
+sanitizeName :: Text -> String
+sanitizeName = T.unpack . T.replace "." "_"
+
+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

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,98 @@
+{-# 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
+  )
+import qualified System.Metrics as M (Value (..))
+import Test.Hspec
+
+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" $
+      sanitizeName ("rts.gc.bytes_allocated" :: Text) `shouldBe` "rts_gc_bytes_allocated"
+
+  describe "buildSchema" $ do
+    it "builds sorted DsSpecs from counters and gauges, skipping labels" $
+      let sample :: HashMap Text M.Value
+          sample = HM.fromList
+            [ ("rts.gc.bytes_allocated", M.Counter 1000)
+            , ("rts.gc.max_bytes_used", M.Gauge 500)
+            , ("rts.gc.label_thing", M.Label "irrelevant")
+            ]
+      in buildSchema sample `shouldBe`
+           [ DsSpec "rts.gc.bytes_allocated" "rts_gc_bytes_allocated" Derive
+           , DsSpec "rts.gc.max_bytes_used" "rts_gc_max_bytes_used" Gauge
+           ]
+
+  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"
+          ]