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` "