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
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 = nub . 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