diff --git a/default.nix b/default.nix index 25d36ee..18e609b 100644 --- a/default.nix +++ b/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 = [ diff --git a/home-assistant-controller.cabal b/home-assistant-controller.cabal index d1b45ee..392e124 100644 --- a/home-assistant-controller.cabal +++ b/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 diff --git a/src/HttpServer.hs b/src/HttpServer.hs index 4ff3521..e00d0d1 100644 --- a/src/HttpServer.hs +++ b/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 - 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) = H5.doctypehtml_ $ H5.body_ inner + toHtmlRaw = toHtml 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" :> 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 } 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) + +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 +