{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}

-- | Encoding of ekg metrics as JSON. The encoding defined by the
-- functions in this module are standardized and used by the ekg web
-- UI. The purpose of this module is to let other web servers and
-- frameworks than the one used by the ekg package expose ekg metrics.
module System.Metrics.Json
    ( -- * Converting metrics to JSON values
      sampleToJson
    , valueToJson

      -- ** Newtype wrappers with instances
    , Sample(..)
    , Value(..)
    ) where

import Data.Aeson ((.=))
import qualified Data.Aeson.Types as A
import qualified Data.HashMap.Strict as M
import Data.Int (Int64)
import qualified Data.Text as T
import qualified System.Metrics as Metrics
import qualified System.Metrics.Distribution as Distribution

#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as KM

type KeyMap = KM.KeyMap

insertMap :: T.Text -> v -> KeyMap v -> KeyMap v
insertMap :: forall v. Text -> v -> KeyMap v -> KeyMap v
insertMap = Key -> v -> KeyMap v -> KeyMap v
forall v. Key -> v -> KeyMap v -> KeyMap v
KM.insert (Key -> v -> KeyMap v -> KeyMap v)
-> (Text -> Key) -> Text -> v -> KeyMap v -> KeyMap v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Key
K.fromText

lookupMap :: T.Text -> KeyMap v -> Maybe v
lookupMap :: forall v. Text -> KeyMap v -> Maybe v
lookupMap = Key -> KeyMap v -> Maybe v
forall v. Key -> KeyMap v -> Maybe v
KM.lookup (Key -> KeyMap v -> Maybe v)
-> (Text -> Key) -> Text -> KeyMap v -> Maybe v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Key
K.fromText
#else
type KeyMap = M.HashMap T.Text

insertMap :: T.Text -> v -> KeyMap v -> KeyMap v
insertMap = M.insert

lookupMap :: T.Text -> KeyMap v -> Maybe v
lookupMap = M.lookup
#endif

------------------------------------------------------------------------
-- * Converting metrics to JSON values


-- | Encode metrics as nested JSON objects. Each "." in the metric
-- name introduces a new level of nesting. For example, the metrics
-- @[("foo.bar", 10), ("foo.baz", "label")]@ are encoded as
--
-- > {
-- >   "foo": {
-- >     "bar": {
-- >       "type:", "c",
-- >       "val": 10
-- >     },
-- >     "baz": {
-- >       "type": "l",
-- >       "val": "label"
-- >     }
-- >   }
-- > }
--
sampleToJson :: Metrics.Sample -> A.Value
sampleToJson :: Sample -> Value
sampleToJson Sample
metrics =
    Sample -> Value -> Value
