module Prometheus.Servant
  ( prometheusMiddleware
  , Metrics (..)
  , defaultMetrics
  , RequestLatencyMetric
  , ActiveRequestsMetric
  ) where

import Control.Exception (finally)
import Data.Data (Proxy)
import Data.Ratio ((%))
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Network.HTTP.Types (Status (..))
import Network.Wai (Middleware, responseStatus)
import Prometheus qualified as P
import System.Clock
  ( Clock (Monotonic)
  , diffTimeSpec
  , getTime
  , s2ns
  , toNanoSecs
  )

import Prometheus.Servant.Internal (Endpoint (..), HasEndpoint (..))

-- | 'Middleware' to observe 'Metrics'.
prometheusMiddleware
  :: (P.Label mLatencyLabel, P.Label mActiveLabel, HasEndpoint api)
  => Metrics mLatencyLabel mActiveLabel
  -> Proxy api
  -> Middleware
prometheusMiddleware :: forall {k} mLatencyLabel mActiveLabel (api :: k).
(Label mLatencyLabel, Label mActiveLabel, HasEndpoint api) =>
Metrics mLatencyLabel mActiveLabel -> Proxy api -> Middleware
prometheusMiddleware Metrics{RequestLatencyMetric mLatencyLabel
ActiveRequestsMetric mActiveLabel
Endpoint -> mActiveLabel
Endpoint -> Status -> mLatencyLabel
mGetActiveLabels :: forall mLatencyLabel mActiveLabel.
Metrics mLatencyLabel mActiveLabel -> Endpoint -> mActiveLabel
mActive :: forall mLatencyLabel mActiveLabel.
Metrics mLatencyLabel mActiveLabel
-> ActiveRequestsMetric mActiveLabel
mGetLatencyLabels :: forall mLatencyLabel mActiveLabel.
Metrics mLatencyLabel mActiveLabel
-> Endpoint -> Status -> mLatencyLabel
mLatency :: forall mLatencyLabel mActiveLabel.
Metrics mLatencyLabel mActiveLabel
-> RequestLatencyMetric mLatencyLabel
mGetActiveLabels :: Endpoint -> mActiveLabel
mActive :: ActiveRequestsMetric mActiveLabel
mGetLatencyLabels :: Endpoint -> Status -> mLatencyLabel
mLatency :: RequestLatencyMetric mLatencyLabel
..} Proxy api
proxy Application
application Request
request Response -> IO ResponseReceived
sendResponse = do
  case forall {k} (api :: k).
HasEndpoint api =>
Proxy api -> Request -> Maybe Endpoint
getEndpoint Proxy api
proxy Request
request of
    Just Endpoint
endpoint -> do
      let mActiveLabel :: mActiveLabel
mActiveLabel = Endpoint -> mActiveLabel
mGetActiveLabels Endpoint
endpoint
      !TimeSpec
start <- Clock -> IO TimeSpec
getTime Clock
Monotonic
      forall label (m :: * -> *) metric.
(Label label, MonadMonitor m) =>
Vector label metric -> label -> (metric -> IO ()) -> m ()
P.withLabel ActiveRequestsMetric mActiveLabel
mActive mActiveLabel
mActiveLabel forall (m :: * -> *). MonadMonitor m => Gauge -> m ()
P.incGauge
      Application
application Request
request forall a b. (a -> b) -> a -> b
$ \Response
response -> do
        let mLatencyLabel :: mLatencyLabel
mLatencyLabel = Endpoint -> Status -> mLatencyLabel
mGetLatencyLabels Endpoint
endpoint (Response -> Status
responseStatus Response
response)
        Response -> IO ResponseReceived
sendResponse Response
response forall a b. IO a -> IO b -> IO a
`finally` do
          !TimeSpec
end <- Clock -> IO TimeSpec
getTime Clock
Monotonic
          let latency :: Double
latency = forall a. Fractional a => Rational -> a
fromRational forall a b. (a -> b) -> a -> b
$ TimeSpec -> Integer
toNanoSecs (TimeSpec
end TimeSpec -> TimeSpec -> TimeSpec
`diffTimeSpec` TimeSpec
start) forall a. Integral a => a -> a -> Ratio a
% forall a. Num a => a
s2ns
          forall label (m :: * -> *) metric.
(Label label, MonadMonitor m) =>
Vector label metric -> label -> (metric -> IO ()) -> m ()
P.withLabel RequestLatencyMetric mLatencyLabel
mLatency mLatencyLabel
mLatencyLabel forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall metric (m :: * -> *).
(Observer metric, MonadMonitor m) =>
metric -> Double -> m ()
P.observe Double
latency
          forall label (m :: * -> *) metric.
(Label label, MonadMonitor m) =>
Vector label metric -> label -> (metric -> IO ()) -> m ()
P.withLabel ActiveRequestsMetric mActiveLabel
mActive mActiveLabel
mActiveLabel forall (m :: * -> *). MonadMonitor m => Gauge -> m ()
P.decGauge
    Maybe Endpoint
