{-# LANGUAGE OverloadedStrings #-}

module System.Metrics.Prometheus.Http.Scrape (
    Path,
    serveMetrics,
    serveMetricsT,
    prometheusApp,
) where

import Control.Applicative ((<$>))
import Control.Monad.IO.Class (
    MonadIO,
    liftIO,
 )
import Data.Text (Text)
import Network.HTTP.Types (
    hContentType,
    methodGet,
    status200,
    status404,
 )
import Network.Wai (
    Application,
    Request,
    Response,
    pathInfo,
    requestMethod,
    responseBuilder,
    responseLBS,
 )
import Network.Wai.Handler.Warp (Port, run)

import System.Metrics.Prometheus.Concurrent.RegistryT (
    RegistryT,
    sample,
 )
import System.Metrics.Prometheus.Encode.Text (encodeMetrics)
import System.Metrics.Prometheus.Registry (RegistrySample)


-- | The HTTP web route on which to serve data
--
-- For example:
--
-- * @http://localhost:9090/metrics@ should use a path of @["metrics"]@.
-- * @http://localhost/@ should use a path of @[]@.
type Path = [Text]


serveMetrics :: MonadIO m => Port -> Path -> IO RegistrySample -> m ()
serveMetrics :: forall (m :: * -> *).
MonadIO m =>
Port -> Path -> IO RegistrySample -> m ()
serveMetrics Port
port Path
path = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Port -> Application -> IO ()
run Port
port forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> IO RegistrySample -> Application
prometheusApp Path
path


serveMetricsT :: MonadIO m => Port -> Path -> RegistryT m ()
serveMetricsT :: forall (m :: * -> *). MonadIO m => Port -> Path -> RegistryT m ()
serveMetricsT Port
port Path
path = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
MonadIO m =>
Port -> Path -> IO RegistrySample -> m ()
serveMetrics Port
port Path
path forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). Monad m => RegistryT m (IO RegistrySample)
sample


prometheusApp :: Path -> IO RegistrySample -> Application
prometheusApp :: Path -> IO RegistrySample -> Application
prometheusApp Path
path IO RegistrySample
runSample Request
request Response -> IO ResponseReceived
respond
    | Path -> Request -> Bool
isPrometheusRequest Path
path Request
request = Response -> IO ResponseReceived
respond forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RegistrySample -> Response
prometheusResponse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO RegistrySample
runSample
    | Bool
otherwise = Response -> IO ResponseReceived
respond Response
response404
  where
    prometheusResponse :: RegistrySample -> Response
prometheusResponse = Status -> ResponseHeaders -> Builder -> Response
responseBuilder Status
status200 ResponseHeaders
headers forall b c a. (b -> c) -> (a -> b) -> a -> c
. RegistrySample -> Builder
encodeMetrics
    headers :: ResponseHeaders
headers = [(HeaderName
hContentType, ByteString
"text/plain; version=0.0.4")]


response404 :: Response
response404 :: Response
response404 = Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status404 ResponseHeaders
header404 ByteString
body404
  where
    header404 :: ResponseHeaders
header404 = [(HeaderName
hContentType, ByteString
"text/plain")]
    body404 :: ByteString
body404 = ByteString
"404"


isPrometheusRequest :: Path -> Request -> Bool
isPrometheusRequest :: Path -> Request -> Bool
isPrometheusRequest Path
path Request
request = Bool
isGet Bool -> Bool -> Bool
&& Bool
matchesPath
  where
    matchesPath :: Bool
matchesPath = Request -> Path
pathInfo Request
request forall a. Eq a => a -> a -> Bool
== Path
path
    isGet :: Bool
isGet = Request -> ByteString
requestMethod Request
request forall a. Eq a => a -> a -> Bool
== ByteString
methodGet