htmx flags

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
+  --   <script src="https://cdn.jsdelivr.net/npm/htmx.org@2.0.11/dist/htmx.min.js"
+          -- integrity="sha384-2OatzQy1H+Zd/IIrjr1TcuDGqLXeHhbooAyJY1KdQMKnr4LZ22k31GBLdYKHmVjg"
+          -- crossorigin="anonymous"></script>
+    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