{-# 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 = (Request -> URI) -> Maybe Request -> Maybe URI
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Request -> URI
getUri (Maybe Request -> Maybe URI)
-> ([Char] -> Maybe Request) -> [Char] -> Maybe URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Maybe Request
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 <- IO Manager
forall (m :: * -> *). MonadIO m => m Manager
newTlsManager
    URIAuth
gn <- IO URIAuth
-> (URIAuth -> IO URIAuth) -> Maybe URIAuth -> IO URIAuth
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> IO URIAuth
forall a. HasCallStack => [Char] -> a
error [Char]
"Invalid URI Authority") URIAuth -> IO URIAuth
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe URIAuth
gatewayName
    Request
requestUri <- URI -> IO Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
requestFromURI (URI -> IO Request) -> URI -> IO Request
forall a b. (a -> b) -> a -> b
$ [Char] -> URIAuth -> Text -> Labels -> URI
buildUri [Char]
scheme URIAuth
gn Text
jobName Labels
labels
    IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO RegistrySample
getSample IO RegistrySample
-> (RegistrySample -> IO (Response ())) -> IO (Response ())
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Request -> Manager -> IO (Response ()))
-> Manager -> Request -> IO (Response ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip Request -> Manager -> IO (Response ())
httpNoBody Manager
manager (Request -> IO (Response ()))
-> (RegistrySample -> Request)
-> RegistrySample
-> IO (Response ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> RegistrySample -> Request
request Request
requestUri IO (Response ()) -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
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 = methodPut
            , requestBody = RequestBodyLBS . toLazyByteString $ encodeMetrics sample
            , requestHeaders = [(hContentType, "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 = scheme
        , uriAuthority = Just gatewayName
        , uriPath = "/metrics/job/" ++ unpack jobName ++ foldMapWithKey labelPath ls
        }
  where
    labelPath :: Text -> Text -> [Char]
labelPath Text
k Text
v = [Char]
"/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
unpack Text
k [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
unpack Text
v