graphing: add pure graph table, ranges, and argv builders
This commit is contained in:
+9
-9
@@ -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";
|
||||
|
||||
@@ -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,
|
||||
|
||||
@@ -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
|
||||
@@ -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"
|
||||
]
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user