metrics: detect rrd schema mismatch and recreate with backup

src/HomeAssistant/Runtime/Metrics.hs

@@ -8,6 +8,8 @@ module HomeAssistant.Runtime.Metrics
   , buildSchema
   , buildCreateArgs
   , buildUpdateArgs
+  , parseInfoDs
+  , schemaMatches
   , ensureRrd
   , sampleAndUpdate
   , metricsAction
@@ -17,19 +19,22 @@ import Control.Concurrent (threadDelay)
 import Control.Monad (forever, unless)
 import Data.Char (ord)
 import Data.Int (Int64)
-import Data.List (intercalate, sortBy)
+import Data.List (intercalate, sort, sortBy, stripPrefix)
+import Data.Maybe (mapMaybe)
 import Data.Ord (comparing)
 import Data.Text (Text)
+import Data.Time (defaultTimeLocale, formatTime, getCurrentTime)
 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)
+import System.Directory (doesFileExist, renameFile)
+import System.Exit (ExitCode (..))
+import System.Process (callProcess, readProcessWithExitCode)
 
 data DsType = Derive | Gauge
-  deriving (Eq, Show)
+  deriving (Eq, Ord, Show)
 
 data DsSpec = DsSpec
   { dsEkgName :: Text
@@ -89,18 +94,57 @@ buildUpdateArgs path names values =
     renderValue Nothing  = "U"
     renderValue (Just n) = show n
 
+dsTypeFromString :: String -> Maybe DsType
+dsTypeFromString "DERIVE" = Just Derive
+dsTypeFromString "GAUGE"  = Just Gauge
+dsTypeFromString _        = Nothing
+
+parseInfoDs :: String -> [(String, DsType)]
+parseInfoDs = mapMaybe parseLine . lines
+  where
+    parseLine line = do
+      rest0 <- stripPrefix "ds[" line
+      let (name, rest1) = break (== ']') rest0
+      rest2 <- stripPrefix "].type = \"" rest1
+      let (ty, _) = break (== '"') rest2
+      dt <- dsTypeFromString ty
+      pure (name, dt)
+
+schemaMatches :: [DsSpec] -> [(String, DsType)] -> Bool
+schemaMatches schema existing =
+  sort (map (\s -> (dsName s, dsType s)) schema) == sort existing
+
 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
 
+readExistingDs :: FilePath -> FilePath -> IO [(String, DsType)]
+readExistingDs rrdtool rrdPath = do
+  (code, out, _) <- readProcessWithExitCode rrdtool ["info", rrdPath] ""
+  pure $ case code of
+    ExitSuccess -> parseInfoDs out
+    _           -> []
+
+backupPath :: FilePath -> IO FilePath
+backupPath path = do
+  now <- getCurrentTime
+  pure $ path ++ ".bak-" ++ formatTime defaultTimeLocale "%Y%m%dT%H%M%S" now
+
 ensureRrd :: FilePath -> FilePath -> [DsSpec] -> IO ()
 ensureRrd rrdtool rrdPath schema = do
   exists <- doesFileExist rrdPath
-  unless exists $
-    callProcess rrdtool (buildCreateArgs rrdPath 10 (map toPair schema))
+  if not exists
+    then create
+    else do
+      current <- readExistingDs rrdtool rrdPath
+      unless (schemaMatches schema current) $ do
+        backup <- backupPath rrdPath
+        renameFile rrdPath backup
+        create
   where
+    create = callProcess rrdtool (buildCreateArgs rrdPath 10 (map toPair schema))
     toPair s = (dsName s, dsType s)
 
 sampleAndUpdate :: M.Store -> FilePath -> FilePath -> [DsSpec] -> IO ()

test/MetricsSpec.hs

@@ -5,7 +5,9 @@ module MetricsSpec (spec) where
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HM
 import Data.Int (Int64)
+import Data.List (isPrefixOf)
 import Data.Text (Text)
+import qualified Data.Text as T
 import HomeAssistant.Runtime.Metrics
   ( DsType (..)
   , DsSpec (..)
@@ -17,11 +19,14 @@ import HomeAssistant.Runtime.Metrics
   , ensureRrd
   , sampleAndUpdate
   , metricsAction
+  , parseInfoDs
+  , schemaMatches
   )
 import qualified System.Metrics as M (Value (..))
 import Test.Hspec
 import Control.Exception (try, SomeException)
-import System.Directory (findExecutable, getTemporaryDirectory, removeFile)
+import Control.Monad (forM_)
+import System.Directory (findExecutable, getTemporaryDirectory, listDirectory, removeFile)
 import System.Exit (ExitCode (ExitSuccess))
 import System.Process (readProcessWithExitCode)
 import qualified System.Metrics as Metrics
@@ -126,6 +131,39 @@ spec = do
           , "N:U"
           ]
 
