graphing: serve rrdtool graphs over http

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
+      "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)
+      }

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"
-          ]
+          ]
+
+  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