{-# 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 :: [Char] -> Maybe URI
parseURI = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Request -> URI
getUri forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadThrow m => [Char] -> m Request
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 :: URI -> Text -> Labels -> Int -> IO RegistrySample -> IO ()
pushMetrics URI
gatewayURI Text
jobName Labels
labels Int
frequencyMicros IO RegistrySample
getSample = do
    Manager
manager <- forall (m :: * -> *). MonadIO m => m Manager
newTlsManager
    URIAuth
gn <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => [Char] -> a
error [Char]
"Invalid URI Authority") forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe URIAuth
gatewayName
    Request
requestUri <- forall (m :: * -> *). MonadThrow m => URI -> m Request
requestFromURI forall a b. (a -> b) -> a -> b
$ [Char] -> URIAuth -> Text -> Labels -> URI
buildUri [Char]
scheme URIAuth
gn Text
jobName Labels
labels
    forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ IO RegistrySample
getSample forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip Request -> Manager -> IO (Response ())
httpNoBody Manager
manager forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> RegistrySample -> Request
request Request
requestUri forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
threadDelay Int
frequencyMicros
  where
    URI [Char]
scheme Maybe URIAuth
gatewayName [Char]
_ [Char]
_ [Char]
_ = URI
gatewayURI
    request :: Request -> RegistrySample -> Request
request Request
req RegistrySample
sample =
        Request
req
            { method :: ByteString
method = ByteString
methodPut
            , requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyLBS forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString forall a b. (a -> b) -> a -> b
$ RegistrySample -> Builder
encodeMetrics RegistrySample
sample
            , requestHeaders :: RequestHeaders
requestHeaders = [(HeaderName
hContentType, ByteString
"text/plain; version=0.0.4")]
            }


buildUri :: String -> URIAuth -> Text -> Labels -> URI
buildUri :: [Char] -> URIAuth -> Text -> Labels -> URI
buildUri [Char]
scheme URIAuth
gatewayName Text
jobName (Labels Map Text Text
ls) =
    URI
nullURI
        { uriScheme :: [Char]
uriScheme = [Char]
scheme
        , uriAuthority :: Maybe URIAuth
uriAuthority = forall a. a -> Maybe a
Just URIAuth
gatewayName
        , uriPath :: [Char]
uriPath = [Char]
"/metrics/job/" forall a. [a] -> [a] -> [a]
++ Text -> [Char]
unpack Text
jobName forall a. [a] -> [a] -> [a]
++ forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
foldMapWithKey Text -> Text -> [Char]
labelPath Map Text Text
ls
        }
  where
    labelPath :: Text -> Text -> [Char]
labelPath Text
k Text
v = [Char]
"/" forall a. [a] -> [a] -> [a]
++ Text -> [Char]
unpack Text
k forall a. [a] -> [a] -> [a]
++ [Char]
"/" forall a. [a] -> [a] -> [a]
++ Text -> [Char]
unpack Text
v