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 ()