{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Monad.Metrics
(
MonadMetrics(..)
, initialize
, initializeWith
, run
, run'
, increment
, counter
, counter'
, gauge
, gauge'
, gaugeIncrement
, gaugeDecrement
, distribution
, timed
, timed'
, timedList
, label
, label'
, Resolution(..)
, Metrics
, metricsCounters
, metricsGauges
, metricsLabels
, metricsStore
) where
import Control.Monad (liftM, forM_)
import Control.Monad.Catch (MonadMask, bracket)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Reader (MonadReader (..), ReaderT (..))
import Control.Monad.Trans (MonadTrans (..))
import Data.Hashable (Hashable)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.IORef (IORef, atomicModifyIORef',
newIORef)
import Data.Monoid (mempty)
import Data.Text (Text)
import qualified Data.Text as Text
import System.Clock (Clock (..), getTime)
import System.IO.Unsafe (unsafeInterleaveIO)
import qualified System.Metrics as EKG
import System.Metrics.Counter as Counter
import System.Metrics.Distribution as Distribution
import System.Metrics.Gauge as Gauge
import System.Metrics.Label as Label
import Prelude
import Control.Monad.Metrics.Internal
class Monad m => MonadMetrics m where
getMetrics :: m Metrics
instance {-# OVERLAPPABLE #-} (MonadMetrics m, MonadTrans t, Monad (t m)) => MonadMetrics (t m) where
getMetrics :: t m Metrics
getMetrics = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). MonadMetrics m => m Metrics
getMetrics
instance Monad m => MonadMetrics (ReaderT Metrics m) where
getMetrics :: ReaderT Metrics m Metrics
getMetrics = forall r (m :: * -> *). MonadReader r m => m r
ask
run :: MonadIO m => ReaderT Metrics m a -> m a
run :: forall (m :: * -> *) a. MonadIO m => ReaderT Metrics m a -> m a
run = forall (m :: * -> *) r a.
MonadIO m =>
(Metrics -> r) -> ReaderT r m a -> m a
run' forall a. a -> a
id
run' :: MonadIO m => (Metrics -> r) -> ReaderT r m a -> m a
run' :: forall (m :: * -> *) r a.
MonadIO m =>
(Metrics -> r) -> ReaderT r m a -> m a
run' Metrics -> r
k ReaderT r m a
action = do
Metrics
m <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Metrics
initialize
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT r m a
action (Metrics -> r
k Metrics
m)
initializeWith :: EKG.Store -> IO Metrics
initializeWith :: Store -> IO Metrics
initializeWith Store
_metricsStore = do
IORef (HashMap Text Counter)
_metricsCounters <- forall a. a -> IO (IORef a)
newIORef forall a. Monoid a => a
mempty
IORef (HashMap Text Distribution)
_metricsDistributions <- forall a. a -> IO (IORef a)
newIORef forall a. Monoid a => a
mempty
IORef (HashMap Text Gauge)
_metricsGauges <- forall a. a -> IO (IORef a)
newIORef forall a. Monoid a => a
mempty
IORef (HashMap Text Label)
_metricsLabels <- forall a. a -> IO (IORef a)
newIORef forall a. Monoid a => a
mempty
forall (m :: * -> *) a. Monad m => a -> m a
return Metrics{IORef (HashMap Text Distribution)
IORef (HashMap Text Label)
IORef (HashMap Text Gauge)
IORef (HashMap Text Counter)
Store
_metricsStore :: Store
_metricsLabels :: IORef (HashMap Text Label)
_metricsDistributions :: IORef (HashMap Text Distribution)
_metricsGauges :: IORef (HashMap Text Gauge)
_metricsCounters :: IORef (HashMap Text Counter)
_metricsLabels :: IORef (HashMap Text Label)
_metricsGauges :: IORef (HashMap Text Gauge)
_metricsDistributions :: IORef (HashMap Text Distribution)
_metricsCounters :: IORef (HashMap Text Counter)
_metricsStore :: Store
..}
initialize :: IO Metrics
initialize :: IO Metrics
initialize = IO Store
EKG.newStore forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Store -> IO Metrics
initializeWith
increment :: (MonadIO m, MonadMetrics m) => Text -> m ()
increment :: forall (m :: * -> *). (MonadIO m, MonadMetrics m) => Text -> m ()
increment Text
name = forall (m :: * -> *).
(MonadIO m, MonadMetrics m) =>
Text -> Int -> m ()
counter Text
name Int
1
counter' :: (MonadIO m, MonadMetrics m, Integral int) => Text -> int -> m ()
counter' :: forall (m :: * -> *) int.
(MonadIO m, MonadMetrics m, Integral int) =>
Text -> int -> m ()
counter' =
forall (m :: * -> *) t t1 b t2.
(MonadMetrics m, MonadIO m) =>
(t -> t1 -> IO b)
-> (t2 -> t1)
-> (Text -> Store -> IO t)
-> (Metrics -> IORef (HashMap Text t))
-> Text
-> t2
-> m b
modifyMetric Counter -> Int64 -> IO ()
Counter.add forall a b. (Integral a, Num b) => a -> b
fromIntegral Text -> Store -> IO Counter
EKG.createCounter Metrics -> IORef (HashMap Text Counter)
_metricsCounters
counter :: (MonadIO m, MonadMetrics m) => Text -> Int -> m ()
counter :: forall (m :: * -> *).
(MonadIO m, MonadMetrics m) =>
Text -> Int -> m ()
counter = forall (m :: * -> *) int.
(MonadIO m, MonadMetrics m, Integral int) =>
Text -> int -> m ()
counter'
distribution :: (MonadIO m, MonadMetrics m) => Text -> Double -> m ()
distribution :: forall (m :: * -> *).
(MonadIO m, MonadMetrics m) =>
Text -> Double -> m ()
distribution =
forall (m :: * -> *) t t1 b t2.
(MonadMetrics m, MonadIO m) =>
(t -> t1 -> IO b)
-> (t2 -> t1)
-> (Text -> Store -> IO t)
-> (Metrics -> IORef (HashMap Text t))
-> Text
-> t2
-> m b
modifyMetric Distribution -> Double -> IO ()
Distribution.add forall a. a -> a
id Text -> Store -> IO Distribution
EKG.createDistribution Metrics -> IORef (HashMap Text Distribution)
_metricsDistributions
gauge' :: (MonadIO m, MonadMetrics m, Integral int) => Text -> int -> m ()
gauge' :: forall (m :: * -> *) int.
(MonadIO m, MonadMetrics m, Integral int) =>
Text -> int -> m ()
gauge' =
forall (m :: * -> *) t t1 b t2.
(MonadMetrics m, MonadIO m) =>
(t -> t1 -> IO b)
-> (t2 -> t1)
-> (Text -> Store -> IO t)
-> (Metrics -> IORef (HashMap Text t))
-> Text
-> t2
-> m b
modifyMetric Gauge -> Int64 -> IO ()
Gauge.set forall a b. (Integral a, Num b) => a -> b
fromIntegral Text -> Store -> IO Gauge
EKG.createGauge Metrics -> IORef (HashMap Text Gauge)
_metricsGauges
gauge :: (MonadIO m, MonadMetrics m) => Text -> Int -> m ()
gauge :: forall (m :: * -> *).
(MonadIO m, MonadMetrics m) =>
Text -> Int -> m ()
gauge = forall (m :: * -> *) int.
(MonadIO m, MonadMetrics m, Integral int) =>
Text -> int -> m ()
gauge'
gaugeDecrement :: (MonadIO m, MonadMetrics m) => Text -> m ()
gaugeDecrement :: forall (m :: * -> *). (MonadIO m, MonadMetrics m) => Text -> m ()
gaugeDecrement Text
name =
forall (m :: * -> *) t t1 b t2.
(MonadMetrics m, MonadIO m) =>
(t -> t1 -> IO b)
-> (t2 -> t1)
-> (Text -> Store -> IO t)
-> (Metrics -> IORef (HashMap Text t))
-> Text
-> t2
-> m b
modifyMetric (\Gauge
g -> forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Gauge -> IO ()
Gauge.dec Gauge
g) forall a. a -> a
id Text -> Store -> IO Gauge
EKG.createGauge Metrics -> IORef (HashMap Text Gauge)
_metricsGauges Text
name ()
gaugeIncrement :: (MonadIO m, MonadMetrics m) => Text -> m ()
gaugeIncrement :: forall (m :: * -> *). (MonadIO m, MonadMetrics m) => Text -> m ()
gaugeIncrement Text
name =
forall (m :: * -> *) t t1 b t2.
(MonadMetrics m, MonadIO m) =>
(t -> t1 -> IO b)
-> (t2 -> t1)
-> (Text -> Store -> IO t)
-> (Metrics -> IORef (HashMap Text t))
-> Text
-> t2
-> m b
modifyMetric (\Gauge
g -> forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Gauge -> IO ()
Gauge.inc Gauge
g) forall a. a -> a
id Text -> Store -> IO Gauge
EKG.createGauge Metrics -> IORef (HashMap Text Gauge)
_metricsGauges Text
name ()
timed' :: (MonadIO m, MonadMetrics m, MonadMask m) => Resolution -> Text -> m a -> m a
timed' :: forall (m :: * -> *) a.
(MonadIO m, MonadMetrics m, MonadMask m) =>
Resolution -> Text -> m a -> m a
timed' Resolution
resolution Text
name m a
action = forall (m :: * -> *) a.
(MonadIO m, MonadMetrics m, MonadMask m) =>
Resolution -> [Text] -> m a -> m a
timedList Resolution
resolution [Text
name] m a
action
timedList :: (MonadIO m, MonadMetrics m, MonadMask m) => Resolution -> [Text] -> m a -> m a
timedList :: forall (m :: * -> *) a.
(MonadIO m, MonadMetrics m, MonadMask m) =>
Resolution -> [Text] -> m a -> m a
timedList Resolution
resolution [Text]
names m a
action =
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Clock -> IO TimeSpec
getTime Clock
Monotonic)) forall {m :: * -> *}.
(MonadIO m, MonadMetrics m) =>
TimeSpec -> m ()
finish (forall a b. a -> b -> a
const m a
action)
where
finish :: TimeSpec -> m ()
finish TimeSpec
start = do
TimeSpec
end <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Clock -> IO TimeSpec
getTime Clock
Monotonic)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
names forall a b. (a -> b) -> a -> b
$ \Text
name ->
forall (m :: * -> *).
(MonadIO m, MonadMetrics m) =>
Text -> Double -> m ()
distribution Text
name (Resolution -> TimeSpec -> TimeSpec -> Double
diffTime Resolution
resolution TimeSpec
end TimeSpec
start)
timed :: (MonadIO m, MonadMetrics m, MonadMask m) => Text -> m a -> m a
timed :: forall (m :: * -> *) a.
(MonadIO m, MonadMetrics m, MonadMask m) =>
Text -> m a -> m a
timed = forall (m :: * -> *) a.
(MonadIO m, MonadMetrics m, MonadMask m) =>
Resolution -> Text -> m a -> m a
timed' Resolution
Seconds
label :: (MonadIO m, MonadMetrics m) => Text -> Text -> m ()
label :: forall (m :: * -> *).
(MonadIO m, MonadMetrics m) =>
Text -> Text -> m ()
label = forall (m :: * -> *) t t1 b t2.
(MonadMetrics m, MonadIO m) =>
(t -> t1 -> IO b)
-> (t2 -> t1)
-> (Text -> Store -> IO t)
-> (Metrics -> IORef (HashMap Text t))
-> Text
-> t2
-> m b
modifyMetric Label -> Text -> IO ()
Label.set forall a. a -> a
id Text -> Store -> IO Label
EKG.createLabel Metrics -> IORef (HashMap Text Label)
_metricsLabels
label' :: (MonadIO m, MonadMetrics m, Show a) => Text -> a -> m ()
label' :: forall (m :: * -> *) a.
(MonadIO m, MonadMetrics m, Show a) =>
Text -> a -> m ()
label' Text
l = forall (m :: * -> *).
(MonadIO m, MonadMetrics m) =>
Text -> Text -> m ()
label Text
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
modifyMetric
:: (MonadMetrics m, MonadIO m)
=> (t -> t1 -> IO b)
-> (t2 -> t1)
-> (Text -> EKG.Store -> IO t)
-> (Metrics -> IORef (HashMap Text t))
-> Text
-> t2
-> m b
modifyMetric :: forall (m :: * -> *) t t1 b t2.
(MonadMetrics m, MonadIO m) =>
(t -> t1 -> IO b)
-> (t2 -> t1)
-> (Text -> Store -> IO t)
-> (Metrics -> IORef (HashMap Text t))
-> Text
-> t2
-> m b
modifyMetric t -> t1 -> IO b
adder t2 -> t1
converter Text -> Store -> IO t
creator Metrics -> IORef (HashMap Text t)
getter Text
name t2
value = do
t
bar <- forall (m :: * -> *) k a.
(MonadMetrics m, MonadIO m, Eq k, Hashable k) =>
(Metrics -> IORef (HashMap k a))
-> (k -> Store -> IO a) -> k -> m a
lookupOrCreate Metrics -> IORef (HashMap Text t)
getter Text -> Store -> IO t
creator Text
name
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ t -> t1 -> IO b
adder t
bar (t2 -> t1
converter t2
value)
lookupOrCreate
:: (MonadMetrics m, MonadIO m, Eq k, Hashable k)
=> (Metrics -> IORef (HashMap k a)) -> (k -> EKG.Store -> IO a) -> k -> m a
lookupOrCreate :: forall (m :: * -> *) k a.
(MonadMetrics m, MonadIO m, Eq k, Hashable k) =>
(Metrics -> IORef (HashMap k a))
-> (k -> Store -> IO a) -> k -> m a
lookupOrCreate Metrics -> IORef (HashMap k a)
getter k -> Store -> IO a
creator k
name = do
IORef (HashMap k a)
ref <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Metrics -> IORef (HashMap k a)
getter forall (m :: * -> *). MonadMetrics m => m Metrics
getMetrics
a
newMetric <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IO a -> IO a
unsafeInterleaveIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> Store -> IO a
creator k
name forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Metrics -> Store
_metricsStore forall (m :: * -> *). MonadMetrics m => m Metrics
getMetrics
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (HashMap k a)
ref (\HashMap k a
container ->
case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup k
name HashMap k a
container of
Maybe a
Nothing ->
(forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert k
name a
newMetric HashMap k a
container, a
newMetric)
Just a
metric ->
(HashMap k a
container, a
metric))