From 9861266c1edce764058edf5546890eb3a1d0da34 Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Tue, 15 Sep 2026 22:06:25 +0300 Subject: [PATCH] graphing: serve rrdtool graphs over http --- src/HomeAssistant/Runtime/Graphing.hs | 80 ++++++++++++++++++++++++++- test/GraphingSpec.hs | 43 +++++++++++++- 2 files changed, 121 insertions(+), 2 deletions(-) diff --git a/src/HomeAssistant/Runtime/Graphing.hs b/src/HomeAssistant/Runtime/Graphing.hs index 914b276..a2dc3d6 100644 --- a/src/HomeAssistant/Runtime/Graphing.hs +++ b/src/HomeAssistant/Runtime/Graphing.hs @@ -10,10 +10,38 @@ module HomeAssistant.Runtime.Graphing , lookupGraph , parseNameParam , buildGraphArgs + , readProcessBytes + , graphAction ) where +import Control.Exception (evaluate) +import Control.Monad (forever) +import Control.Monad.IO.Class (liftIO) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Void (Void) +import Network.HTTP.Types.Status (Status, status400, status404, status500) +import Network.Wai.Handler.Warp (defaultSettings, setHost, setPort) +import System.Exit (ExitCode (..)) +import System.IO (hGetContents) +import System.Process (CreateProcess (..), StdStream (..), proc, waitForProcess, withCreateProcess) +import Web.Scotty + ( ActionM + , ScottyM + , defaultOptions + , get + , pathParam + , queryParamMaybe + , raw + , scottyOpts + , setHeader + , settings + , status + , text + ) data Range = TenMinutes | OneHour | OneDay | OneWeek | OneMonth deriving (Eq, Show, Bounded, Enum) @@ -82,4 +110,54 @@ buildGraphArgs rrdPath spec range = , "CDEF:" ++ alias ++ "_min=" ++ alias ++ ",60,*" ] line (Series _ alias color label) = - "LINE2:" ++ alias ++ "_min" ++ color ++ ":" ++ label \ No newline at end of file + "LINE2:" ++ alias ++ "_min" ++ color ++ ":" ++ label + +readProcessBytes :: FilePath -> [String] -> IO (ExitCode, BS.ByteString, String) +readProcessBytes cmd args = + withCreateProcess (proc cmd args) { std_out = CreatePipe, std_err = CreatePipe } $ + \_ mout merr ph -> + case (mout, merr) of + (Just hout, Just herr) -> do + out <- BS.hGetContents hout + err <- hGetContents herr + code <- waitForProcess ph + _ <- evaluate (length err) + pure (code, out, err) + _ -> pure (ExitFailure 1, BS.empty, "failed to create pipes") + +respond :: Status -> TL.Text -> ActionM () +respond st body = status st >> text body + +serve :: FilePath -> FilePath -> GraphSpec -> Range -> ActionM () +serve rrdPath rrdtool spec range = do + (code, out, err) <- liftIO (readProcessBytes rrdtool (buildGraphArgs rrdPath spec range)) + case code of + ExitSuccess + | not (BS.null out) -> do + setHeader "Content-Type" "image/png" + raw (BL.fromStrict out) + | otherwise -> respond status500 "empty graph" + _ -> respond status500 (TL.pack (take 200 err)) + +handler :: FilePath -> FilePath -> ActionM () +handler rrdPath rrdtool = do + name <- pathParam "name" + case parseNameParam graphs name of + Nothing -> respond status404 "unknown graph" + Just spec -> do + rangeArg <- queryParamMaybe "range" + case rangeArg of + Nothing -> serve rrdPath rrdtool spec OneDay + Just t -> case parseRange t of + Nothing -> respond status400 "invalid range" + Just range -> serve rrdPath rrdtool spec range + +app :: FilePath -> FilePath -> ScottyM () +app rrdPath rrdtool = get "/metrics/:name" (handler rrdPath rrdtool) + +graphAction :: FilePath -> FilePath -> Int -> IO Void +graphAction rrdPath rrdtool port = forever $ scottyOpts opts (app rrdPath rrdtool) + where + opts = defaultOptions + { settings = setHost "127.0.0.1" (setPort port defaultSettings) + } \ No newline at end of file diff --git a/test/GraphingSpec.hs b/test/GraphingSpec.hs index bf5b035..9d52e96 100644 --- a/test/GraphingSpec.hs +++ b/test/GraphingSpec.hs @@ -2,6 +2,8 @@ module GraphingSpec (spec) where +import Control.Exception (SomeException, finally, try) +import qualified Data.ByteString as BS import HomeAssistant.Runtime.Graphing ( GraphSpec (..) , Range (..) @@ -11,7 +13,12 @@ import HomeAssistant.Runtime.Graphing , parseNameParam , parseRange , rangeStart + , readProcessBytes ) +import qualified HomeAssistant.Runtime.Metrics as Metrics +import System.Directory (findExecutable, getTemporaryDirectory, removeFile) +import System.Exit (ExitCode (..)) +import System.Process (readProcessWithExitCode) import Test.Hspec traffic :: GraphSpec @@ -82,4 +89,38 @@ spec = do , "CDEF:svc_min=svc,60,*" , "LINE2:trig_min#0066cc:triggers in/min" , "LINE2:svc_min#cc0000:services out/min" - ] \ No newline at end of file + ] + + describe "end-to-end (rrdtool-gated)" $ do + it "renders a PNG for the traffic graph" $ do + mRrdtool <- findExecutable "rrdtool" + case mRrdtool of + Nothing -> pendingWith "rrdtool not on PATH" + Just rrdtool -> do + tmp <- getTemporaryDirectory + let rrdPath = tmp ++ "/hass-controller-graph-test.rrd" + cleanup = try (removeFile rrdPath) :: IO (Either SomeException ()) + schema = + [ ("hass_trigger_in", Metrics.Derive) + , ("hass_service_out", Metrics.Derive) + ] + pngMagic = BS.pack [0x89, 0x50, 0x4E, 0x47, 0x0D, 0x0A, 0x1A, 0x0A] + _ <- cleanup + ( do + (createCode, _, _) <- + readProcessWithExitCode rrdtool (Metrics.buildCreateArgs rrdPath 10 schema) "" + createCode `shouldBe` ExitSuccess + (updateCode, _, _) <- + readProcessWithExitCode + rrdtool + (Metrics.buildUpdateArgs + rrdPath + ["hass_trigger_in", "hass_service_out"] + [Just 5, Just 3]) + "" + updateCode `shouldBe` ExitSuccess + (code, out, _) <- readProcessBytes rrdtool (buildGraphArgs rrdPath traffic OneHour) + code `shouldBe` ExitSuccess + out `shouldSatisfy` BS.isPrefixOf pngMagic + ) + `finally` cleanup \ No newline at end of file