From 55855db55bed17a8897311231ede6f37fcd6f8b1 Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Mon, 12 Oct 2026 11:11:37 +0300 Subject: [PATCH 1/5] Try a separate `holdKnown` primitive --- src/AFRP.hs | 6 ++++++ src/HomeAssistant/Controller/Children.hs | 7 ++++--- 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/src/AFRP.hs b/src/AFRP.hs index 4fcb319..11da618 100644 --- a/src/AFRP.hs +++ b/src/AFRP.hs @@ -8,6 +8,7 @@ module AFRP , withEntities , Event(..) , hold + , holdKnown , events -- , switch , preMapAccum @@ -326,6 +327,11 @@ hold def = mapAccum step def id Tick -> prev Event new -> new + +-- A variant of 'hold' which makes it explicit whether we have a previous value +holdKnown :: (Serialize a, Eq a) => Mealy m (Event a) (Maybe a) +holdKnown = arr (fmap Just) >>> hold Nothing + snapshot :: (Serialize a, Eq a) => a -> Mealy m (Event (), a) a snapshot def = mapAccum step def id where diff --git a/src/HomeAssistant/Controller/Children.hs b/src/HomeAssistant/Controller/Children.hs index 65767df..24e3b1e 100644 --- a/src/HomeAssistant/Controller/Children.hs +++ b/src/HomeAssistant/Controller/Children.hs @@ -19,6 +19,7 @@ import Data.Aeson.Types (ToJSON (..)) import Data.Aeson.Lens (key, _String) import Control.Lens ((^?), to) import Data.Text (Text) +import Control.Monad (join) -- Let's see building some reasonable interface for utctime dow :: Day -> (WeekOfYear, Int) @@ -131,8 +132,8 @@ data HumidifierAction instance Serialize HumidifierAction -- what is the humidifer doing right now? -humidifierEntityAction :: HASS (Event Value) (Event (Maybe HumidifierAction)) -humidifierEntityAction = entityChangeEvent "humidifier.lapset_ilmankostutin" +humidifierOperatingState :: HASS (Event Value) (Event (Maybe HumidifierAction)) +humidifierOperatingState = entityChangeEvent "humidifier.lapset_ilmankostutin" >>> arr (fmap entityAction) where entityAction v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "attributes" . key "action" . _String . to humidifierAction @@ -149,7 +150,7 @@ instance ToJSON Percentage where childrenAirFilterController :: HASS (Event Value) () childrenAirFilterController = proc ev -> do level <- pm25 >>> pm25Level >>> AFRP.changes >>> traceEvent -< ev - humidifier <- humidifierEntityAction >>> AFRP.hold Nothing -< ev + humidifier <- humidifierOperatingState >>> AFRP.holdKnown >>> arr join -< ev case level of Event PM25High -> AFRP.whenA (== Just Idle) (callService (fanOnTo (Percentage 80))) -< humidifier From 87dda96e7eb09de872d69821d0b733ae6d6f7584 Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Mon, 12 Oct 2026 13:28:54 +0300 Subject: [PATCH 2/5] Simple HTML responses --- default.nix | 12 ++--- home-assistant-controller.cabal | 2 + src/HttpServer.hs | 93 +++++++++++++++++++++++++++------ 3 files changed, 86 insertions(+), 21 deletions(-) diff --git a/default.nix b/default.nix index 25d36ee..18e609b 100644 --- a/default.nix +++ b/default.nix @@ -2,9 +2,9 @@ , cereal, cereal-conduit, cereal-text, conduit, containers , data-default, directory, ekg-core, exceptions, filepath, hedgehog , hspec, hspec-hedgehog, http-media, http-types, katip, lens -, lens-aeson, lib, libsystemd-journal, network, process, retry -, servant, servant-server, stm, temporary, text, time, unliftio -, unordered-containers, uuid, wai, warp, websockets +, lens-aeson, lib, libsystemd-journal, lucid2, network, process +, retry, servant, servant-server, stm, temporary, text, time +, unliftio, unordered-containers, uuid, wai, warp, websockets }: mkDerivation { pname = "home-assistant-controller"; @@ -16,9 +16,9 @@ mkDerivation { aeson annotated-exception async base bytestring cereal cereal-conduit cereal-text conduit containers data-default directory ekg-core exceptions filepath http-media http-types katip - lens lens-aeson libsystemd-journal network process retry servant - servant-server stm text time unliftio unordered-containers uuid wai - warp websockets + lens lens-aeson libsystemd-journal lucid2 network process retry + servant servant-server stm text time unliftio unordered-containers + uuid wai warp websockets ]; executableHaskellDepends = [ base ]; testHaskellDepends = [ diff --git a/home-assistant-controller.cabal b/home-assistant-controller.cabal index d1b45ee..392e124 100644 --- a/home-assistant-controller.cabal +++ b/home-assistant-controller.cabal @@ -132,6 +132,8 @@ library , wai , retry , libsystemd-journal + , lucid2 + , http-api-data -- Directories containing source files. hs-source-dirs: src diff --git a/src/HttpServer.hs b/src/HttpServer.hs index 4ff3521..e00d0d1 100644 --- a/src/HttpServer.hs +++ b/src/HttpServer.hs @@ -7,10 +7,10 @@ import Control.Monad.IO.Class (liftIO, MonadIO) import qualified Data.ByteString as BS import Data.Void (Void) import Network.Wai.Handler.Warp (run) -import Servant.API ((:>), Capture, Get, QueryParam, (:-), MimeRender (..), Accept (..), NamedRoutes, JSON, ReqBody, Put) +import Servant.API ((:>), Capture, Get, QueryParam, (:-), MimeRender (..), Accept (..), NamedRoutes, JSON, ReqBody, Put, Post, FormUrlEncoded) import Data.ByteString (ByteString) import GHC.Generics (Generic) -import Servant (Handler, err404) +import Servant (Handler, err404, fieldLink, toUrlPiece) import Control.Monad.Catch (throwM, catch, MonadCatch, MonadThrow, SomeException) import Servant.Server (err500, ServerT) import Data.Maybe (fromMaybe) @@ -22,56 +22,118 @@ import Control.Exception.Annotated (checkpoint, Annotation (Annotation)) import Servant.Server.Generic (genericServeT) import Network.Wai (Application) import Network.HTTP.Media ((//)) -import HomeAssistant.Runtime.Graphing (Graph, Range (..), lookupGraph, graphs, renderGraph) +import HomeAssistant.Runtime.Graphing (Graph (..), Range (..), lookupGraph, graphs, renderGraph) import Katip (KatipContextT, Katip, runKatipContextT, LogEnv, KatipContext, ls, Severity (..), logFM) +import Data.Aeson (ToJSON, FromJSON) +import Lucid (ToHtml, toHtml, renderBS, toHtmlRaw, HtmlT) +import qualified Lucid.Html5 as H5 +import qualified Data.Map.Strict as M +import Data.Foldable (for_) +import qualified Data.Text as T +import Web.FormUrlEncoded (FromForm, fromForm, parseUnique) data ImagePng -instance MimeRender ImagePng ByteString where - mimeRender _ = BS.fromStrict +instance MimeRender ImagePng GraphPng where + mimeRender _ (GraphPng bs) = BS.fromStrict bs instance Accept ImagePng where contentType _ = "image" // "png" +-- `servant-lucid` package would provide this and the instance for the original lucid(1) package +-- but we have lucid2 +data HTML + +instance Accept HTML where + contentType _ = "text" // "html" + +instance ToHtml a => MimeRender HTML a where + mimeRender _ = renderBS . toHtml + +newtype StatsPage = StatsPage (forall m. Monad m => HtmlT m ()) + +instance ToHtml StatsPage where + toHtml (StatsPage inner) = H5.doctypehtml_ $ H5.body_ inner + toHtmlRaw = toHtml data API mode = API - { getMetrics :: mode :- "metrics" :> Capture "graph" Graph :> QueryParam "range" Range :> Get '[ImagePng] ByteString - , getFlags :: mode :- "flags" :> Get '[JSON] (Map Text Bool) - , putFlag :: mode :- "flags" :> Capture "name" Text :> ReqBody '[JSON] Bool :> Put '[JSON] (Map Text Bool) + { getMetrics :: mode :- "metrics" :> Capture "graph" Graph :> QueryParam "range" Range :> Get '[ImagePng] GraphPng + , getStats :: mode :- "stats" :> QueryParam "range" Range :> Get '[HTML] StatsPage + , getFlags :: mode :- "flags" :> Get '[JSON, HTML] FlagsResponse + , putFlag :: mode :- "flags" :> Capture "name" Text :> ReqBody '[JSON] FlagValue :> Put '[JSON] FlagsResponse + , postFlag :: mode :- "flags" :> Capture "name" Text :> ReqBody '[JSON, FormUrlEncoded] FlagValue :> Post '[JSON, HTML] FlagsResponse } deriving Generic +newtype GraphPng = GraphPng ByteString -getFlagsHandler :: Flags -> LoggingHandler (Map Text Bool) -getFlagsHandler = allFlags +newtype FlagValue = FlagValue Bool + deriving FromJSON via Bool -putFlagHandler :: Flags -> Text -> Bool -> LoggingHandler (Map Text Bool) -putFlagHandler flags name val +instance FromForm FlagValue where + fromForm f = FlagValue <$> parseUnique "flag-value" f + +newtype FlagsResponse = FlagsResponse (Map Text Bool) + deriving (ToJSON) via (Map Text Bool) + +flagsPage :: Monad m => FlagsResponse -> HtmlT m () +flagsPage (FlagsResponse f) = H5.doctypehtml_ $ + H5.body_ $ H5.table_ $ for_ (M.toList f) $ \(k,v) -> H5.tr_ $ + H5.td_ (toHtml k) <> H5.td_ (toHtml $ show v) <> H5.td_ (toggle k v) + where + toggle :: Monad m => Text -> Bool -> HtmlT m () + toggle key current = H5.form_ [H5.method_ "post", H5.action_ $ postFlagsLink key] $ do + H5.input_ [H5.name_ "flag-value", H5.type_ "hidden", H5.value_ (T.pack $ show (not current))] + H5.input_ [H5.type_ "submit", H5.value_ "Toggle"] + postFlagsLink k = "/" <> toUrlPiece (fieldLink putFlag k) + +instance ToHtml FlagsResponse where + toHtml = flagsPage + toHtmlRaw = toHtml + +getFlagsHandler :: Flags -> LoggingHandler FlagsResponse +getFlagsHandler = fmap FlagsResponse . allFlags + +putFlagHandler :: Flags -> Text -> FlagValue -> LoggingHandler FlagsResponse +putFlagHandler flags name (FlagValue val) | name `S.notMember` validNames flags = throwM err404 | otherwise = do setEnabled flags name val `catch` \e -> do logFM ErrorS (ls ("failed to persist handler flag: " <> show (e :: SomeException))) throwM err500 - allFlags flags + FlagsResponse <$> allFlags flags -getMetricsHandler :: FilePath -> FilePath -> Graph -> Maybe Range -> LoggingHandler ByteString +getMetricsHandler :: FilePath -> FilePath -> Graph -> Maybe Range -> LoggingHandler GraphPng getMetricsHandler rrdPath rrdtool graphMode mRange = checkpoint (Annotation (graphMode, mRange)) $ do case lookupGraph graphs graphMode of Nothing -> throwM err404 Just spec -> do let range = fromMaybe OneDay mRange g <- renderGraph rrdPath rrdtool spec range - either (\e -> logFM ErrorS (ls e) >> throwM err500) pure g + either (\e -> logFM ErrorS (ls e) >> throwM err500) (pure . GraphPng) g -- server :: FilePath -> FilePath -> API AsServer server :: FilePath -> FilePath -> Flags -> ServerT (NamedRoutes API) LoggingHandler server rrdPath rrdtool flags = API { getMetrics = getMetricsHandler rrdPath rrdtool + , getStats = getStatsHandler , getFlags = getFlagsHandler flags , putFlag = putFlagHandler flags + , postFlag = putFlagHandler flags -- This exists only for html forms } +getStatsHandler :: Maybe Range -> LoggingHandler StatsPage +getStatsHandler r = pure $ StatsPage $ do + H5.h2_ "Traffic" + H5.img_ [H5.src_ (src Traffic)] + H5.h2_ "Memory" + H5.img_ [H5.src_ (src Memory)] + H5.h2_ "Ratelimit" + H5.img_ [H5.src_ (src RateLimit)] + where + src m = "/" <> toUrlPiece (fieldLink getMetrics m r) + servantApp :: LogEnv -> FilePath -> FilePath -> Flags -> Application servantApp le rrdPath rrdtool flags = genericServeT (toHandler le) (server rrdPath rrdtool flags) @@ -85,3 +147,4 @@ toHandler :: LogEnv -> (forall a. LoggingHandler a -> Handler a) toHandler le (LoggingHandler k) = runKatipContextT le () "http" k + From 45277e02dae48f27915e78c3097c5069222cfc27 Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Mon, 12 Oct 2026 14:55:30 +0300 Subject: [PATCH 3/5] htmx flags --- src/HttpServer.hs | 64 +++++++++++++++++++++++++++++++++++++---------- 1 file changed, 51 insertions(+), 13 deletions(-) diff --git a/src/HttpServer.hs b/src/HttpServer.hs index e00d0d1..e01d656 100644 --- a/src/HttpServer.hs +++ b/src/HttpServer.hs @@ -17,20 +17,22 @@ import Data.Maybe (fromMaybe) import Data.Map.Strict (Map) import qualified Data.Set as S import Data.Text (Text) -import HomeAssistant.Runtime.Flags (Flags, allFlags, setEnabled, validNames) +import HomeAssistant.Runtime.Flags (Flags, allFlags, setEnabled, validNames, isEnabled) import Control.Exception.Annotated (checkpoint, Annotation (Annotation)) import Servant.Server.Generic (genericServeT) import Network.Wai (Application) import Network.HTTP.Media ((//)) import HomeAssistant.Runtime.Graphing (Graph (..), Range (..), lookupGraph, graphs, renderGraph) -import Katip (KatipContextT, Katip, runKatipContextT, LogEnv, KatipContext, ls, Severity (..), logFM) -import Data.Aeson (ToJSON, FromJSON) -import Lucid (ToHtml, toHtml, renderBS, toHtmlRaw, HtmlT) +import Katip (KatipContextT, Katip, runKatipContextT, LogEnv, KatipContext, ls, Severity (..), logFM, katipAddContext, sl) +import Data.Aeson (ToJSON (toJSON), FromJSON, object, (.=)) +import Lucid (ToHtml, toHtml, renderBS, toHtmlRaw, HtmlT, Attributes) import qualified Lucid.Html5 as H5 import qualified Data.Map.Strict as M import Data.Foldable (for_) import qualified Data.Text as T import Web.FormUrlEncoded (FromForm, fromForm, parseUnique) +import Lucid.Base (makeAttributes) +import Data.Aeson.Key (fromText) data ImagePng @@ -56,12 +58,13 @@ instance ToHtml StatsPage where toHtml (StatsPage inner) = H5.doctypehtml_ $ H5.body_ inner toHtmlRaw = toHtml + data API mode = API { getMetrics :: mode :- "metrics" :> Capture "graph" Graph :> QueryParam "range" Range :> Get '[ImagePng] GraphPng , getStats :: mode :- "stats" :> QueryParam "range" Range :> Get '[HTML] StatsPage , getFlags :: mode :- "flags" :> Get '[JSON, HTML] FlagsResponse - , putFlag :: mode :- "flags" :> Capture "name" Text :> ReqBody '[JSON] FlagValue :> Put '[JSON] FlagsResponse - , postFlag :: mode :- "flags" :> Capture "name" Text :> ReqBody '[JSON, FormUrlEncoded] FlagValue :> Post '[JSON, HTML] FlagsResponse + , putFlag :: mode :- "flags" :> Capture "name" Text :> ReqBody '[JSON, FormUrlEncoded] FlagValue :> Put '[HTML, JSON] FlagResponse + , postFlag :: mode :- "flags" :> Capture "name" Text :> ReqBody '[JSON, FormUrlEncoded] FlagValue :> Post '[JSON, HTML] FlagResponse } deriving Generic @@ -76,17 +79,52 @@ instance FromForm FlagValue where newtype FlagsResponse = FlagsResponse (Map Text Bool) deriving (ToJSON) via (Map Text Bool) +data FlagResponse = FlagResponse Text Bool + +instance ToHtml FlagResponse where + toHtml (FlagResponse name value) = flagRow name value + toHtmlRaw = toHtml + +instance ToJSON FlagResponse where + toJSON (FlagResponse k v) = object [fromText k .= v] + flagsPage :: Monad m => FlagsResponse -> HtmlT m () -flagsPage (FlagsResponse f) = H5.doctypehtml_ $ - H5.body_ $ H5.table_ $ for_ (M.toList f) $ \(k,v) -> H5.tr_ $ - H5.td_ (toHtml k) <> H5.td_ (toHtml $ show v) <> H5.td_ (toggle k v) +flagsPage (FlagsResponse f) = H5.doctypehtml_ $ do + -- + H5.head_ $ do + H5.script_ + [ H5.src_ "https://cdn.jsdelivr.net/npm/htmx.org@2.0.11/dist/htmx.min.js" + , H5.integrity_ "sha384-2OatzQy1H+Zd/IIrjr1TcuDGqLXeHhbooAyJY1KdQMKnr4LZ22k31GBLdYKHmVjg" + , H5.crossorigin_ "anonymous" + ] + ("" :: Text) + H5.body_ $ H5.table_ $ for_ (M.toList f) $ \(k,v) -> H5.tr_ [H5.id_ ("status-" <> k)] $ flagRow k v + +flagRow :: Monad m => Text -> Bool -> HtmlT m () +flagRow name value = + H5.td_ (toHtml name) <> H5.td_ (toHtml $ show value) <> H5.td_ (toggle name value) where + target k = "status-" <> k toggle :: Monad m => Text -> Bool -> HtmlT m () toggle key current = H5.form_ [H5.method_ "post", H5.action_ $ postFlagsLink key] $ do H5.input_ [H5.name_ "flag-value", H5.type_ "hidden", H5.value_ (T.pack $ show (not current))] - H5.input_ [H5.type_ "submit", H5.value_ "Toggle"] + H5.input_ [H5.type_ "submit", H5.value_ "Toggle", hxTrigger "click", hxTarget ("#" <> target key), hxPut (postFlagsLink key), hxSwap "outerHtml"] postFlagsLink k = "/" <> toUrlPiece (fieldLink putFlag k) +hxTrigger :: Text -> Attributes +hxTrigger = makeAttributes "hx-trigger" + +hxTarget :: Text -> Attributes +hxTarget = makeAttributes "hx-target" + +hxPut :: Text -> Attributes +hxPut = makeAttributes "hx-put" + +hxSwap :: Text -> Attributes +hxSwap = makeAttributes "hx-swap" + instance ToHtml FlagsResponse where toHtml = flagsPage toHtmlRaw = toHtml @@ -94,14 +132,14 @@ instance ToHtml FlagsResponse where getFlagsHandler :: Flags -> LoggingHandler FlagsResponse getFlagsHandler = fmap FlagsResponse . allFlags -putFlagHandler :: Flags -> Text -> FlagValue -> LoggingHandler FlagsResponse +putFlagHandler :: Flags -> Text -> FlagValue -> LoggingHandler FlagResponse putFlagHandler flags name (FlagValue val) | name `S.notMember` validNames flags = throwM err404 - | otherwise = do + | otherwise = checkpoint (Annotation (name, val)) $ katipAddContext (sl "flag" (name, val)) $ do setEnabled flags name val `catch` \e -> do logFM ErrorS (ls ("failed to persist handler flag: " <> show (e :: SomeException))) throwM err500 - FlagsResponse <$> allFlags flags + FlagResponse name <$> isEnabled flags name getMetricsHandler :: FilePath -> FilePath -> Graph -> Maybe Range -> LoggingHandler GraphPng From 3a6fe26d0c394f33e3980dfeba68d3da6e022c40 Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Mon, 12 Oct 2026 15:17:07 +0300 Subject: [PATCH 4/5] List of ranges --- src/HomeAssistant/Runtime/Graphing.hs | 1 + src/HttpServer.hs | 6 +++++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/src/HomeAssistant/Runtime/Graphing.hs b/src/HomeAssistant/Runtime/Graphing.hs index b34a95a..97e8281 100644 --- a/src/HomeAssistant/Runtime/Graphing.hs +++ b/src/HomeAssistant/Runtime/Graphing.hs @@ -13,6 +13,7 @@ module HomeAssistant.Runtime.Graphing , readProcessBytes , Graph(..) , renderGraph + , rangeSuffix ) where import Control.Exception (evaluate) diff --git a/src/HttpServer.hs b/src/HttpServer.hs index e01d656..36928a7 100644 --- a/src/HttpServer.hs +++ b/src/HttpServer.hs @@ -22,7 +22,7 @@ import Control.Exception.Annotated (checkpoint, Annotation (Annotation)) import Servant.Server.Generic (genericServeT) import Network.Wai (Application) 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 Data.Aeson (ToJSON (toJSON), FromJSON, object, (.=)) import Lucid (ToHtml, toHtml, renderBS, toHtmlRaw, HtmlT, Attributes) @@ -163,6 +163,9 @@ server rrdPath rrdtool flags = API getStatsHandler :: Maybe Range -> LoggingHandler StatsPage 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.img_ [H5.src_ (src Traffic)] H5.h2_ "Memory" @@ -171,6 +174,7 @@ getStatsHandler r = pure $ StatsPage $ do H5.img_ [H5.src_ (src RateLimit)] where src m = "/" <> toUrlPiece (fieldLink getMetrics m r) + flagWithRange range = "/" <> toUrlPiece (fieldLink getStats (Just range)) servantApp :: LogEnv -> FilePath -> FilePath -> Flags -> Application servantApp le rrdPath rrdtool flags = genericServeT (toHandler le) (server rrdPath rrdtool flags) From 7d5103ac90922f5c12f7a45be457dc7138a09250 Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Mon, 12 Oct 2026 16:05:32 +0300 Subject: [PATCH 5/5] Pretty --- home-assistant-controller.cabal | 4 +- src/HttpServer.hs | 104 +++++++++++++++++++++++--------- test/HttpServerSpec.hs | 64 ++++++++++++++++++++ test/Main.hs | 2 + 4 files changed, 146 insertions(+), 28 deletions(-) create mode 100644 test/HttpServerSpec.hs diff --git a/home-assistant-controller.cabal b/home-assistant-controller.cabal index 392e124..c422e07 100644 --- a/home-assistant-controller.cabal +++ b/home-assistant-controller.cabal @@ -181,6 +181,7 @@ test-suite home-assistant-controller-test , ConnectionSpec , FlagsSpec , GraphingSpec + , HttpServerSpec , KitchenSpec , LivingroomSpec , MetricsSpec @@ -224,4 +225,5 @@ test-suite home-assistant-controller-test unordered-containers, process, directory, - temporary + temporary, + lucid2 diff --git a/src/HttpServer.hs b/src/HttpServer.hs index 36928a7..a6eead9 100644 --- a/src/HttpServer.hs +++ b/src/HttpServer.hs @@ -7,7 +7,7 @@ import Control.Monad.IO.Class (liftIO, MonadIO) import qualified Data.ByteString as BS import Data.Void (Void) import Network.Wai.Handler.Warp (run) -import Servant.API ((:>), Capture, Get, QueryParam, (:-), MimeRender (..), Accept (..), NamedRoutes, JSON, ReqBody, Put, Post, FormUrlEncoded) +import Servant.API ((:>), Capture, Get, QueryParam, (:-), MimeRender (..), Accept (..), NamedRoutes, JSON, ReqBody, Put, Post, FormUrlEncoded, Header) import Data.ByteString (ByteString) import GHC.Generics (Generic) import Servant (Handler, err404, fieldLink, toUrlPiece) @@ -55,13 +55,36 @@ instance ToHtml a => MimeRender HTML a where newtype StatsPage = StatsPage (forall m. Monad m => HtmlT m ()) instance ToHtml StatsPage where - toHtml (StatsPage inner) = H5.doctypehtml_ $ H5.body_ inner + toHtml (StatsPage inner) = inner toHtmlRaw = toHtml +page_ :: Monad m => HtmlT m () -> HtmlT m () +page_ inner = H5.doctypehtml_ $ do + H5.head_ $ do + H5.script_ + [ H5.src_ "https://cdn.jsdelivr.net/npm/htmx.org@2.0.11/dist/htmx.min.js" + , H5.integrity_ "sha384-2OatzQy1H+Zd/IIrjr1TcuDGqLXeHhbooAyJY1KdQMKnr4LZ22k31GBLdYKHmVjg" + , H5.crossorigin_ "anonymous" + ] + ("" :: Text) + H5.style_ css + H5.body_ inner + +css :: Text +css = T.unlines + [ "body { font-family: system-ui, sans-serif; margin: 1rem auto; max-width: 40rem; padding: 0 1rem; }" + , "table { border-collapse: collapse; }" + , "th, td { padding: 0.4rem 0.75rem; border-bottom: 1px solid #ddd; text-align: left; }" + , "input[type=submit] { padding: 0.25rem 0.75rem; cursor: pointer; }" + , "img { max-width: 100%; }" + ] + + +type HxRequest = Header "HX-Request" Bool data API mode = API { getMetrics :: mode :- "metrics" :> Capture "graph" Graph :> QueryParam "range" Range :> Get '[ImagePng] GraphPng - , getStats :: mode :- "stats" :> QueryParam "range" Range :> Get '[HTML] StatsPage + , getStats :: mode :- "stats" :> HxRequest :> QueryParam "range" Range :> Get '[HTML] StatsPage , getFlags :: mode :- "flags" :> Get '[JSON, HTML] FlagsResponse , putFlag :: mode :- "flags" :> Capture "name" Text :> ReqBody '[JSON, FormUrlEncoded] FlagValue :> Put '[HTML, JSON] FlagResponse , postFlag :: mode :- "flags" :> Capture "name" Text :> ReqBody '[JSON, FormUrlEncoded] FlagValue :> Post '[JSON, HTML] FlagResponse @@ -89,30 +112,36 @@ instance ToJSON FlagResponse where toJSON (FlagResponse k v) = object [fromText k .= v] flagsPage :: Monad m => FlagsResponse -> HtmlT m () -flagsPage (FlagsResponse f) = H5.doctypehtml_ $ do - -- - H5.head_ $ do - H5.script_ - [ H5.src_ "https://cdn.jsdelivr.net/npm/htmx.org@2.0.11/dist/htmx.min.js" - , H5.integrity_ "sha384-2OatzQy1H+Zd/IIrjr1TcuDGqLXeHhbooAyJY1KdQMKnr4LZ22k31GBLdYKHmVjg" - , H5.crossorigin_ "anonymous" - ] - ("" :: Text) - H5.body_ $ H5.table_ $ for_ (M.toList f) $ \(k,v) -> H5.tr_ [H5.id_ ("status-" <> k)] $ flagRow k v +flagsPage (FlagsResponse f) = page_ $ + H5.table_ $ do + H5.tr_ $ do + H5.th_ "Name" + H5.th_ "Value" + H5.th_ "" + for_ (M.toList f) $ uncurry flagRow flagRow :: Monad m => Text -> Bool -> HtmlT m () -flagRow name value = - H5.td_ (toHtml name) <> H5.td_ (toHtml $ show value) <> H5.td_ (toggle name value) +flagRow name value = H5.tr_ [H5.id_ (rowId name)] $ do + H5.td_ (toHtml name) + H5.td_ (toHtml (if value then "on" else "off" :: Text)) + H5.td_ (toggle name value) where - target k = "status-" <> k toggle :: Monad m => Text -> Bool -> HtmlT m () - toggle key current = H5.form_ [H5.method_ "post", H5.action_ $ postFlagsLink key] $ do - H5.input_ [H5.name_ "flag-value", H5.type_ "hidden", H5.value_ (T.pack $ show (not current))] - H5.input_ [H5.type_ "submit", H5.value_ "Toggle", hxTrigger "click", hxTarget ("#" <> target key), hxPut (postFlagsLink key), hxSwap "outerHtml"] + toggle key current = H5.form_ [H5.method_ "post", H5.action_ (postFlagsLink key)] $ do + H5.input_ [H5.name_ "flag-value", H5.type_ "hidden", H5.value_ (T.pack (show (not current)))] + H5.input_ + [ H5.type_ "submit" + , H5.value_ (if current then "Disable" else "Enable") + , hxTrigger "click" + , hxTarget ("#" <> rowId key) + , hxPut (postFlagsLink key) + , hxSwap "outerHTML" + ] postFlagsLink k = "/" <> toUrlPiece (fieldLink putFlag k) +rowId :: Text -> Text +rowId = ("status-" <>) + hxTrigger :: Text -> Attributes hxTrigger = makeAttributes "hx-trigger" @@ -122,6 +151,12 @@ hxTarget = makeAttributes "hx-target" hxPut :: Text -> Attributes hxPut = makeAttributes "hx-put" +hxGet :: Text -> Attributes +hxGet = makeAttributes "hx-get" + +hxPushUrl :: Text -> Attributes +hxPushUrl = makeAttributes "hx-push-url" + hxSwap :: Text -> Attributes hxSwap = makeAttributes "hx-swap" @@ -161,11 +196,16 @@ server rrdPath rrdtool flags = API , postFlag = putFlagHandler flags -- This exists only for html forms } -getStatsHandler :: Maybe Range -> LoggingHandler StatsPage -getStatsHandler r = pure $ StatsPage $ do - H5.ul_ $ do - for_ [minBound..maxBound] $ \range -> - H5.li_ $ H5.a_ [H5.href_ $ flagWithRange range] $ toHtml $ rangeSuffix range +statsPage :: Maybe Bool -> Maybe Range -> StatsPage +statsPage hx r = StatsPage $ + if hx == Just True + then statsContent r + else page_ (statsContent r) + +statsContent :: Monad m => Maybe Range -> HtmlT m () +statsContent r = H5.div_ [H5.id_ "stats"] $ do + H5.ul_ $ for_ [minBound..maxBound] $ \range -> + H5.li_ $ H5.a_ (link range) $ toHtml $ rangeSuffix range H5.h2_ "Traffic" H5.img_ [H5.src_ (src Traffic)] H5.h2_ "Memory" @@ -174,7 +214,17 @@ getStatsHandler r = pure $ StatsPage $ do H5.img_ [H5.src_ (src RateLimit)] where src m = "/" <> toUrlPiece (fieldLink getMetrics m r) - flagWithRange range = "/" <> toUrlPiece (fieldLink getStats (Just range)) + link range = + let url = "/" <> toUrlPiece (fieldLink getStats (Just range)) + in [ H5.href_ url + , hxGet url + , hxTarget "#stats" + , hxSwap "outerHTML" + , hxPushUrl "true" + ] + +getStatsHandler :: Maybe Bool -> Maybe Range -> LoggingHandler StatsPage +getStatsHandler hx r = pure (statsPage hx r) servantApp :: LogEnv -> FilePath -> FilePath -> Flags -> Application servantApp le rrdPath rrdtool flags = genericServeT (toHandler le) (server rrdPath rrdtool flags) diff --git a/test/HttpServerSpec.hs b/test/HttpServerSpec.hs new file mode 100644 index 0000000..2b5956b --- /dev/null +++ b/test/HttpServerSpec.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HttpServerSpec (spec) where + +import qualified Data.Map.Strict as M +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Lazy.Encoding (decodeUtf8) +import qualified Data.Text.Lazy as TL +import Lucid (Html, renderBS, toHtml) +import Test.Hspec + +import HomeAssistant.Runtime.Graphing (Range (..)) +import HttpServer + +render :: Html () -> String +render = TL.unpack . decodeUtf8 . renderBS + +spec :: Spec +spec = describe "HttpServer" $ do + describe "flagRow" $ do + it "renders the whole row so htmx can outerHTML-swap it" $ + render (flagRow "tea" True) `shouldContain` "" + + it "requests an outerHTML swap (htmx casing)" $ + render (flagRow "tea" True) `shouldContain` "hx-swap=\"outerHTML\"" + + it "displays on with a Disable button when enabled" $ do + let html = render (flagRow "tea" True) + html `shouldContain` "on" + html `shouldContain` "value=\"Disable\"" + + it "displays off with an Enable button when disabled" $ do + let html = render (flagRow "tea" False) + html `shouldContain` "off" + html `shouldContain` "value=\"Enable\"" + + describe "flagsPage" $ do + let page = flagsPage (FlagsResponse (M.fromList [("tea" :: Text, True)])) + it "uses the shared page shell with a style block" $ + render page `shouldContain` "Name" + html `shouldContain` "Value" + + it "carries each row id exactly once" $ + T.count "id=\"status-tea\"" (T.pack (render page)) `shouldBe` 1 + + describe "statsPage" $ do + it "uses the shared page shell with a style block (full page)" $ + render (toHtml (statsPage Nothing Nothing)) `shouldContain` "" + + it "range links swap the stats fragment in place" $ do + let html = render (toHtml (statsPage Nothing (Just OneDay))) + html `shouldContain` "hx-get=\"/stats?range=24h\"" + html `shouldContain` "hx-target=\"#stats\"" + html `shouldContain` "hx-push-url=\"true\"" diff --git a/test/Main.hs b/test/Main.hs index d3e2db1..88ee50c 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -8,6 +8,7 @@ import qualified BusSpec import qualified ConnectionSpec import qualified FlagsSpec import qualified GraphingSpec +import qualified HttpServerSpec import qualified KitchenSpec import qualified LivingroomSpec import qualified MetricsSpec @@ -23,6 +24,7 @@ main = hspec $ do ConnectionSpec.spec FlagsSpec.spec GraphingSpec.spec + HttpServerSpec.spec KitchenSpec.spec LivingroomSpec.spec MetricsSpec.spec