{-# 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 :: String -> Maybe URI
parseURI = (Request -> URI) -> Maybe Request -> Maybe URI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Request -> URI
getUri (Maybe Request -> Maybe URI)
-> (String -> Maybe Request) -> String -> Maybe URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Request
forall (m :: * -> *). MonadThrow m => String -> m Request
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 :: 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 (String -> IO URIAuth
forall a. HasCallStack => String -> a
error String
"Invalid URI Authority") URIAuth -> IO URIAuth
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
$ String -> URIAuth -> Text -> Labels -> URI
buildUri String
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 (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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
threadDelay Int
frequencyMicros
  where
    URI String
scheme Maybe URIAuth
gatewayName String
_ String
_ String
_ = URI
gatewayURI
    request :: Request -> RegistrySample -> Request
request Request
req RegistrySample
sample = Request
req
        { method :: Method
method         = Method
methodPut
        , requestBody :: RequestBody
requestBody    = ByteString -> RequestBody
RequestBodyLBS (ByteString -> RequestBody)
-> (Builder -> ByteString) -> Builder -> RequestBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString (Builder -> RequestBody) -> Builder -> RequestBody
forall a b. (a -> b) -> a -> b
$ RegistrySample -> Builder
encodeMetrics RegistrySample
sample
        , requestHeaders :: RequestHeaders
requestHeaders = [(HeaderName
hContentType, Method
"text/plain; version=0.0.4")]
        }

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