fradrive-old/src/Utils/Metrics.hs

module Utils.Metrics
  ( withHealthReportMetrics
  , registerGHCMetrics
  , observeHTTPRequestLatency
  , registerReadyMetric
  , withJobWorkerStateLbls
  , observeYesodCacheSize
  , observeFavouritesQuickActionsDuration
  , LoginOutcome(..), observeLoginOutcome
  ) where

import Import.NoModel hiding (Vector, Info)
import Model
import Prometheus
import Prometheus.Metric.GHC

import qualified Data.List as List

import System.Clock
import Data.Time.Clock.POSIX

import Network.Wai (Middleware)
import qualified Network.Wai as Wai
import qualified Network.HTTP.Types as HTTP

import Yesod.Core.Types (HandlerData(..), GHState(..))

{-# ANN module ("HLint: ignore Use even" :: String) #-}


histogramBuckets :: Rational -- ^ min
                 -> Rational -- ^ max
                 -> [Double]
histogramBuckets bMin bMax = map fromRational . takeWhile (<= bMax) . go bMin $ List.cycle factors
  where
    go n []     = [n]
    go n (f:fs) = n : go (f * n) fs

    factors
      | bMin' `mod` 2 == 0 = [2.5, 2, 2]
      | bMin' `mod` 5 == 0 = [2, 2, 2.5]
      | otherwise          = [2, 2.5, 2]
      where
        bMin' :: Integer
        bMin' = floor . List.head . dropWhile (< 1) $ List.iterate (* 10) bMin


{-# NOINLINE healthReportTime #-}
healthReportTime :: Vector Label2 Gauge
healthReportTime = unsafeRegister . vector ("check", "status") $ gauge info
  where
    info = Info "uni2work_health_check_time"
                "POSIXTime of last health check performed by this Uni2work-instance"

{-# NOINLINE healthReportDuration #-}
healthReportDuration :: Vector Label2 Histogram
healthReportDuration = unsafeRegister . vector ("check", "status") $ histogram info buckets
  where
    info = Info "uni2work_health_check_duration_seconds"
                "Duration of last health check performed by this Uni2work-instance"
    buckets = histogramBuckets 5e-6 100e-3

{-# NOINLINE httpRequestLatency #-}
httpRequestLatency :: Vector Label3 Histogram
httpRequestLatency = unsafeRegister . vector ("handler", "method", "status") $ histogram info buckets
  where info = Info "http_request_duration_seconds"
                    "HTTP request latency"
        buckets = histogramBuckets 50e-6 500

data ReadySince = MkReadySince

readyMetric :: POSIXTime -> Metric ReadySince
readyMetric ts = Metric $ return (MkReadySince, collectReadySince)
  where
    collectReadySince = return [SampleGroup info GaugeType [Sample "ready_time" [] sample]]
    info = Info "ready_time"
                "POSIXTime this Uni2work-instance became ready"
    sample = encodeUtf8 $ tshow (realToFrac ts :: Nano)

{-# NOINLINE jobWorkerStateDuration #-}
jobWorkerStateDuration :: Vector Label4 Histogram
jobWorkerStateDuration = unsafeRegister . vector ("worker", "state", "jobctl", "task") $ histogram info buckets
  where info = Info "uni2work_job_worker_state_duration_seconds"
                    "Duration of time a Uni2work job executor spent in a certain state"
        buckets = histogramBuckets 1e-6 500

{-# NOINLINE jobWorkerStateTransitions #-}
jobWorkerStateTransitions :: Vector Label4 Counter
jobWorkerStateTransitions = unsafeRegister . vector ("worker", "state", "jobctl", "task") $ counter info
  where info = Info "uni2work_job_worker_state_transitions_total"
                    "Number of times a Uni2work job executor entered a certain state"

{-# NOINLINE yesodCacheSize #-}
yesodCacheSize :: Histogram
yesodCacheSize = unsafeRegister $ histogram info buckets
  where info = Info "yesod_ghs_cache_items"
                    "Number of items in Yesod's ghsCache and ghsCacheBy"
        buckets = 0 : histogramBuckets 1 1e6

{-# NOINLINE favouritesQuickActionsDuration #-}
favouritesQuickActionsDuration :: Histogram
favouritesQuickActionsDuration = unsafeRegister $ histogram info buckets
  where info = Info "uni2work_favourites_quick_actions_seconds"
                    "Duration of time needed to calculate a set of favourite quick actions"
        buckets = histogramBuckets 500e-6 50

{-# NOINLINE loginOutcomes #-}
loginOutcomes :: Vector Label2 Counter
loginOutcomes = unsafeRegister . vector ("plugin", "outcome") $ counter info
  where info = Info "uni2work_login_attempts_total"
                    "Number of login attempts"


withHealthReportMetrics :: MonadIO m => m HealthReport -> m HealthReport
withHealthReportMetrics act = do
  before <- liftIO $ getTime Monotonic
  report <- act
  after <- liftIO $ getTime Monotonic

  let checkVal = toPathPiece $ classifyHealthReport report
      statusVal = toPathPiece $ healthReportStatus report
      timeSample, durationSample :: Double
      timeSample = realToFrac (realToFrac after :: Nano)
      durationSample = realToFrac (realToFrac $ after - before :: Nano)
  liftIO $ withLabel healthReportTime (checkVal, statusVal) $ flip setGauge timeSample
  liftIO $ withLabel healthReportDuration (checkVal, statusVal) $ flip observe durationSample

  return report

registerGHCMetrics :: MonadIO m => m ()
registerGHCMetrics = void $ register ghcMetrics

observeHTTPRequestLatency :: forall site. ParseRoute site => (Route site -> String) -> Middleware
observeHTTPRequestLatency classifyHandler app req respond' = do
  start <- getTime Monotonic
  app req $ \res -> do
    end <- getTime Monotonic
    let method  = decodeUtf8 $ Wai.requestMethod req
        status  = tshow . HTTP.statusCode $ Wai.responseStatus res
        route :: Maybe (Route site)
        route   = parseRoute ( Wai.pathInfo req
                             , over (mapped . _2) (fromMaybe "") . HTTP.queryToQueryText $ Wai.queryString req
                             )
        handler' = pack . classifyHandler <$> route

        labels :: Label3
        labels = (fromMaybe "n/a" handler', method, status)
    withLabel httpRequestLatency labels . flip observe . realToFrac $ end - start

    respond' res

registerReadyMetric :: MonadIO m => m ()
registerReadyMetric = liftIO $ void . register . readyMetric =<< getPOSIXTime

withJobWorkerStateLbls :: (MonadIO m, MonadMask m) => Label4 -> m a -> m a
withJobWorkerStateLbls newLbls act = do
  liftIO $ withLabel jobWorkerStateTransitions newLbls incCounter

  start <- liftIO $ getTime Monotonic
  res <- handleAll (return . Left) $ Right <$> act
  end <- liftIO $ getTime Monotonic

  liftIO . withLabel jobWorkerStateDuration newLbls . flip observe . realToFrac $ end - start

  either throwM return res

observeYesodCacheSize :: MonadHandler m => m ()
observeYesodCacheSize = do
  HandlerData{handlerState} <- liftHandler ask
  liftIO $ do
    GHState{..} <- readIORef handlerState
    let size = fromIntegral $ length ghsCache + length ghsCacheBy
    observe yesodCacheSize size

observeFavouritesQuickActionsDuration :: (MonadIO m, MonadMask m) => m a -> m a
observeFavouritesQuickActionsDuration act = do
  start <- liftIO $ getTime Monotonic
  res <- handleAll (return . Left) $ Right <$> act
  end <- liftIO $ getTime Monotonic

  liftIO . observe favouritesQuickActionsDuration . realToFrac $ end - start

  either throwM return res

data LoginOutcome
  = LoginSuccessful
  | LoginInvalidCredentials
  | LoginError
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
  deriving anyclass (Universe, Finite)
nullaryPathPiece ''LoginOutcome $ camelToPathPiece' 1

observeLoginOutcome :: MonadHandler m
                    => Text -- ^ Plugin
                    -> LoginOutcome
                    -> m ()
observeLoginOutcome plugin outcome
  = liftIO $ withLabel loginOutcomes (plugin, toPathPiece outcome) incCounter