List of ranges

This commit is contained in:
MasseR committed 2026-10-12 15:17:07 +03:00
1 parent 45277e02da
commit 3a6fe26d0c
2 files changed
+6 -1

No files matched your search

+1
View File
@@ -13,6 +13,7 @@ module HomeAssistant.Runtime.Graphing
, readProcessBytes , readProcessBytes
, Graph(..) , Graph(..)
, renderGraph , renderGraph
, rangeSuffix
) where ) where
import Control.Exception (evaluate) import Control.Exception (evaluate)
+5 -1
View File
@@ -22,7 +22,7 @@ import Control.Exception.Annotated (checkpoint, Annotation (Annotation))
import Servant.Server.Generic (genericServeT) import Servant.Server.Generic (genericServeT)
import Network.Wai (Application) import Network.Wai (Application)
import Network.HTTP.Media ((//)) import Network.HTTP.Media ((//))
import HomeAssistant.Runtime.Graphing (Graph (..), Range (..), lookupGraph, graphs, renderGraph) import HomeAssistant.Runtime.Graphing (Graph (..), Range (..), lookupGraph, graphs, renderGraph, rangeSuffix)
import Katip (KatipContextT, Katip, runKatipContextT, LogEnv, KatipContext, ls, Severity (..), logFM, katipAddContext, sl) import Katip (KatipContextT, Katip, runKatipContextT, LogEnv, KatipContext, ls, Severity (..), logFM, katipAddContext, sl)
import Data.Aeson (ToJSON (toJSON), FromJSON, object, (.=)) import Data.Aeson (ToJSON (toJSON), FromJSON, object, (.=))
import Lucid (ToHtml, toHtml, renderBS, toHtmlRaw, HtmlT, Attributes) import Lucid (ToHtml, toHtml, renderBS, toHtmlRaw, HtmlT, Attributes)
@@ -163,6 +163,9 @@ server rrdPath rrdtool flags = API
getStatsHandler :: Maybe Range -> LoggingHandler StatsPage getStatsHandler :: Maybe Range -> LoggingHandler StatsPage
getStatsHandler r = pure $ StatsPage $ do getStatsHandler r = pure $ StatsPage $ do
H5.ul_ $ do
for_ [minBound..maxBound] $ \range ->
H5.li_ $ H5.a_ [H5.href_ $ flagWithRange range] $ toHtml $ rangeSuffix range
H5.h2_ "Traffic" H5.h2_ "Traffic"
H5.img_ [H5.src_ (src Traffic)] H5.img_ [H5.src_ (src Traffic)]
H5.h2_ "Memory" H5.h2_ "Memory"
@@ -171,6 +174,7 @@ getStatsHandler r = pure $ StatsPage $ do
H5.img_ [H5.src_ (src RateLimit)] H5.img_ [H5.src_ (src RateLimit)]
where where
src m = "/" <> toUrlPiece (fieldLink getMetrics m r) src m = "/" <> toUrlPiece (fieldLink getMetrics m r)
flagWithRange range = "/" <> toUrlPiece (fieldLink getStats (Just range))
servantApp :: LogEnv -> FilePath -> FilePath -> Flags -> Application servantApp :: LogEnv -> FilePath -> FilePath -> Flags -> Application
servantApp le rrdPath rrdtool flags = genericServeT (toHandler le) (server rrdPath rrdtool flags) servantApp le rrdPath rrdtool flags = genericServeT (toHandler le) (server rrdPath rrdtool flags)