{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.Wai.Middleware.Prometheus
( prometheus
, PrometheusSettings(..)
, Default.def
, instrumentHandlerValue
, instrumentApp
, instrumentIO
, metricsApp
) where
import qualified Data.Default as Default
import Data.Maybe (fromMaybe)
import Data.Ratio ((%))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import qualified Network.HTTP.Types as HTTP
import qualified Network.Wai as Wai
import qualified Prometheus as Prom
import System.Clock (Clock(..), TimeSpec, diffTimeSpec, getTime, toNanoSecs)
data PrometheusSettings = PrometheusSettings {
prometheusEndPoint :: [T.Text]
, prometheusInstrumentApp :: Bool
, prometheusInstrumentPrometheus :: Bool
}
instance Default.Default PrometheusSettings where
def = PrometheusSettings {
prometheusEndPoint = ["metrics"]
, prometheusInstrumentApp = True
, prometheusInstrumentPrometheus = True
}
{-# NOINLINE requestLatency #-}
requestLatency :: Prom.Vector Prom.Label3 Prom.Histogram
requestLatency = Prom.unsafeRegister $ Prom.vector ("handler", "method", "status_code")
$ Prom.histogram info Prom.defaultBuckets
where info = Prom.Info "http_request_duration_seconds"
"The HTTP request latencies in seconds."
instrumentHandlerValue ::
(Wai.Request -> Text)
-> Wai.Application
-> Wai.Application
instrumentHandlerValue f app req respond = do
start <- getTime Monotonic
app req $ \res -> do
end <- getTime Monotonic
let method = Just $ decodeUtf8 (Wai.requestMethod req)
let status = Just $ T.pack (show (HTTP.statusCode (Wai.responseStatus res)))
observeSeconds (f req) method status start end
respond res
instrumentApp ::
Text
-> Wai.Application
-> Wai.Application
instrumentApp handler app req respond =
instrumentHandlerValue (const handler) app req respond
instrumentIO :: Text
-> IO a
-> IO a
instrumentIO label io = do
start <- getTime Monotonic
result <- io
end <- getTime Monotonic
observeSeconds label Nothing Nothing start end
return result
observeSeconds :: Text -> Maybe Text -> Maybe Text -> TimeSpec -> TimeSpec -> IO ()
observeSeconds handler method status start end = do
let latency = fromRational $ toRational (toNanoSecs (end `diffTimeSpec` start) % 1000000000)
Prom.withLabel requestLatency
(handler, fromMaybe "" method, fromMaybe "" status)
(flip Prom.observe latency)
prometheus :: PrometheusSettings -> Wai.Middleware
prometheus PrometheusSettings{..} app req respond =
if Wai.requestMethod req == HTTP.methodGet
&& Wai.pathInfo req == prometheusEndPoint
then
if prometheusInstrumentPrometheus
then instrumentApp "prometheus" (const respondWithMetrics) req respond
else respondWithMetrics respond
else
if prometheusInstrumentApp
then instrumentApp "app" app req respond
else app req respond
metricsApp :: Wai.Application
metricsApp = const respondWithMetrics
respondWithMetrics :: (Wai.Response -> IO Wai.ResponseReceived)
-> IO Wai.ResponseReceived
respondWithMetrics respond = do
metrics <- Prom.exportMetricsAsText
respond $ Wai.responseLBS HTTP.status200 headers metrics
where
headers = [(HTTP.hContentType, "text/plain; version=0.0.4")]