{-# LANGUAGE ExistentialQuantification #-}
module Prometheus.Registry (
    register
,   registerIO
,   unsafeRegister
,   unsafeRegisterIO
,   collectMetrics
,   unregisterAll
) where

import Prometheus.Metric

import Control.Applicative ((<$>))
import Control.Monad.IO.Class
import System.IO.Unsafe (unsafePerformIO)
import qualified Control.Concurrent.STM as STM


-- $setup
-- >>> :module +Prometheus
-- >>> unregisterAll

-- | A 'Registry' is a list of all registered metrics, currently represented by
-- their sampling functions.
type Registry = [IO [SampleGroup]]

{-# NOINLINE globalRegistry #-}
globalRegistry :: STM.TVar Registry
globalRegistry :: TVar Registry
globalRegistry = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (TVar a)
STM.newTVarIO []

-- | Registers a metric with the global metric registry.
register :: MonadIO m => Metric s -> m s
register :: forall (m :: * -> *) s. MonadIO m => Metric s -> m s
register (Metric IO (s, IO [SampleGroup])
mk) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    (s
metric, IO [SampleGroup]
sampleGroups) <- IO (s, IO [SampleGroup])
mk
    let addToRegistry :: Registry -> Registry
addToRegistry = (IO [SampleGroup]
sampleGroups forall a. a -> [a] -> [a]
:)
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
STM.modifyTVar' TVar Registry
globalRegistry Registry -> Registry
addToRegistry
    forall (m :: * -> *) a. Monad m => a -> m a
return s
metric

-- | Registers a metric with the global metric registry.
registerIO :: MonadIO m => m (Metric s) -> m s
registerIO :: forall (m :: * -> *) s. MonadIO m => m (Metric s) -> m s
registerIO m (Metric s)
metricGen = m (Metric s)
metricGen forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) s. MonadIO m => Metric s -> m s
register

-- | Registers a metric with the global metric registry.
--
-- __IMPORTANT__: This method should only be used to register metrics as top
-- level symbols, it should not be run from other pure code.
unsafeRegister :: Metric s -> s
unsafeRegister :: forall s. Metric s -> s
unsafeRegister = forall a. IO a -> a
unsafePerformIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) s. MonadIO m => Metric s -> m s
register

-- | Registers a metric with the global metric registry.
--
-- __IMPORTANT__: This method should only be used to register metrics as top
-- level symbols, it should not be run from other pure code.
--
-- For example,
--
-- >>> :{
--  {-# NOINLINE c #-}
--  let c = unsafeRegisterIO $ counter (Info "my_counter" "An example metric")
-- :}
-- ...
unsafeRegisterIO :: IO (Metric s) -> s
unsafeRegisterIO :: forall s. IO (Metric s) -> s
unsafeRegisterIO = forall a. IO a -> a
unsafePerformIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) s. MonadIO m => m (Metric s) -> m s
registerIO

-- | Removes all currently registered metrics from the registry.
unregisterAll :: MonadIO m => m ()
unregisterAll :: forall (m :: * -> *). MonadIO m => m ()
unregisterAll = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
STM.writeTVar TVar Registry
globalRegistry []

-- | Collect samples from all currently registered metrics. In typical use cases
-- there is no reason to use this function, instead you should use
-- `exportMetricsAsText` or a convenience library.
--
-- This function is likely only of interest if you wish to export metrics in
-- a non-supported format for use with another monitoring service.
collectMetrics :: MonadIO m => m [SampleGroup]
collectMetrics :: forall (m :: * -> *). MonadIO m => m [SampleGroup]
collectMetrics = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    Registry
registry <- forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> STM a
STM.readTVar TVar Registry
globalRegistry
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence Registry
registry