diff --git a/src/HomeAssistant/Runtime/Metrics.hs b/src/HomeAssistant/Runtime/Metrics.hs index 0e07597..f72b9c2 100644 --- a/src/HomeAssistant/Runtime/Metrics.hs +++ b/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 () diff --git a/test/MetricsSpec.hs b/test/MetricsSpec.hs index 2b3c6b2..b7bd0e3 100644 --- a/test/MetricsSpec.hs +++ b/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 ()