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..c422e07 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 @@ -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 diff --git a/src/AFRP.hs b/src/AFRP.hs index 4fcb319..11da618 100644 --- a/src/AFRP.hs +++ b/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 diff --git a/src/HomeAssistant/Controller/Children.hs b/src/HomeAssistant/Controller/Children.hs index 65767df..24e3b1e 100644 --- a/src/HomeAssistant/Controller/Children.hs +++ b/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 diff --git a/src/HomeAssistant/Runtime/Graphing.hs b/src/HomeAssistant/Runtime/Graphing.hs index b34a95a..97e8281 100644 --- a/src/HomeAssistant/Runtime/Graphing.hs +++ b/src/HomeAssistant/Runtime/Graphing.hs @@ -13,6 +13,7 @@ module HomeAssistant.Runtime.Graphing , readProcessBytes , Graph(..) , renderGraph + , rangeSuffix ) where import Control.Exception (evaluate) diff --git a/src/HttpServer.hs b/src/HttpServer.hs index 4ff3521..a6eead9 100644 --- a/src/HttpServer.hs +++ b/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 + diff --git a/test/HttpServerSpec.hs b/test/HttpServerSpec.hs new file mode 100644 index 0000000..2b5956b --- /dev/null +++ b/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` "" + + 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` "on" + html `shouldContain` "value=\"Disable\"" + + it "displays off with an Enable button when disabled" $ do + let html = render (flagRow "tea" False) + html `shouldContain` "off" + 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` "Name" + html `shouldContain` "Value" + + 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` "" + + 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\"" diff --git a/test/Main.hs b/test/Main.hs index d3e2db1..88ee50c 100644 --- a/test/Main.hs +++ b/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