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.Types                    (hContentType, methodPut)
import           Network.HTTP.Client.TLS               (newTlsManager)
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 :: URI               -- ^ PushGateway URI name, including port number (ex: @parseUri https://myGateway.com:8080@)
            -> Text              -- ^ Job name
            -> Labels            -- ^ Label set to use as a grouping key for metrics
            -> Int               -- ^ Microsecond push frequency
            -> IO RegistrySample -- ^ Action to get latest metrics
            -> 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