+  describe "parseInfoDs" $ do
+    it "extracts DS names and types from rrdtool info output" $
+      let info = unlines
+            [ "filename = \"test.rrd\""
+            , "step = 10"
+            , "ds[foo].index = 0"
+            , "ds[foo].type = \"DERIVE\""
+            , "ds[bar].type = \"GAUGE\""
+            , "rra[0].cf = \"AVERAGE\""
+            ]
+      in parseInfoDs info `shouldBe` [("foo", Derive), ("bar", Gauge)]
+
+    it "ignores lines that are not ds type declarations" $
+      parseInfoDs "step = 10\nrra[0].cf = \"AVERAGE\"\n" `shouldBe` []
+
+  describe "schemaMatches" $ do
+    let ds name ty = DsSpec (T.pack name) name ty
+    it "is true for identical schemas regardless of order" $
+      schemaMatches [ds "b" Gauge, ds "a" Derive] [("a", Derive), ("b", Gauge)]
+        `shouldBe` True
+
+    it "is false when the derived schema has an added DS" $
+      schemaMatches [ds "a" Derive, ds "b" Gauge] [("a", Derive)]
+        `shouldBe` False
+
+    it "is false when the derived schema has a removed DS" $
+      schemaMatches [ds "a" Derive] [("a", Derive), ("b", Gauge)]
+        `shouldBe` False
+
+    it "is false when a DS type changed" $
+      schemaMatches [ds "a" Derive] [("a", Gauge)]
+        `shouldBe` False
+
   describe "end-to-end (rrdtool-gated)" $ do
     it "creates an rrd, samples, and updates it" $ do
       mRrdtool <- findExecutable "rrdtool"
@@ -148,3 +186,29 @@ spec = do
           length out `shouldSatisfy` (> 0)
           _ <- try (removeFile rrdPath) :: IO (Either SomeException ())
           return ()
+
+    it "backs up and recreates the rrd when the schema changes" $ do
+      mRrdtool <- findExecutable "rrdtool"
+      case mRrdtool of
+        Nothing -> pendingWith "rrdtool not on PATH"
+        Just rrdtool -> do
+          tmp <- getTemporaryDirectory
+          let rrdPath = tmp ++ "/hass-controller-schema-change-test.rrd"
+              bakPrefix = "hass-controller-schema-change-test.rrd.bak-"
+              base = [ DsSpec "a" "a" Derive, DsSpec "b" "b" Gauge ]
+              expanded = base ++ [ DsSpec "c" "c" Derive ]
+          _ <- try (removeFile rrdPath) :: IO (Either SomeException ())
+          ensureRrd rrdtool rrdPath base
+          ensureRrd rrdtool rrdPath base
+          noBackups <- filter (isPrefixOf bakPrefix) <$> listDirectory tmp
+          noBackups `shouldBe` []
+          ensureRrd rrdtool rrdPath expanded
+          backups <- filter (isPrefixOf bakPrefix) <$> listDirectory tmp
+          length backups `shouldBe` 1
+          (rc, out, _) <- readProcessWithExitCode rrdtool ["info", rrdPath] ""
+          rc `shouldBe` ExitSuccess
+          out `shouldContain` "ds[c].type"
+          _ <- try (removeFile rrdPath) :: IO (Either SomeException ())
+          forM_ backups $ \f -> do
+            _ <- try (removeFile (tmp ++ "/" ++ f)) :: IO (Either SomeException ())
+            pure ()