114 lines
4.0 KiB
Haskell
114 lines
4.0 KiB
Haskell
module Utils.Metrics
|
|
( withHealthReportMetrics
|
|
, registerGHCMetrics
|
|
, observeHTTPRequestLatency
|
|
, registerReadyMetric
|
|
) where
|
|
|
|
import Import.NoFoundation hiding (Vector, Info)
|
|
import Prometheus
|
|
import Prometheus.Metric.GHC
|
|
|
|
import qualified Data.List as List
|
|
|
|
import Data.Time.Clock.POSIX
|
|
|
|
import Network.Wai (Middleware)
|
|
import qualified Network.Wai as Wai
|
|
import qualified Network.HTTP.Types as HTTP
|
|
|
|
|
|
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
|
|
{ metricName = "uni2work_health_check_time"
|
|
, metricHelp = "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
|
|
{ metricName = "uni2work_health_check_duration_seconds"
|
|
, metricHelp = "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)
|
|
|
|
|
|
withHealthReportMetrics :: MonadIO m => m HealthReport -> m HealthReport
|
|
withHealthReportMetrics act = do
|
|
before <- liftIO getPOSIXTime
|
|
report <- act
|
|
after <- liftIO getPOSIXTime
|
|
|
|
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 <- getPOSIXTime
|
|
app req $ \res -> do
|
|
end <- getPOSIXTime
|
|
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
|