{-# 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 = m Metrics -> t m Metrics
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Metrics
forall (m :: * -> *). MonadMetrics m => m Metrics
getMetrics
instance Monad m => MonadMetrics (ReaderT Metrics m) where
getMetrics :: ReaderT Metrics m Metrics
getMetrics = ReaderT Metrics m Metrics
forall r (m :: * -> *). MonadReader r m => m r
ask
run :: MonadIO m => ReaderT Metrics m a -> m a
run :: ReaderT Metrics m a -> m a
run = (Metrics -> Metrics) -> ReaderT Metrics m a -> m a
forall (m :: * -> *) r a.
MonadIO m =>
(Metrics -> r) -> ReaderT r m a -> m a
run' Metrics -> Metrics
forall a. a -> a
id
run' :: MonadIO m => (Metrics -> r) -> ReaderT r m a -> m a
run' :: (Metrics -> r) -> ReaderT r m a -> m a
run' Metrics -> r
k ReaderT r m a
action = do
Metrics
m <- IO Metrics -> m Metrics
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Metrics
initialize
ReaderT r m a -> r -> m a
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 <- HashMap Text Counter -> IO (IORef (HashMap Text Counter))
forall a. a -> IO (IORef a)
newIORef HashMap Text Counter
forall a. Monoid a => a
mempty
IORef (HashMap Text Distribution)
_metricsDistributions <- HashMap Text Distribution -> IO (IORef (HashMap Text Distribution))
forall a. a -> IO (IORef a)
newIORef HashMap Text Distribution
forall a. Monoid a => a
mempty
IORef (HashMap Text Gauge)
_metricsGauges <- HashMap Text Gauge -> IO (IORef (HashMap Text Gauge))
forall a. a -> IO (IORef a)
newIORef HashMap Text Gauge
forall a. Monoid a => a
mempty
IORef (HashMap Text Label)
_metricsLabels <- HashMap Text Label -> IO (IORef (HashMap Text Label))
forall a. a -> IO (IORef a)
newIORef HashMap Text Label
forall a. Monoid a => a
mempty
Metrics -> IO Metrics
forall (m :: * -> *) a. Monad m => a -> m a
return Metrics :: IORef (HashMap Text Counter)
-> IORef (HashMap Text Gauge)
-> IORef (HashMap Text Distribution)
-> IORef (HashMap Text Label)
-> Store
-> Metrics
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 IO Store -> (Store -> IO Metrics) -> IO Metrics
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 :: Text -> m ()
increment Text
name = Text -> Int -> m ()
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' :: Text -> int -> m ()
counter' =
(Counter -> Int64 -> IO ())
-> (int -> Int64)
-> (Text -> Store -> IO Counter)
-> (Metrics -> IORef (HashMap Text Counter))
-> Text
-> int
-> m ()
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 int -> Int64
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 :: Text -> Int -> m ()
counter = Text -> Int -> m ()
forall (m :: * -> *) int.
(MonadIO m, MonadMetrics m, Integral int) =>
Text -> int -> m ()
counter'
distribution :: (MonadIO m, MonadMetrics m) => Text -> Double -> m ()
distribution :: Text -> Double -> m ()
distribution =
(Distribution -> Double -> IO ())
-> (Double -> Double)
-> (Text -> Store -> IO Distribution)
-> (Metrics -> IORef (HashMap Text Distribution))
-> Text
-> Double
-> m ()
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 Double -> Double
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' :: Text -> int -> m ()
gauge' =
(Gauge -> Int64 -> IO ())
-> (int -> Int64)
-> (Text -> Store -> IO Gauge)
-> (Metrics -> IORef (HashMap Text Gauge))
-> Text
-> int
-> m ()
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 int -> Int64
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 :: Text -> Int -> m ()
gauge = Text -> Int -> m ()
forall (m :: * -> *) int.
(MonadIO m, MonadMetrics m, Integral int) =>
Text -> int -> m ()
gauge'
gaugeDecrement :: (MonadIO m, MonadMetrics m) => Text -> m ()
gaugeDecrement :: Text -> m ()
gaugeDecrement Text
name =
(Gauge -> () -> IO ())
-> (() -> ())
-> (Text -> Store -> IO Gauge)
-> (Metrics -> IORef (HashMap Text Gauge))
-> Text
-> ()
-> m ()
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 -> IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> () -> IO ()) -> IO () -> () -> IO ()
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 :: Text -> m ()
gaugeIncrement Text
name =
(Gauge -> () -> IO ())
-> (() -> ())
-> (Text -> Store -> IO Gauge)
-> (Metrics -> IORef (HashMap Text Gauge))
-> Text
-> ()
-> m ()
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 -> IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> () -> IO ()) -> IO () -> () -> IO ()
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' :: Resolution -> Text -> m a -> m a
timed' Resolution
resolution Text
name m a
action = Resolution -> [Text] -> m a -> m a
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 :: Resolution -> [Text] -> m a -> m a
timedList Resolution
resolution [Text]
names m a
action =
m TimeSpec -> (TimeSpec -> m ()) -> (TimeSpec -> m a) -> m a
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (IO TimeSpec -> m TimeSpec
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Clock -> IO TimeSpec
getTime Clock
Monotonic)) TimeSpec -> m ()
forall (m :: * -> *).
(MonadIO m, MonadMetrics m) =>
TimeSpec -> m ()
finish (m a -> TimeSpec -> m a
forall a b. a -> b -> a
const m a
action)
where
finish :: TimeSpec -> m ()
finish TimeSpec
start = do
TimeSpec
end <- IO TimeSpec -> m TimeSpec
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Clock -> IO TimeSpec
getTime Clock
Monotonic)
[Text] -> (Text -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
names ((Text -> m ()) -> m ()) -> (Text -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Text
name ->
Text -> Double -> m ()
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 :: Text -> m a -> m a
timed = Resolution -> Text -> m a -> m a
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 :: Text -> Text -> m ()
label = (Label -> Text -> IO ())
-> (Text -> Text)
-> (Text -> Store -> IO Label)
-> (Metrics -> IORef (HashMap Text Label))
-> Text
-> Text
-> m ()
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 Text -> Text
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' :: Text -> a -> m ()
label' Text
l = Text -> Text -> m ()
forall (m :: * -> *).
(MonadIO m, MonadMetrics m) =>
Text -> Text -> m ()
label Text
l (Text -> m ()) -> (a -> Text) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
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 :: (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 <- (Metrics -> IORef (HashMap Text t))
-> (Text -> Store -> IO t) -> Text -> m t
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
IO b -> m b
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> m b) -> IO b -> m b
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 :: (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 <- (Metrics -> IORef (HashMap k a))
-> m Metrics -> m (IORef (HashMap k a))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Metrics -> IORef (HashMap k a)
getter m Metrics
forall (m :: * -> *). MonadMetrics m => m Metrics
getMetrics
a
newMetric <- IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (Store -> IO a) -> Store -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO a
forall a. IO a -> IO a
unsafeInterleaveIO (IO a -> IO a) -> (Store -> IO a) -> Store -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> Store -> IO a
creator k
name (Store -> m a) -> m Store -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Metrics -> Store) -> m Metrics -> m Store
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Metrics -> Store
_metricsStore m Metrics
forall (m :: * -> *). MonadMetrics m => m Metrics
getMetrics
IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ IORef (HashMap k a) -> (HashMap k a -> (HashMap k a, a)) -> IO a
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (HashMap k a)
ref (\HashMap k a
container ->
case k -> HashMap k a -> Maybe a
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 ->
(k -> a -> HashMap k a -> HashMap k a
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))