\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 ()
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
Either String (Double, Text)
_ -> Bool
False
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]
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
| (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"
, mValue :: Number
mValue = Integer -> Number
NumberInt (a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
v)
}
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}