Pretty

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

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
+flagsPage (FlagsResponse f) = page_ $
-  --   <script src="https://cdn.jsdelivr.net/npm/htmx.org@2.0.11/dist/htmx.min.js"
+  H5.table_ $ do
-          -- integrity="sha384-2OatzQy1H+Zd/IIrjr1TcuDGqLXeHhbooAyJY1KdQMKnr4LZ22k31GBLdYKHmVjg"
+    H5.tr_ $ do
-          -- crossorigin="anonymous"></script>
+      H5.th_ "Name"
-    H5.head_ $ do
+      H5.th_ "Value"
-      H5.script_
+      H5.th_ ""
-        [ H5.src_ "https://cdn.jsdelivr.net/npm/htmx.org@2.0.11/dist/htmx.min.js"
+    for_ (M.toList f) $ uncurry flagRow
-        , 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 =
+flagRow name value = H5.tr_ [H5.id_ (rowId name)] $ do
-      H5.td_ (toHtml name) <> H5.td_  (toHtml $ show value) <> H5.td_ (toggle name value)
+  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
+    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.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"]
+      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
+statsPage :: Maybe Bool -> Maybe Range -> StatsPage
-getStatsHandler r = pure $ StatsPage $ do
+statsPage hx r = StatsPage $
-  H5.ul_ $ do
+  if hx == Just True
-    for_ [minBound..maxBound] $ \range ->
+    then statsContent r
-      H5.li_ $ H5.a_ [H5.href_ $ flagWithRange range] $ toHtml $ rangeSuffix range
+    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)

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` "<tr id=\"status-tea\">"
+
+    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` "<td>on</td>"
+      html `shouldContain` "value=\"Disable\""
+
+    it "displays off with an Enable button when disabled" $ do
+      let html = render (flagRow "tea" False)
+      html `shouldContain` "<td>off</td>"
+      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` "<style"
+
+    it "has a header row" $ do
+      let html = render page
+      html `shouldContain` "<th>Name</th>"
+      html `shouldContain` "<th>Value</th>"
+
+    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` "<style"
+
+    it "serves a bare fragment for htmx requests" $ do
+      let html = render (toHtml (statsPage (Just True) (Just OneDay)))
+      html `shouldNotContain` "DOCTYPE"
+      html `shouldContain` "<div id=\"stats\">"
+
+    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\""

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