{-# LANGUAGE FlexibleInstances #-}
-- | An interface for bundling metrics in a way that they cna be iterated over for reporting or looked up for use by code that shares the registry.
module Data.Metrics.Registry (
  MetricRegistry,
  Metric(..),
  Register(..),
  metrics,
  newMetricRegistry,
  module Data.Metrics.Types
) where
import Control.Concurrent.MVar
import qualified Data.HashMap.Strict as H
import Data.Metrics.Counter
import Data.Metrics.Gauge
import Data.Metrics.Histogram
import Data.Metrics.Meter
import Data.Metrics.Timer
import Data.Metrics.Types
import Data.Text (Text)

-- | Initializes a new metric registry.
newMetricRegistry :: IO (MetricRegistry IO)
newMetricRegistry :: IO (MetricRegistry IO)
newMetricRegistry = (MVar (HashMap Text (Metric IO)) -> MetricRegistry IO)
-> IO (MVar (HashMap Text (Metric IO))) -> IO (MetricRegistry IO)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MVar (HashMap Text (Metric IO)) -> MetricRegistry IO
forall (m :: * -> *).
MVar (HashMap Text (Metric m)) -> MetricRegistry m
MetricRegistry (IO (MVar (HashMap Text (Metric IO))) -> IO (MetricRegistry IO))
-> IO (MVar (HashMap Text (Metric IO))) -> IO (MetricRegistry IO)
forall a b. (a -> b) -> a -> b
$ HashMap Text (Metric IO) -> IO (MVar (HashMap Text (Metric IO)))
forall a. a -> IO (MVar a)
newMVar HashMap Text (Metric IO)
forall k v. HashMap k v
H.empty

-- | A container that tracks all metrics registered with it.
-- All forms of metrics share the same namespace in the registry.
-- Consequently, attempting to replace a metric with one of a different type will fail (return Nothing from a call to `register`).
data MetricRegistry m = MetricRegistry
  { forall (m :: * -> *).
MetricRegistry m -> MVar (HashMap Text (Metric m))
metrics :: !(MVar (H.HashMap Text (Metric m)))
  }

-- | A sum type of all supported metric types that reporters should be able to output.
data Metric m
  = MetricGauge !(Gauge m)
  | MetricCounter !(Counter m)
  | MetricHistogram !(Histogram m)
  | MetricMeter !(Meter m)
  | MetricTimer !(Timer m)

-- | Add a new metric to a registry or retrieve the existing metric of the same name if one exists.
class Register a where
  -- | If possible, avoid using 'register' to frequently retrieve metrics from a global registry. The metric registry is locked any time a lookup is performed, which may cause contention.
  register :: MetricRegistry IO -> Text -> IO a -> IO (Maybe a)

instance Register (Counter IO) where
  register :: MetricRegistry IO
-> Text -> IO (Counter IO) -> IO (Maybe (Counter IO))
register MetricRegistry IO
r Text
t IO (Counter IO)
m = do
    hm <- MVar (HashMap Text (Metric IO)) -> IO (HashMap Text (Metric IO))
forall a. MVar a -> IO a
takeMVar (MVar (HashMap Text (Metric IO)) -> IO (HashMap Text (Metric IO)))
-> MVar (HashMap Text (Metric IO)) -> IO (HashMap Text (Metric IO))
forall a b. (a -> b) -> a -> b
$ MetricRegistry IO -> MVar (HashMap Text (Metric IO))
forall (m :: * -> *).
MetricRegistry m -> MVar (HashMap Text (Metric m))
metrics MetricRegistry IO
r
    case H.lookup t hm of
      Maybe (Metric IO)
Nothing -> do
        c <- IO (Counter IO)
m
        putMVar (metrics r) $! H.insert t (MetricCounter c) hm
        return $ Just c
      Just Metric IO
im -> do
        MVar (HashMap Text (Metric IO))
-> HashMap Text (Metric IO) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (MetricRegistry IO -> MVar (HashMap Text (Metric IO))
forall (m :: * -> *).
MetricRegistry m -> MVar (HashMap Text (Metric m))
metrics MetricRegistry IO
r) HashMap Text (Metric IO)
hm
        Maybe (Counter IO) -> IO (Maybe (Counter IO))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Counter IO) -> IO (Maybe (Counter IO)))