buildOne Sample
metrics (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ Value
A.emptyObject
  where
    buildOne :: M.HashMap T.Text Metrics.Value -> A.Value -> A.Value
    buildOne :: Sample -> Value -> Value
buildOne Sample
m Value
o = (Value -> Text -> Value -> Value) -> Value -> Sample -> Value
forall a k v. (a -> k -> v -> a) -> a -> HashMap k v -> a
M.foldlWithKey' Value -> Text -> Value -> Value
build Value
o Sample
m

    build :: A.Value -> T.Text -> Metrics.Value -> A.Value
    build :: Value -> Text -> Value -> Value
build Value
m Text
name Value
val = Value -> [Text] -> Value -> Value
go Value
m (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"." Text
name) Value
val

    go :: A.Value -> [T.Text] -> Metrics.Value -> A.Value
    go :: Value -> [Text] -> Value -> Value
go (A.Object Object
m) [Text
str] Value
val      = Object -> Value
A.Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object -> Object
forall v. Text -> v -> KeyMap v -> KeyMap v
insertMap Text
str Value
metric Object
m
      where metric :: Value
metric = Value -> Value
valueToJson Value
val
    go (A.Object Object
m) (Text
str:[Text]
rest) Value
val = case Text -> Object -> Maybe Value
forall v. Text -> KeyMap v -> Maybe v
lookupMap Text
str Object
m of
        Maybe Value
Nothing -> Object -> Value
A.Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object -> Object
forall v. Text -> v -> KeyMap v -> KeyMap v
insertMap Text
str (Value -> [Text] -> Value -> Value
go Value
A.emptyObject [Text]
rest Value
val) Object
m
        Just Value
m' -> Object -> Value
A.Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object -> Object
forall v. Text -> v -> KeyMap v -> KeyMap v
insertMap Text
str (Value -> [Text] -> Value -> Value
go Value
m' [Text]
rest Value
val) Object
m
    go Value
v [Text]
_ Value
_                        = String -> Value -> Value
forall a. String -> Value -> a
typeMismatch String
"Object" Value
v

typeMismatch :: String   -- ^ The expected type
             -> A.Value  -- ^ The actual value encountered
             -> a
typeMismatch :: forall a. String -> Value -> a
typeMismatch String
expected Value
actual =
    String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"when expecting a " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
expected String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", encountered " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++
    String
" instead"
  where
    name :: String
name = case Value
actual of
        A.Object Object
_ -> String
"Object"
        A.Array Array
_  -> String
"Array"
        A.String Text
_ -> String
"String"
        A.Number Scientific
_ -> String
"Number"
        A.Bool Bool
_   -> String
"Boolean"
        Value
A.Null     -> String
"Null"

-- | Encodes a single metric as a JSON object. Example:
--
-- > {
-- >   "type": "c",
-- >   "val": 89460
-- > }
--
valueToJson :: Metrics.Value -> A.Value
valueToJson :: Value -> Value
valueToJson (Metrics.Counter Int64
n)      = Int64 -> MetricType -> Value
forall a. ToJSON a => a -> MetricType -> Value
scalarToJson Int64
n MetricType
CounterType
valueToJson (Metrics.Gauge Int64
n)        = Int64 -> MetricType -> Value
forall a. ToJSON a => a -> MetricType -> Value
scalarToJson Int64
n MetricType
GaugeType
valueToJson (Metrics.Label Text
l)        = Text -> MetricType -> Value
forall a. ToJSON a => a -> MetricType -> Value
scalarToJson Text
l MetricType
LabelType
valueToJson (Metrics.Distribution Stats
l) = Stats -> Value
distrubtionToJson Stats
l

-- | Convert a scalar metric (i.e. counter, gauge, or label) to a JSON
-- value.
scalarToJson :: A.ToJSON a => a -> MetricType -> A.Value
scalarToJson :: forall a. ToJSON a => a -> MetricType -> Value
scalarToJson a
val MetricType
ty = [Pair] -> Value
A.object
    [Key
"val" Key -> a -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= a
val, Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= MetricType -> Text
metricType MetricType
ty]
{-# SPECIALIZE scalarToJson :: Int64 -> MetricType -> A.Value #-}
{-# SPECIALIZE scalarToJson :: T.Text -> MetricType -> A.Value #-}

data MetricType =
      CounterType
    | GaugeType
    | LabelType
    | DistributionType

metricType :: MetricType -> T.Text
metricType :: MetricType -> Text
metricType MetricType
CounterType      = Text
"c"
metricType MetricType
GaugeType        = Text
"g"
metricType MetricType
LabelType        = Text
"l"
metricType MetricType
DistributionType = Text
"d"

-- | Convert a distribution to a JSON value.
distrubtionToJson :: Distribution.Stats -> A.Value
distrubtionToJson :: Stats -> Value
distrubtionToJson Stats
stats = [Pair] -> Value
A.object
    [ Key
"mean" Key -> Double -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Stats -> Double
Distribution.mean Stats
stats
    , Key
"variance" Key -> Double -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Stats -> Double
Distribution.variance Stats
stats
    , Key
"count" Key -> Int64 -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Stats -> Int64
Distribution.count Stats
stats
    , Key
"sum" Key -> Double -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Stats -> Double
Distribution.sum Stats
stats
    , Key
"min" Key -> Double -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Stats -> Double
Distribution.min Stats
stats
    , Key
"max" Key -> Double -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Stats -> Double
Distribution.max Stats
stats
    , Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= MetricType -> Text
metricType MetricType
DistributionType
    ]

------------------------------------------------------------------------
-- ** Newtype wrappers with instances

-- | Newtype wrapper that provides a 'A.ToJSON' instances for the
-- underlying 'Metrics.Sample' without creating an orphan instance.
newtype Sample = Sample Metrics.Sample
    deriving Int -> Sample -> String -> String
[Sample] -> String -> String
Sample -> String
(Int -> Sample -> String -> String)
-> (Sample -> String)
-> ([Sample] -> String -> String)
-> Show Sample
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Sample -> String -> String
showsPrec :: Int -> Sample -> String -> String
$cshow :: Sample -> String
show :: Sample -> String
$cshowList :: [Sample] -> String -> String
showList :: [Sample] -> String -> String
Show

-- | Uses 'sampleToJson'.
instance A.ToJSON Sample where
    toJSON :: Sample -> Value
toJSON (Sample Sample
s) = Sample -> Value
sampleToJson Sample
s

-- | Newtype wrapper that provides a 'A.ToJSON' instances for the
-- underlying 'Metrics.Value' without creating an orphan instance.
newtype Value = Value Metrics.Value
    deriving Int -> Value -> String -> String
[Value] -> String -> String
Value -> String
(Int -> Value -> String -> String)
-> (Value -> String) -> ([Value] -> String -> String) -> Show Value
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Value -> String -> String
showsPrec :: Int -> Value -> String -> String
$cshow :: Value -> String
show :: Value -> String
$cshowList :: [Value] -> String -> String
showList :: [Value] -> String -> String
Show

-- | Uses 'valueToJson'.
instance A.ToJSON Value where
    toJSON :: Value -> Value
toJSON (Value Value
v) = Value -> Value
valueToJson Value
v