graphing: add pure graph table, ranges, and argv builders

default.nix

@@ -1,8 +1,8 @@
 { mkDerivation, aeson, annotated-exception, async, base, bytestring
 , cereal, cereal-conduit, conduit, containers, directory, ekg-core
-, filepath, hedgehog, hspec, hspec-hedgehog, katip, lens
-, lens-aeson, lib, network, process, stm, text, time
-, unordered-containers, uuid, websockets
+, filepath, hedgehog, hspec, hspec-hedgehog, http-types, katip
+, lens, lens-aeson, lib, network, process, scotty, stm, text, time
+, unordered-containers, uuid, wai, warp, websockets
 }:
 mkDerivation {
   pname = "home-assistant-controller";
@@ -12,15 +12,15 @@ mkDerivation {
   isExecutable = true;
   libraryHaskellDepends = [
     aeson annotated-exception async base bytestring cereal
-    cereal-conduit conduit containers directory ekg-core filepath katip
-    lens lens-aeson network process stm text time unordered-containers
-    uuid websockets
+    cereal-conduit conduit containers directory ekg-core filepath
+    http-types katip lens lens-aeson network process scotty stm text
+    time unordered-containers uuid wai warp websockets
   ];
   executableHaskellDepends = [ base ];
   testHaskellDepends = [
-    aeson annotated-exception async base cereal containers directory
-    ekg-core hedgehog hspec hspec-hedgehog katip process stm text time
-    unordered-containers uuid
+    aeson annotated-exception async base bytestring cereal containers
+    directory ekg-core hedgehog hspec hspec-hedgehog katip process stm
+    text time unordered-containers uuid
   ];
   license = lib.meta.getLicenseFromSpdxId "BSD-3-Clause";
   mainProgram = "home-assistant-controller";

home-assistant-controller.cabal

@@ -68,6 +68,7 @@ library
                     , HomeAssistant.Runtime
                     , HomeAssistant.Runtime.Bus
                     , HomeAssistant.Runtime.Connection
+                    , HomeAssistant.Runtime.Graphing
                     , HomeAssistant.Runtime.Metrics
                     , HomeAssistant.Runtime.Supervisor
 
@@ -102,6 +103,10 @@ library
                     , filepath
                     , conduit
                     , cereal-conduit
+                    , scotty
+                    , http-types
+                    , warp
+                    , wai
 
     -- Directories containing source files.
     hs-source-dirs:   src
@@ -148,6 +153,7 @@ test-suite home-assistant-controller-test
                     , BedroomSpec
                     , BusSpec
                     , ConnectionSpec
+                    , GraphingSpec
                     , MetricsSpec
                     , RuntimeSpec
                     , SupervisorSpec
@@ -169,6 +175,7 @@ test-suite home-assistant-controller-test
     build-depends:
         base ^>=4.20.2.0,
         home-assistant-controller,
+        bytestring,
         hspec,
         stm,
         aeson,

src/HomeAssistant/Runtime/Graphing.hs

@@ -0,0 +1,85 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module HomeAssistant.Runtime.Graphing
+  ( Range (..)
+  , parseRange
+  , rangeStart
+  , Series (..)
+  , GraphSpec (..)
+  , graphs
+  , lookupGraph
+  , parseNameParam
+  , buildGraphArgs
+  ) where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+
+data Range = TenMinutes | OneHour | OneDay | OneWeek | OneMonth
+  deriving (Eq, Show, Bounded, Enum)
+
+rangeSuffix :: Range -> String
+rangeSuffix TenMinutes = "10m"
+rangeSuffix OneHour     = "1h"
+rangeSuffix OneDay      = "24h"
+rangeSuffix OneWeek     = "7d"
+rangeSuffix OneMonth    = "30d"
+
+parseRange :: Text -> Maybe Range
+parseRange t = lookup t [(T.pack (rangeSuffix r), r) | r <- [minBound .. maxBound]]
+
+rangeStart :: Range -> String
+rangeStart r = "end-" ++ rangeSuffix r
+
+data Series = Series
+  { serDs    :: String
+  , serAlias :: String
+  , serColor :: String
+  , serLabel :: String
+  }
+  deriving (Eq, Show)
+
+data GraphSpec = GraphSpec
+  { gsName   :: Text
+  , gsTitle  :: String
+  , gsSeries :: [Series]
+  }
+  deriving (Eq, Show)
+
+graphs :: [GraphSpec]
+graphs =
+  [ GraphSpec
+      "traffic"
+      "Hass triggers in / services out"
+      [ Series "hass_trigger_in" "trig" "#0066cc" "triggers in/min"
+      , Series "hass_service_out" "svc" "#cc0000" "services out/min"
+      ]
+  ]
+
+lookupGraph :: [GraphSpec] -> Text -> Maybe GraphSpec
+lookupGraph specs name = case [g | g <- specs, gsName g == name] of
+  (g : _) -> Just g
+  []      -> Nothing
+
+parseNameParam :: [GraphSpec] -> Text -> Maybe GraphSpec
+parseNameParam specs t = T.stripSuffix ".png" t >>= lookupGraph specs
+
+buildGraphArgs :: FilePath -> GraphSpec -> Range -> [String]
+buildGraphArgs rrdPath spec range =
+  [ "graph"
+  , "-"
+  , "--start", rangeStart range
+  , "--title", gsTitle spec
+  , "--width", "800"
+  , "--height", "250"
+  , "--imgformat", "PNG"
+  ]
+    ++ concatMap defArgs (gsSeries spec)
+    ++ map line (gsSeries spec)
+  where
+    defArgs (Series ds alias _ _) =
+      [ "DEF:" ++ alias ++ "=" ++ rrdPath ++ ":" ++ ds ++ ":AVERAGE"
+      , "CDEF:" ++ alias ++ "_min=" ++ alias ++ ",60,*"
+      ]
+    line (Series _ alias color label) =
+      "LINE2:" ++ alias ++ "_min" ++ color ++ ":" ++ label

test/GraphingSpec.hs

@@ -0,0 +1,85 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module GraphingSpec (spec) where
+
+import HomeAssistant.Runtime.Graphing
+  ( GraphSpec (..)
+  , Range (..)
+  , buildGraphArgs
+  , graphs
+  , lookupGraph
+  , parseNameParam
+  , parseRange
+  , rangeStart
+  )
+import Test.Hspec
+
+traffic :: GraphSpec
+traffic = case lookupGraph graphs "traffic" of
+  Just s  -> s
+  Nothing -> error "traffic graph is missing from the table"
+
+spec :: Spec
+spec = do
+  describe "parseRange" $ do
+    it "accepts every suffix in the closed set" $
+      map parseRange ["10m", "1h", "24h", "7d", "30d"]
+        `shouldBe` [ Just TenMinutes
+                   , Just OneHour
+                   , Just OneDay
+                   , Just OneWeek
+                   , Just OneMonth
+                   ]
+
+    it "rejects everything outside the closed set" $
+      map parseRange
+        [ ""
+        , "1h "
+        , " 1h"
+        , "1h; rm -rf /"
+        , "end-1h"
+        , "../../etc/passwd"
+        , "1y"
+        , "30m"
+        , "1H"
+        ]
+        `shouldBe` replicate 9 Nothing
+
+  describe "rangeStart" $ do
+    it "renders rrdtool end- relative starts" $
+      map rangeStart [TenMinutes, OneHour, OneDay, OneWeek, OneMonth]
+        `shouldBe` ["end-10m", "end-1h", "end-24h", "end-7d", "end-30d"]
+
+  describe "parseNameParam" $ do
+    it "resolves the traffic graph only with a .png suffix" $ do
+      fmap gsName (parseNameParam graphs "traffic.png") `shouldBe` Just "traffic"
+      parseNameParam graphs "traffic" `shouldBe` Nothing
+
+    it "rejects unknown, malformed, and traversing names" $
+      map (parseNameParam graphs)
+        [ "unknown.png"
+        , "../traffic.png"
+        , "traffic.png.png"
+        , ""
+        , "nope"
+        ]
+        `shouldBe` replicate 5 Nothing
+
+  describe "buildGraphArgs" $ do
+    it "builds the traffic argv for a range" $
+      buildGraphArgs "hass-controller.rrd" traffic OneHour
+        `shouldBe`
+          [ "graph"
+          , "-"
+          , "--start", "end-1h"
+          , "--title", "Hass triggers in / services out"
+          , "--width", "800"
+          , "--height", "250"
+          , "--imgformat", "PNG"
+          , "DEF:trig=hass-controller.rrd:hass_trigger_in:AVERAGE"
+          , "CDEF:trig_min=trig,60,*"
+          , "DEF:svc=hass-controller.rrd:hass_service_out:AVERAGE"
+          , "CDEF:svc_min=svc,60,*"
+          , "LINE2:trig_min#0066cc:triggers in/min"
+          , "LINE2:svc_min#cc0000:services out/min"
+          ]

test/Main.hs

@@ -7,6 +7,7 @@ import qualified BackoffProp
 import qualified BedroomSpec
 import qualified BusSpec
 import qualified ConnectionSpec
+import qualified GraphingSpec
 import qualified MetricsSpec
 import qualified RuntimeSpec
 import qualified SupervisorSpec
@@ -18,6 +19,7 @@ main = hspec $ do
   BedroomSpec.spec
   BusSpec.spec
   ConnectionSpec.spec
+  GraphingSpec.spec
   MetricsSpec.spec
   RuntimeSpec.spec
   SupervisorSpec.spec