\subsection{Cardano.BM.Backend.Prometheus}
\label{module:Cardano.BM.Backend.Prometheus}

%if style == newcode
\begin{code}

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiWayIf #-}

module Cardano.BM.Backend.Prometheus
    ( spawnPrometheus
    ) where

import qualified Control.Concurrent.Async as Async
import           Control.Monad.IO.Class (MonadIO (..))
import qualified Data.HashMap.Strict as HM
import qualified Data.Aeson as A
import           Data.Aeson ((.=))
import           Data.ByteString.Builder
import           Data.ByteString.Char8 (ByteString)
import           Data.List (find, partition)
import           Data.Maybe (fromJust)
import           Data.Text (Text)
import qualified Data.Text as T
import           Data.Text.Encoding (encodeUtf8)
import           Data.Text.Read (double)
import           GHC.Generics
import           Snap.Core (Snap, route, writeLBS)
import           Snap.Http.Server (Config, ConfigLog (..), defaultConfig, setAccessLog,
                     setBind, setErrorLog, setPort, simpleHttpServe)
import           System.Metrics (Value (..), sampleAll)
import qualified System.Remote.Monitoring as EKG

\end{code}
%endif

\subsubsection{Spawn Prometheus client from existing EKG server}
\label{code:spawnPrometheus}\index{spawnPrometheus}
\begin{code}

data MetricsGroup = MetricsGroup
    { MetricsGroup -> Text
namespace :: !Text
    , MetricsGroup -> [Metric]
metrics   :: ![Metric]
    } deriving ((forall x. MetricsGroup -> Rep MetricsGroup x)
-> (forall x. Rep MetricsGroup x -> MetricsGroup)
-> Generic MetricsGroup
forall x. Rep MetricsGroup x -> MetricsGroup
forall x. MetricsGroup -> Rep MetricsGroup x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MetricsGroup x -> MetricsGroup
$cfrom :: forall x. MetricsGroup -> Rep MetricsGroup x
Generic, [MetricsGroup] -> Encoding
[MetricsGroup] -> Value
MetricsGroup -> Encoding
MetricsGroup -> Value
(MetricsGroup -> Value)
-> (MetricsGroup -> Encoding)
-> ([MetricsGroup] -> Value)
-> ([MetricsGroup] -> Encoding)
-> ToJSON MetricsGroup
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [MetricsGroup] -> Encoding
$ctoEncodingList :: [MetricsGroup] -> Encoding
toJSONList :: [MetricsGroup] -> Value
$ctoJSONList :: [MetricsGroup] -> Value
toEncoding :: MetricsGroup -> Encoding
$ctoEncoding :: MetricsGroup -> Encoding
toJSON :: MetricsGroup -> Value
$ctoJSON :: MetricsGroup -> Value
A.ToJSON)

data Metric
    = NoMetric
    | Metric
        { Metric -> Text
mName  :: !Text
        , Metric -> Text
mType  :: !Text
        , Metric -> Number
mValue :: !Number
        }

instance A.ToJSON Metric where
    toJSON :: Metric -> Value
toJSON Metric
NoMetric = Value
A.Null
    toJSON (Metric Text
n Text
t Number
v) = [Pair] -> Value
A.object [Text
"name" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
n, Text
"type" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
t, Text
"value" Text -> Number -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Number
v]

data Number
    = NumberInt Integer
    | NumberReal Double

instance A.ToJSON Number where
    toJSON :: Number -> Value
toJSON (NumberInt Integer
i)  = Scientific -> Value
A.Number (Scientific -> Value) -> Scientific -> Value
forall a b. (a -> b) -> a -> b
$ Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger Integer
i
    toJSON (NumberReal Double
r) = Scientific -> Value
A.Number (Scientific -> Value) -> Scientific -> Value
forall a b. (a -> b) -> a -> b
$ Rational -> Scientific
forall a. Fractional a => Rational -> a
fromRational (Double -> Rational
forall a. Real a => a -> Rational
toRational Double
r)

spawnPrometheus :: EKG.Server -> ByteString -> Int -> Maybe Text -> IO (Async.Async ())
spawnPrometheus :: Server -> ByteString -> Int -> Maybe Text -> IO (Async ())
spawnPrometheus Server
ekg ByteString
host Int
port Maybe Text
prometheusOutput = IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
Async.async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$
    Config Snap Any -> Snap () -> IO ()
forall (m :: * -> *) a.
MonadSnap m =>
Config m a -> Snap () -> IO ()
simpleHttpServe Config Snap Any
forall a. Config Snap a
config Snap ()
site
  where
    config :: Config Snap a
    config :: Config Snap a
