Push.hs

{-# LANGUAGE OverloadedStrings #-}

module System.Metrics.Prometheus.Http.Push (
    pushMetrics,
    parseURI,
) where

import Control.Concurrent (threadDelay)
import Control.Monad (forever)
import Data.ByteString.Builder (toLazyByteString)
import Data.Map (foldMapWithKey)
import Data.Text (Text, unpack)
import Network.HTTP.Client (
    Request (..),
    RequestBody (..),
    getUri,
    httpNoBody,
    parseRequest,
    requestBody,
    requestFromURI,
    requestHeaders,
 )
import Network.HTTP.Client.TLS (newTlsManager)
import Network.HTTP.Types (hContentType, methodPut)
import Network.URI (
    URI (..),
    URIAuth,
    nullURI,
 )

import System.Metrics.Prometheus.Encode.Text (encodeMetrics)
import System.Metrics.Prometheus.MetricId (Labels (..))
import System.Metrics.Prometheus.Registry (RegistrySample)


-- | Parses a uri such that
-- @
--   parseURI "https://example.com"
--      ===
--   Just (URI "https:" "//example.com"
-- @
parseURI :: String -> Maybe URI
parseURI = fmap getUri . parseRequest


pushMetrics ::
    -- | PushGateway URI name, including port number (ex: @parseUri https://myGateway.com:8080@)
    URI ->
    -- | Job name
    Text ->
    -- | Label set to use as a grouping key for metrics
    Labels ->
    -- | Microsecond push frequency
    Int ->
    -- | Action to get latest metrics
    IO RegistrySample ->
    IO ()
pushMetrics gatewayURI jobName labels frequencyMicros getSample = do
    manager <- newTlsManager
    gn <- maybe (error "Invalid URI Authority") pure gatewayName
    requestUri <- requestFromURI $ buildUri scheme gn jobName labels
    forever $ getSample >>= flip httpNoBody manager . request requestUri >> threadDelay frequencyMicros
  where
    URI scheme gatewayName _ _ _ = gatewayURI
    request req sample =
        req
            { method = methodPut
            , requestBody = RequestBodyLBS . toLazyByteString $ encodeMetrics sample
            , requestHeaders = [(hContentType, "text/plain; version=0.0.4")]
            }


buildUri :: String -> URIAuth -> Text -> Labels -> URI
buildUri scheme gatewayName jobName (Labels ls) =
    nullURI
        { uriScheme = scheme
        , uriAuthority = Just gatewayName
        , uriPath = "/metrics/job/" ++ unpack jobName ++ foldMapWithKey labelPath ls
        }
  where
    labelPath k v = "/" ++ unpack k ++ "/" ++ unpack v