Merge pull request 'Statistics page' (#7) from statistics-page into main

Reviewed-on: #7

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 = [

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
@@ -179,6 +181,7 @@ test-suite home-assistant-controller-test
                       , ConnectionSpec
                       , FlagsSpec
                       , GraphingSpec
+                      , HttpServerSpec
                       , KitchenSpec
                       , LivingroomSpec
                       , MetricsSpec
@@ -222,4 +225,5 @@ test-suite home-assistant-controller-test
         unordered-containers,
         process,
         directory,
-        temporary
+        temporary,
+        lucid2

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

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

src/HomeAssistant/Runtime/Graphing.hs

@@ -13,6 +13,7 @@ module HomeAssistant.Runtime.Graphing
   , readProcessBytes
   , Graph(..)
   , renderGraph
+  , rangeSuffix
   ) where
 
 import Control.Exception (evaluate)

src/HttpServer.hs

@@ -7,71 +7,225 @@ 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, Header)
 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)
 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 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)
+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
 
-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) = 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] 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" :> 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
   }
   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)
+
+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) = 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.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
+    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_ (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"
+
+hxTarget :: Text -> Attributes
+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"
+
+instance ToHtml FlagsResponse where
+  toHtml = flagsPage
+  toHtmlRaw = toHtml
+
+getFlagsHandler :: Flags -> LoggingHandler FlagsResponse
+getFlagsHandler = fmap FlagsResponse . allFlags
+
+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
-      allFlags flags
+      FlagResponse name <$> isEnabled flags name
 
 
-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
   }
 
+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"
+  H5.img_ [H5.src_ (src Memory)]
+  H5.h2_ "Ratelimit"
+  H5.img_ [H5.src_ (src RateLimit)]
+  where
+    src m = "/" <> toUrlPiece (fieldLink getMetrics m r)
+    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)
 
@@ -85,3 +239,4 @@ toHandler :: LogEnv -> (forall a.  LoggingHandler a -> Handler a)
 toHandler le (LoggingHandler k) = runKatipContextT le () "http" k
 
 
+

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