46 lines
1.4 KiB
Haskell
46 lines
1.4 KiB
Haskell
module Handler.Metrics
|
|
( getMetricsR
|
|
) where
|
|
|
|
import Import hiding (Info)
|
|
|
|
import Prometheus
|
|
import qualified Network.Wai.Middleware.Prometheus as Prometheus
|
|
|
|
import qualified Data.Text as Text
|
|
import qualified Data.HashSet as HashSet
|
|
|
|
|
|
getMetricsR :: Handler TypedContent
|
|
getMetricsR = selectRep $ do
|
|
provideRep (sendWaiApplication Prometheus.metricsApp :: Handler Text)
|
|
provideRep metricsHtml
|
|
provideRep $ collectMetrics >>= returnJson
|
|
where
|
|
metricsHtml :: Handler Html
|
|
metricsHtml = do
|
|
samples <- collectMetrics
|
|
|
|
metricsToken <- runMaybeT . hoist runDB $ do
|
|
uid <- MaybeT maybeAuthId
|
|
guardM . lift . existsBy $ UniqueUserGroupMember UserGroupMetrics uid
|
|
|
|
encodeToken =<< bearerToken (Left $ toJSON UserGroupMetrics) (Just $ HashSet.singleton MetricsR) Nothing (Just Nothing) Nothing
|
|
|
|
defaultLayout $ do
|
|
setTitleI MsgTitleMetrics
|
|
$(widgetFile "metrics")
|
|
|
|
metricBasename base sName
|
|
| Just suffix <- Text.stripPrefix base sName
|
|
= if | Just suffix' <- Text.stripPrefix "_" suffix
|
|
-> suffix'
|
|
| otherwise
|
|
-> suffix
|
|
| otherwise
|
|
= sName
|
|
getLabels = nub . concatMap (\(Sample _ lPairs _) -> lPairs ^.. folded . _1)
|
|
singleSample base [Sample sName lPairs sValue]
|
|
| sName == base = Just (lPairs, sValue)
|
|
singleSample _ _ = Nothing
|