config = Int -> Config Snap a -> Config Snap a
forall (m :: * -> *) a. Int -> Config m a -> Config m a
setPort Int
port (Config Snap a -> Config Snap a)
-> (Config Snap a -> Config Snap a)
-> Config Snap a
-> Config Snap a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Config Snap a -> Config Snap a
forall (m :: * -> *) a. ByteString -> Config m a -> Config m a
setBind ByteString
host (Config Snap a -> Config Snap a)
-> (Config Snap a -> Config Snap a)
-> Config Snap a
-> Config Snap a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigLog -> Config Snap a -> Config Snap a
forall (m :: * -> *) a. ConfigLog -> Config m a -> Config m a
setAccessLog ConfigLog
lg (Config Snap a -> Config Snap a)
-> (Config Snap a -> Config Snap a)
-> Config Snap a
-> Config Snap a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigLog -> Config Snap a -> Config Snap a
forall (m :: * -> *) a. ConfigLog -> Config m a -> Config m a
setErrorLog ConfigLog
lg (Config Snap a -> Config Snap a) -> Config Snap a -> Config Snap a
forall a b. (a -> b) -> a -> b
$ Config Snap a
forall (m :: * -> *) a. MonadSnap m => Config m a
defaultConfig
    lg :: ConfigLog
lg = ConfigLog
ConfigNoLog
    site :: Snap ()
    site :: Snap ()
site = [(ByteString, Snap ())] -> Snap ()
forall (m :: * -> *) a. MonadSnap m => [(ByteString, m a)] -> m a
route [ (ByteString
"/metrics/", Server -> Snap ()
webhandler Server
ekg) ]
    webhandler :: EKG.Server -> Snap ()
    webhandler :: Server -> Snap ()
webhandler Server
srv = do
        Sample
samples <- IO Sample -> Snap Sample
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Sample -> Snap Sample) -> IO Sample -> Snap Sample
forall a b. (a -> b) -> a -> b
$ Store -> IO Sample
sampleAll (Store -> IO Sample) -> Store -> IO Sample
forall a b. (a -> b) -> a -> b
$ Server -> Store
EKG.serverMetricStore Server
srv
        let output :: ByteString
output = case Maybe Text
prometheusOutput of
                         Maybe Text
Nothing     -> Sample -> ByteString
renderSimpleOutput Sample
samples
                         Just Text
"json" -> Sample -> ByteString
renderJSONOutput Sample
samples
                         Just Text
_      -> Sample -> ByteString
renderSimpleOutput Sample
samples
        ByteString -> Snap ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeLBS ByteString
output
        () -> Snap ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    -- Simple output: key value.

    renderSimpleOutput :: Sample -> ByteString
renderSimpleOutput = Builder -> ByteString
toLazyByteString (Builder -> ByteString)
-> (Sample -> Builder) -> Sample -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Value)] -> Builder
renderSamples ([(Text, Value)] -> Builder)
-> (Sample -> [(Text, Value)]) -> Sample -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sample -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HM.toList

    renderSamples :: [(Text, Value)] -> Builder
    renderSamples :: [(Text, Value)] -> Builder
renderSamples [] = Builder
forall a. Monoid a => a
mempty
    renderSamples [(Text, Value)]
samples = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
        [ case Value
sv of
            Counter Int64
c -> Text -> Builder -> Builder
renderNamedValue Text
sk (Int64 -> Builder
int64Dec Int64
c)
            Gauge Int64
g -> Text -> Builder -> Builder
renderNamedValue Text
sk (Int64 -> Builder
int64Dec Int64
g)
            Label Text
l -> if Text -> Bool
isFloat Text
l
                         then Text -> Builder -> Builder
renderNamedValue Text
sk (ByteString -> Builder
byteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
l)
                         else Builder
forall a. Monoid a => a
mempty
            Value
_ -> Builder
forall a. Monoid a => a
mempty
        | (Text
sk,Value
sv) <- [(Text, Value)]
samples ]
    renderNamedValue :: Text -> Builder -> Builder
    renderNamedValue :: Text -> Builder -> Builder
renderNamedValue Text
nm Builder
bld =
        (ByteString -> Builder
byteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
prepareName Text
nm)
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
charUtf8 Char
' '
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
bld
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
charUtf8 Char
'\n'
    prepareName :: Text -> ByteString
