diff --git a/default.nix b/default.nix index f318d92..9025a71 100644 --- a/default.nix +++ b/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"; diff --git a/home-assistant-controller.cabal b/home-assistant-controller.cabal index f726621..72d2d2b 100644 --- a/home-assistant-controller.cabal +++ b/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, diff --git a/src/HomeAssistant/Runtime/Graphing.hs b/src/HomeAssistant/Runtime/Graphing.hs new file mode 100644 index 0000000..914b276 --- /dev/null +++ b/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 \ No newline at end of file diff --git a/test/GraphingSpec.hs b/test/GraphingSpec.hs new file mode 100644 index 0000000..bf5b035 --- /dev/null +++ b/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" + ] \ No newline at end of file diff --git a/test/Main.hs b/test/Main.hs index d64ce5c..d27dce3 100644 --- a/test/Main.hs +++ b/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