{-# 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 :: [Char] -> 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)
-> ([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 :: 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 ([Char] -> IO URIAuth
forall a. HasCallStack => [Char] -> a
error [Char]
"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
$ [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 (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 [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 (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, 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 = URIAuth -> Maybe URIAuth
forall a. a -> Maybe a
Just URIAuth
gatewayName
    , uriPath :: [Char]
uriPath      = [Char]
"/metrics/job/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
unpack Text
jobName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Text -> Text -> [Char]) -> Map Text Text -> [Char]
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]
"/" [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