-> Maybe (Counter IO) -> IO (Maybe (Counter IO))
forall a b. (a -> b) -> a -> b
$! case Metric IO
im of
          MetricCounter Counter IO
c -> Counter IO -> Maybe (Counter IO)
forall a. a -> Maybe a
Just Counter IO
c
          Metric IO
_ -> Maybe (Counter IO)
forall a. Maybe a
Nothing

instance Register (Gauge IO) where
  register :: MetricRegistry IO -> Text -> IO (Gauge IO) -> IO (Maybe (Gauge IO))
register MetricRegistry IO
r Text
t IO (Gauge IO)
m = do
    hm <- MVar (HashMap Text (Metric IO)) -> IO (HashMap Text (Metric IO))
forall a. MVar a -> IO a
takeMVar (MVar (HashMap Text (Metric IO)) -> IO (HashMap Text (Metric IO)))
-> MVar (HashMap Text (Metric IO)) -> IO (HashMap Text (Metric IO))
forall a b. (a -> b) -> a -> b
$ MetricRegistry IO -> MVar (HashMap Text (Metric IO))
forall (m :: * -> *).
MetricRegistry m -> MVar (HashMap Text (Metric m))
metrics MetricRegistry IO
r
    case H.lookup t hm of
      Maybe (Metric IO)
Nothing -> do
        g <- IO (Gauge IO)
m
        putMVar (metrics r) $! H.insert t (MetricGauge g) hm
        return $ Just g
      Just Metric IO
im -> do
        MVar (HashMap Text (Metric IO))
-> HashMap Text (Metric IO) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (MetricRegistry IO -> MVar (HashMap Text (Metric IO))
forall (m :: * -> *).
MetricRegistry m -> MVar (HashMap Text (Metric m))
metrics MetricRegistry IO
r) HashMap Text (Metric IO)
hm
        Maybe (Gauge IO) -> IO (Maybe (Gauge IO))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Gauge IO) -> IO (Maybe (Gauge IO)))
-> Maybe (Gauge IO) -> IO (Maybe (Gauge IO))
forall a b. (a -> b) -> a -> b
$! case Metric IO
im of
          MetricGauge Gauge IO
r -> Gauge IO -> Maybe (Gauge IO)
forall a. a -> Maybe a
Just Gauge IO
r
          Metric IO
_ -> Maybe (Gauge IO)
forall a. Maybe a
Nothing

instance Register (Histogram IO) where
  register :: MetricRegistry IO
-> Text -> IO (Histogram IO) -> IO (Maybe (Histogram IO))
register MetricRegistry IO
r Text
t IO (Histogram IO)
m = do
    hm <- MVar (HashMap Text (Metric IO)) -> IO (HashMap Text (Metric IO))
forall a. MVar a -> IO a
takeMVar (MVar (HashMap Text (Metric IO)) -> IO (HashMap Text (Metric IO)))
-> MVar (HashMap Text (Metric IO)) -> IO (HashMap Text (Metric IO))
forall a b. (a -> b) -> a -> b
$ MetricRegistry IO -> MVar (HashMap Text (Metric IO))
forall (m :: * -> *).
MetricRegistry m -> MVar (HashMap Text (Metric m))
metrics MetricRegistry IO
r
    case H.lookup t hm of
      Maybe (Metric IO)
Nothing -> do
        h <- IO (Histogram IO)
m
        putMVar (metrics r) $! H.insert t (MetricHistogram h) hm
        return $ Just h
      Just Metric IO
im -> do
        MVar (HashMap Text (Metric IO))
-> HashMap Text (Metric IO) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (MetricRegistry IO -> MVar (HashMap Text (Metric IO))
forall (m :: * -> *).
MetricRegistry m -> MVar (HashMap Text (Metric m))
metrics MetricRegistry IO
r) HashMap Text (Metric IO)
hm
        Maybe (Histogram IO) -> IO (Maybe (Histogram IO))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Histogram IO) -> IO (Maybe (Histogram IO)))
-> Maybe (Histogram IO) -> IO (Maybe (Histogram IO))
forall a b. (a -> b) -> a -> b
$! case Metric IO
im of
          MetricHistogram Histogram IO
