Simple HTML responses

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
+, lens-aeson, lib, libsystemd-journal, lucid2, network, process
-, servant, servant-server, stm, temporary, text, time, unliftio
+, retry, servant, servant-server, stm, temporary, text, time
-, unordered-containers, uuid, wai, warp, websockets
+, 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
+    lens lens-aeson libsystemd-journal lucid2 network process retry
-    servant-server stm text time unliftio unordered-containers uuid wai
+    servant servant-server stm text time unliftio unordered-containers
-    warp websockets
+    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

src/HttpServer.hs

@@ -7,10 +7,10 @@ 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)
 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)
@@ -22,56 +22,118 @@ 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 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 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)
 
 data ImagePng
 
-instance MimeRender ImagePng ByteString where
+instance MimeRender ImagePng GraphPng where
-  mimeRender _ = BS.fromStrict
+  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) = H5.doctypehtml_ $ H5.body_ inner
+  toHtmlRaw = toHtml
 
 data API mode = API
-  { getMetrics :: mode :- "metrics" :> Capture "graph" Graph :> QueryParam "range" Range :> Get '[ImagePng] ByteString
+  { getMetrics :: mode :- "metrics" :> Capture "graph" Graph :> QueryParam "range" Range :> Get '[ImagePng] GraphPng
-  , getFlags   :: mode :- "flags" :> Get '[JSON] (Map Text Bool)
+  , getStats :: mode :- "stats" :> QueryParam "range" Range :> Get '[HTML] StatsPage
-  , putFlag    :: mode :- "flags" :> Capture "name" Text :> ReqBody '[JSON] Bool :> Put '[JSON] (Map Text Bool)
+  , 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
   }
   deriving Generic
 
+newtype GraphPng = GraphPng ByteString
 
-getFlagsHandler :: Flags -> LoggingHandler (Map Text Bool)
+newtype FlagValue = FlagValue Bool
-getFlagsHandler = allFlags
+  deriving FromJSON via Bool
 
-putFlagHandler :: Flags -> Text -> Bool -> LoggingHandler (Map Text Bool)
+instance FromForm FlagValue where
-putFlagHandler flags name val
+  fromForm f = FlagValue <$> parseUnique "flag-value" f
+
+newtype FlagsResponse = FlagsResponse (Map Text Bool)
+  deriving (ToJSON) via (Map Text Bool)
+
+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)
+  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_ "Toggle"]
+    postFlagsLink k = "/" <> toUrlPiece (fieldLink putFlag k)
+
+instance ToHtml FlagsResponse where
+  toHtml = flagsPage
+  toHtmlRaw = toHtml
+
+getFlagsHandler :: Flags -> LoggingHandler FlagsResponse
+getFlagsHandler = fmap FlagsResponse . allFlags
+
+putFlagHandler :: Flags -> Text -> FlagValue -> LoggingHandler FlagsResponse
+putFlagHandler flags name (FlagValue val)
   | name `S.notMember` validNames flags = throwM err404
   | otherwise = do
       setEnabled flags name val `catch` \e -> do
         logFM ErrorS (ls ("failed to persist handler flag: " <> show (e :: SomeException)))
         throwM err500
-      allFlags flags
+      FlagsResponse <$> allFlags flags
 
 
-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
   }
 
+getStatsHandler :: Maybe Range -> LoggingHandler StatsPage
+getStatsHandler r = pure $ StatsPage $ do
+  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)
+
 servantApp :: LogEnv -> FilePath -> FilePath -> Flags -> Application
 servantApp le rrdPath rrdtool flags = genericServeT (toHandler le) (server rrdPath rrdtool flags)
 
@@ -85,3 +147,4 @@ toHandler :: LogEnv -> (forall a.  LoggingHandler a -> Handler a)
 toHandler le (LoggingHandler k) = runKatipContextT le () "http" k
 
 
+