Pretty

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