h -> Histogram IO -> Maybe (Histogram IO)
forall a. a -> Maybe a
Just Histogram IO
h
          Metric IO
_ -> Maybe (Histogram IO)
forall a. Maybe a
Nothing

instance Register (Meter IO) where
  register :: MetricRegistry IO -> Text -> IO (Meter IO) -> IO (Maybe (Meter IO))
register MetricRegistry IO
r Text
t IO (Meter IO)
m = do
    hm <- MVar (HashMap Text (Metric IO)) -> IO (HashMap Text (Metric IO))
forall a. MVar a -> IO a
takeMVar (MVar (HashMap Text (Metric IO)) -> IO (HashMap Text (Metric IO)))
-> MVar (HashMap Text (Metric IO)) -> IO (HashMap Text (Metric IO))
forall a b. (a -> b) -> a -> b
$ MetricRegistry IO -> MVar (HashMap Text (Metric IO))
forall (m :: * -> *).
MetricRegistry m -> MVar (HashMap Text (Metric m))
metrics MetricRegistry IO
r
    case H.lookup t hm of
      Maybe (Metric IO)
Nothing -> do
        mv <- IO (Meter IO)
m
        putMVar (metrics r) $! H.insert t (MetricMeter mv) hm
        return $ Just mv
      Just Metric IO
im -> do
        MVar (HashMap Text (Metric IO))
-> HashMap Text (Metric IO) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (MetricRegistry IO -> MVar (HashMap Text (Metric IO))
forall (m :: * -> *).
MetricRegistry m -> MVar (HashMap Text (Metric m))
metrics MetricRegistry IO
r) HashMap Text (Metric IO)
hm
        Maybe (Meter IO) -> IO (Maybe (Meter IO))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Meter IO) -> IO (Maybe (Meter IO)))
-> Maybe (Meter IO) -> IO (Maybe (Meter IO))
forall a b. (a -> b) -> a -> b
$! case Metric IO
im of
          MetricMeter Meter IO
md -> Meter IO -> Maybe (Meter IO)
forall a. a -> Maybe a
Just Meter IO
md
          Metric IO
_ -> Maybe (Meter IO)
forall a. Maybe a
Nothing

instance Register (Timer IO) where
  register :: MetricRegistry IO -> Text -> IO (Timer IO) -> IO (Maybe (Timer IO))
register MetricRegistry IO
r Text
t IO (Timer IO)
m = do
    hm <- MVar (HashMap Text (Metric IO)) -> IO (HashMap Text (Metric IO))
forall a. MVar a -> IO a
takeMVar (MVar (HashMap Text (Metric IO)) -> IO (HashMap Text (Metric IO)))
-> MVar (HashMap Text (Metric IO)) -> IO (HashMap Text (Metric IO))
forall a b. (a -> b) -> a -> b
$ MetricRegistry IO -> MVar (HashMap Text (Metric IO))
forall (m :: * -> *).
MetricRegistry m -> MVar (HashMap Text (Metric m))
metrics MetricRegistry IO
r
    case H.lookup t hm of
      Maybe (Metric IO)
Nothing -> do
        mv <- IO (Timer IO)
m
        putMVar (metrics r) $! H.insert t (MetricTimer mv) hm
        return $ Just mv
      Just Metric IO
im -> do
        MVar (HashMap Text (Metric IO))
-> HashMap Text (Metric IO) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (MetricRegistry IO -> MVar (HashMap Text (Metric IO))
forall (m :: * -> *).
MetricRegistry m -> MVar (HashMap Text (Metric m))
metrics MetricRegistry IO
r) HashMap Text (Metric IO)
hm
        Maybe (Timer IO) -> IO (Maybe (Timer IO))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Timer IO) -> IO (Maybe (Timer IO)))
-> Maybe (Timer IO) -> IO (Maybe (Timer IO))
forall a b. (a -> b) -> a -> b
$! case Metric IO
im of
          MetricTimer Timer IO
md -> Timer IO -> Maybe (Timer IO)
forall a. a -> Maybe a
Just Timer IO
md
          Metric IO
_ -> Maybe (Timer IO)
forall a. Maybe a
Nothing