Pretty
This commit is contained in:
MasseR committed
1 parent
3a6fe26d0c
commit
7d5103ac90
4 files changed
+146
-28
No files matched your search
+77
-27
@@ -7,7 +7,7 @@ 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, Post, FormUrlEncoded)
|
||||
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, fieldLink, toUrlPiece)
|
||||
@@ -55,13 +55,36 @@ instance ToHtml a => MimeRender HTML a where
|
||||
newtype StatsPage = StatsPage (forall m. Monad m => HtmlT m ())
|
||||
|
||||
instance ToHtml StatsPage where
|
||||
toHtml (StatsPage inner) = H5.doctypehtml_ $ H5.body_ inner
|
||||
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] GraphPng
|
||||
, getStats :: mode :- "stats" :> QueryParam "range" Range :> Get '[HTML] StatsPage
|
||||
, 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
|
||||
@@ -89,30 +112,36 @@ instance ToJSON FlagResponse where
|
||||
toJSON (FlagResponse k v) = object [fromText k .= v]
|
||||
|
||||
flagsPage :: Monad m => FlagsResponse -> HtmlT m ()
|
||||
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
|
||||
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.td_ (toHtml name) <> H5.td_ (toHtml $ show value) <> H5.td_ (toggle name value)
|
||||
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
|
||||
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", hxTrigger "click", hxTarget ("#" <> target key), hxPut (postFlagsLink key), hxSwap "outerHtml"]
|
||||
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"
|
||||
|
||||
@@ -122,6 +151,12 @@ 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"
|
||||
|
||||
@@ -161,11 +196,16 @@ server rrdPath rrdtool flags = API
|
||||
, postFlag = putFlagHandler flags -- This exists only for html forms
|
||||
}
|
||||
|
||||
getStatsHandler :: Maybe Range -> LoggingHandler StatsPage
|
||||
getStatsHandler r = pure $ StatsPage $ do
|
||||
H5.ul_ $ do
|
||||
for_ [minBound..maxBound] $ \range ->
|
||||
H5.li_ $ H5.a_ [H5.href_ $ flagWithRange range] $ toHtml $ rangeSuffix range
|
||||
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"
|
||||
@@ -174,7 +214,17 @@ getStatsHandler r = pure $ StatsPage $ do
|
||||
H5.img_ [H5.src_ (src RateLimit)]
|
||||
where
|
||||
src m = "/" <> toUrlPiece (fieldLink getMetrics m r)
|
||||
flagWithRange range = "/" <> toUrlPiece (fieldLink getStats (Just range))
|
||||
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)
|
||||
|
||||
Reference in new issue
Block a user