prepareName Text
nm = Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text
T.replace Text
" " Text
"_" (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text
T.replace Text
"-" Text
"_" (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text
T.replace Text
"." Text
"_" Text
nm
    isFloat :: Text -> Bool
isFloat Text
v = case Reader Double
double Text
v of
        Right (Double
_n, Text
"") -> Bool
True  -- only floating point number parsed, no leftover
        Either String (Double, Text)
_ -> Bool
False

    -- JSON output

    renderJSONOutput :: Sample -> ByteString
renderJSONOutput Sample
samples =
        let rtsNamespace :: Text
rtsNamespace = Text
"rts.gc"
            ([(Text, Value)]
rtsSamples, [(Text, Value)]
otherSamples) = ((Text, Value) -> Bool)
-> [(Text, Value)] -> ([(Text, Value)], [(Text, Value)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(Text
sk, Value
_) -> Text
rtsNamespace Text -> Text -> Bool
`T.isPrefixOf` Text
sk) ([(Text, Value)] -> ([(Text, Value)], [(Text, Value)]))
-> [(Text, Value)] -> ([(Text, Value)], [(Text, Value)])
forall a b. (a -> b) -> a -> b
$ Sample -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HM.toList Sample
samples
            rtsMetrics :: MetricsGroup
rtsMetrics = Text -> [(Text, Value)] -> MetricsGroup
extractRtsGcMetrics Text
rtsNamespace [(Text, Value)]
rtsSamples
            otherMetrics :: MetricsGroup
otherMetrics = [(Text, Value)] -> MetricsGroup
extractOtherMetrics [(Text, Value)]
otherSamples
        in [MetricsGroup] -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode [MetricsGroup
rtsMetrics, MetricsGroup
otherMetrics]

    -- rts.gc metrics are always here because they are predefined in ekg-core,
    -- so we can group them.
    extractRtsGcMetrics :: Text -> [(Text, Value)] -> MetricsGroup
    extractRtsGcMetrics :: Text -> [(Text, Value)] -> MetricsGroup
extractRtsGcMetrics Text
ns [(Text, Value)]
samples = MetricsGroup :: Text -> [Metric] -> MetricsGroup
MetricsGroup
        { namespace :: Text
namespace = Text
ns
        , metrics :: [Metric]
metrics =
            [ case Value
sv of
                Counter Int64
c -> Text -> Int64 -> Metric
forall a. Integral a => Text -> a -> Metric
intMetric Text
sk Int64
c
                Gauge Int64
g   -> Text -> Int64 -> Metric
forall a. Integral a => Text -> a -> Metric
intMetric Text
sk Int64
g
                Value
_         -> Metric
NoMetric -- rts.gc can contain Counter or Gauge only.
            | (Text
sk, Value
sv) <- [(Text, Value)]
samples
            ]
        }
      where
        intMetric :: Text -> a -> Metric
intMetric Text
sk a
v =
            Metric :: Text -> Text -> Number -> Metric
Metric { mName :: Text
mName  = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Text -> Text
forall a. a -> a
id (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripPrefix (Text
ns Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".") Text
sk
                   , mType :: Text
mType  = Text
"int" -- All values are Int64.
                   , mValue :: Number
mValue = Integer -> Number
NumberInt (a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
v)
                   }

    -- We cannot make any assumptions about the format of 'sk' in other samples,
    -- so group other samples into 'common' group.
    extractOtherMetrics :: [(Text, Value)] -> MetricsGroup
    extractOtherMetrics :: [(Text, Value)] -> MetricsGroup
extractOtherMetrics [(Text, Value)]
samples = MetricsGroup :: Text -> [Metric] -> MetricsGroup
MetricsGroup
        { namespace :: Text
namespace = Text
"common"
        , metrics :: [Metric]
metrics =
            [ case Value
sv of
                Counter Int64
c -> Text -> Number -> Metric
mkMetric Text
sk (Number -> Metric) -> Number -> Metric
forall a b. (a -> b) -> a -> b
$ Integer -> Number
NumberInt (Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
c)
                Gauge Int64
g   -> Text -> Number -> Metric
mkMetric Text
sk (Number -> Metric) -> Number -> Metric
forall a b. (a -> b) -> a -> b
$ Integer -> Number
NumberInt (Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
g)
                Label Text
l   -> case Reader Double
double Text
l of
                                 Left String
_       -> Metric
NoMetric
                                 Right (Double
r, Text
_) -> Text -> Number -> Metric
mkMetric Text
sk (Number -> Metric) -> Number -> Metric
forall a b. (a -> b) -> a -> b
$ Double -> Number
NumberReal Double
r
                Value
_         -> Metric
NoMetric
            | (Text
sk, Value
sv) <- [(Text, Value)]
samples
            ]
        }
      where
        mkMetric :: Text -> Number -> Metric
mkMetric Text
sk Number
number =
            let (Text
withoutType, Text
typeSuffix) = Text -> Number -> (Text, Text)
stripTypeSuffix Text
sk Number
number
            in Metric :: Text -> Text -> Number -> Metric
Metric { mName :: Text
mName = Text
withoutType, mType :: Text
mType = Text
typeSuffix, mValue :: Number
mValue = Number
number }
        stripTypeSuffix :: Text -> Number -> (Text, Text)
stripTypeSuffix Text
sk Number
number =
            let types :: [Text]
types = [Text
"us", Text
"ns", Text
"s", Text
"B", Text
"int", Text
"real"]
                parts :: [Text]
parts = Text -> Text -> [Text]
T.splitOn Text
"." Text
sk
                typeSuffix :: Text
typeSuffix = if Bool -> Bool
not (Bool -> Bool) -> ([Text] -> Bool) -> [Text] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Text] -> Bool) -> [Text] -> Bool
forall a b. (a -> b) -> a -> b
$ [Text]
parts then [Text] -> Text
forall a. [a] -> a
last [Text]
parts else Text
""
            in if Text
typeSuffix Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
types
                   then (Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripSuffix (Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
typeSuffix) Text
sk, Text
typeSuffix)
                   else case Number
number of
                            NumberInt Integer
_  -> (Text
sk, Text
"int")
                            NumberReal Double
_ -> (Text
sk, Text
"real")
\end{code}