From 45277e02dae48f27915e78c3097c5069222cfc27 Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Mon, 12 Oct 2026 14:55:30 +0300 Subject: [PATCH] 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