{-# 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)
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 ::
URI ->
Text ->
Labels ->
Int ->
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