61 lines
2.1 KiB
Haskell
61 lines
2.1 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Handler.Metrics
|
|
( getMetricsR
|
|
) where
|
|
|
|
import Import hiding (Info, samples, singleSample)
|
|
|
|
import Prometheus
|
|
import qualified Network.Wai.Middleware.Prometheus as Prometheus
|
|
|
|
import qualified Data.Text as Text
|
|
import qualified Data.HashSet as HashSet
|
|
import qualified Data.HashMap.Strict as HashMap
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
|
|
getMetricsR :: Handler TypedContent
|
|
getMetricsR = selectRep $ do
|
|
provideRep (sendWaiApplication Prometheus.metricsApp :: Handler Text)
|
|
provideRep metricsHtml
|
|
provideRep $ collectMetrics >>= returnJson
|
|
where
|
|
metricsHtml :: Handler Html
|
|
metricsHtml = do
|
|
let metricSort = comparing $ \(SampleGroup Info{..} _ mSamples) -> (metricName, mSamples <&> \(Sample sampleName lbls _) -> (sampleName, lbls))
|
|
samples <- sortBy metricSort <$> collectMetrics
|
|
|
|
metricsBearer <- runMaybeT . hoist runDB $ do
|
|
guardM $ hasGlobalGetParam GetGenerateToken
|
|
uid <- MaybeT maybeAuthId
|
|
guardM . lift . existsBy $ UniqueUserGroupMember UserGroupMetrics uid
|
|
|
|
encodeBearer =<< bearerToken (HashSet.singleton . Left $ toJSON UserGroupMetrics) Nothing (HashMap.singleton BearerTokenRouteEval $ 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 = nubOrd . concatMap (\(Sample _ lPairs _) -> lPairs ^.. folded . _1)
|
|
singleSample base [Sample sName lPairs sValue]
|
|
| sName == base = Just (lPairs, sValue)
|
|
singleSample _ _ = Nothing
|
|
|
|
showMetricName metricName mSamples = Set.size (Set.fromList sampleBasenames) > 1
|
|
where
|
|
sampleBasenames = do
|
|
Sample sName _ _ <- mSamples
|
|
return $ metricBasename metricName sName
|