Nothing -> Application
application Request
request Response -> IO ResponseReceived
sendResponse

-- | Supported metrics and a function to get relevant labels from 'Endpoint'.
data Metrics mLatencyLabel mActiveLabel = Metrics
  { forall mLatencyLabel mActiveLabel.
Metrics mLatencyLabel mActiveLabel
-> RequestLatencyMetric mLatencyLabel
mLatency :: RequestLatencyMetric mLatencyLabel
  , forall mLatencyLabel mActiveLabel.
Metrics mLatencyLabel mActiveLabel
-> Endpoint -> Status -> mLatencyLabel
mGetLatencyLabels :: Endpoint -> Status -> mLatencyLabel
  , forall mLatencyLabel mActiveLabel.
Metrics mLatencyLabel mActiveLabel
-> ActiveRequestsMetric mActiveLabel
mActive :: ActiveRequestsMetric mActiveLabel
  , forall mLatencyLabel mActiveLabel.
Metrics mLatencyLabel mActiveLabel -> Endpoint -> mActiveLabel
mGetActiveLabels :: Endpoint -> mActiveLabel
  }

-- | Default 'Metrics'.
defaultMetrics :: Metrics P.Label3 P.Label2
defaultMetrics :: Metrics Label3 Label2
defaultMetrics =
  Metrics
    { mLatency :: RequestLatencyMetric Label3
mLatency = RequestLatencyMetric Label3
mHttpRequestLatency
    , mGetLatencyLabels :: Endpoint -> Status -> Label3
mGetLatencyLabels = Endpoint -> Status -> Label3
getHttpRequestLatencyLabels
    , mActive :: ActiveRequestsMetric Label2
mActive = ActiveRequestsMetric Label2
mHttpActiveRequests
    , mGetActiveLabels :: Endpoint -> Label2
mGetActiveLabels = Endpoint -> Label2
getHttpActiveRequestsLabels
    }

-- | Request latency metric parametrized with some label @l@.
type RequestLatencyMetric l = P.Vector l P.Histogram

-- | Metric to measure HTTP server request latency.
mHttpRequestLatency :: RequestLatencyMetric P.Label3
mHttpRequestLatency :: RequestLatencyMetric Label3
mHttpRequestLatency =
  forall s. Metric s -> s
P.unsafeRegister
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l m. Label l => l -> Metric m -> Metric (Vector l m)
P.vector (Text
"route_name", Text
"method", Text
"status_code")
    forall a b. (a -> b) -> a -> b
$ Info -> [Double] -> Metric Histogram
P.histogram Info
i [Double]
P.defaultBuckets
  where
    i :: Info
i =
      Text -> Text -> Info
P.Info
        Text
"http_request_duration_seconds"
        Text
"The HTTP server request latencies in seconds."
{-# NOINLINE mHttpRequestLatency #-}

-- | Defines how to get labels for 'mHttpRequestLatency' from 'Endpoint'.
getHttpRequestLatencyLabels :: Endpoint -> Status -> P.Label3
getHttpRequestLatencyLabels :: Endpoint -> Status -> Label3
getHttpRequestLatencyLabels Endpoint{[Text]
Method
eMethod :: Endpoint -> Method
ePathSegments :: Endpoint -> [Text]
eMethod :: Method
ePathSegments :: [Text]
..} Status
status =
  ( Text
"/" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"/" [Text]
ePathSegments
  , Method -> Text
T.decodeUtf8 Method
eMethod
  , String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Status -> Int
statusCode Status
status
  )

-- | Active requests metric parametrized with some label @l@.
type ActiveRequestsMetric l = P.Vector l P.Gauge

-- | Metric to track HTTP active requests.
mHttpActiveRequests :: ActiveRequestsMetric P.Label2
mHttpActiveRequests :: ActiveRequestsMetric Label2
mHttpActiveRequests =
  forall s. Metric s -> s
P.unsafeRegister
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l m. Label l => l -> Metric m -> Metric (Vector l m)
P.vector (Text
"route_name", Text
"method")
    forall a b. (a -> b) -> a -> b
$ Info -> Metric Gauge
P.gauge Info
i
  where
    i :: Info
i =
      Text -> Text -> Info
P.Info
        Text
"http_active_requests"
        Text
"The HTTP active requests."
{-# NOINLINE mHttpActiveRequests #-}

-- | Defines how to get labels for 'mHttpActiveRequests' from 'Endpoint'.
getHttpActiveRequestsLabels :: Endpoint -> P.Label2
getHttpActiveRequestsLabels :: Endpoint -> Label2
getHttpActiveRequestsLabels Endpoint{[Text]
Method
eMethod :: Method
ePathSegments :: [Text]
eMethod :: Endpoint -> Method
ePathSegments :: Endpoint -> [Text]
..} =
  ( Text
"/" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"/" [Text]
ePathSegments
  , Method -> Text
T.decodeUtf8 Method
eMethod
  )