diff --git a/monad-metrics.cabal b/monad-metrics.cabal --- a/monad-metrics.cabal +++ b/monad-metrics.cabal @@ -1,5 +1,5 @@ name: monad-metrics -version: 0.1.0.2 +version: 0.2.0.0 synopsis: A convenient wrapper around EKG metrics description: A convenient wrapper for collecting application metrics. Please see the README.md for more information. homepage: https://github.com/sellerlabs/monad-metrics#readme @@ -17,14 +17,15 @@ hs-source-dirs: src exposed-modules: Control.Monad.Metrics , Control.Monad.Metrics.Internal - build-depends: base >= 4.7 && < 5 - , clock >= 0.3 && < 0.8 - , containers >= 0.2 && < 0.6 - , ekg-core >= 0.1.0.1 && < 0.2 - , text < 1.3 - , mtl >= 2 && < 2.3 - , transformers >= 0.3 && < 0.6 - , microlens >= 0.2 && < 0.5 + build-depends: base >= 4.7 && < 5 + , clock >= 0.3 && < 0.8 + , ekg-core >= 0.1.0.1 && < 0.2 + , hashable >= 1.2 && < 1.3 + , text < 1.3 + , mtl >= 2 && < 2.3 + , transformers >= 0.3 && < 0.6 + , unordered-containers >= 0.2 && < 0.3 + , microlens >= 0.2 && < 0.5 default-language: Haskell2010 test-suite monad-metrics-test diff --git a/src/Control/Monad/Metrics.hs b/src/Control/Monad/Metrics.hs --- a/src/Control/Monad/Metrics.hs +++ b/src/Control/Monad/Metrics.hs @@ -1,12 +1,7 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} {-| Module : Control.Monad.Metrics @@ -60,15 +55,17 @@ import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Reader (MonadReader (..), ReaderT (..)) import Control.Monad.Trans (MonadTrans (..)) -import Data.IORef -import Data.Map (Map) -import qualified Data.Map as Map +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 Lens.Micro import System.Clock (Clock (..), TimeSpec (..), getTime) +import System.IO.Unsafe (unsafeInterleaveIO) import qualified System.Metrics as EKG import System.Metrics.Counter as Counter import System.Metrics.Distribution as Distribution @@ -238,50 +235,19 @@ label' l = label l . Text.pack . show -- $metrictype --- The 'Metric' type contains an 'IORef' to a 'Map' from 'Text' labels to +-- The 'Metric' type contains an 'IORef' to a 'HashMap' from 'Text' labels to -- the various counters, and a 'EKG.Store' to register them with. If you -- must use the 'Metric' value directly, then you are recommended to use -- the lenses provided for compatibility. ------------------------------------------------------------------------------- -diffTime :: Resolution -> TimeSpec -> TimeSpec -> Double -diffTime res (TimeSpec seca nseca) (TimeSpec secb nsecb) = - let sec = seca - secb - nsec = nseca - nsecb - in convertTimeSpecTo res (TimeSpec sec nsec) - -convertTimeSpecTo :: Resolution -> TimeSpec -> Double -convertTimeSpecTo res (TimeSpec secs' nsecs') = - case res of - Nanoseconds -> nsecs + sToNs secs - Microseconds -> nsToUs nsecs + sToUs secs - Milliseconds -> nsToMs nsecs + sToMs secs - Seconds -> nsToS nsecs + secs - Minutes -> sToMin (nsToS nsecs + secs) - Hours -> sToHour (nsToS nsecs + secs) - Days -> sToDay (nsToS nsecs + secs) - where - nsecs = fromIntegral nsecs' - secs = fromIntegral secs' - -nsToUs, nsToMs, nsToS, sToMin, sToHour, sToDay, sToNs, sToUs, sToMs :: Double -> Double -nsToUs = (/ 10^3) -nsToMs = (/ 10^6) -nsToS = (/ 10^9) -sToMin = (/ 60) -sToHour = sToMin . sToMin -sToDay = (/ 24) . sToHour -sToNs = (* 10^9) -sToUs = (* 10^6) -sToMs = (* 10^3) - modifyMetric :: (MonadMetrics m, MonadIO m) => (t -> t1 -> IO b) -- ^ The action to add a value to a metric. -> (t2 -> t1) -- ^ A conversion function from input to metric value. -> (Text -> EKG.Store -> IO t) -- ^ The function for creating a new metric. - -> (Metrics -> IORef (Map Text t)) -- ^ A way of getting the current metrics. + -> (Metrics -> IORef (HashMap Text t)) -- ^ A way of getting the current metrics. -> Text -- ^ The name of the metric to use. -> t2 -- ^ The value the end user can provide. -> m b @@ -290,14 +256,18 @@ liftIO $ adder bar (converter value) lookupOrCreate - :: (MonadMetrics m, MonadIO m, Ord k) - => (Metrics -> IORef (Map k a)) -> (k -> EKG.Store -> IO a) -> k -> m a + :: (MonadMetrics m, MonadIO m, Eq k, Hashable k) + => (Metrics -> IORef (HashMap k a)) -> (k -> EKG.Store -> IO a) -> k -> m a lookupOrCreate getter creator name = do ref <- liftM getter getMetrics - container <- liftIO $ readIORef ref - case Map.lookup name container of - Nothing -> do - c <- liftIO . creator name =<< liftM _metricsStore getMetrics - liftIO $ modifyIORef ref (Map.insert name c) - return c - Just c -> return c + -- unsafeInterleaveIO is used here to defer creating the metric into + -- the 'atomicModifyIORef'' function. We lazily create the value here, + -- and the resulting IO action only gets run to create the metric when + -- the named metric is not present in the map. + newMetric <- liftIO . unsafeInterleaveIO . creator name =<< liftM _metricsStore getMetrics + liftIO $ atomicModifyIORef' ref (\container -> + case HashMap.lookup name container of + Nothing -> + (HashMap.insert name newMetric container, newMetric) + Just metric -> + (container, metric)) diff --git a/src/Control/Monad/Metrics/Internal.hs b/src/Control/Monad/Metrics/Internal.hs --- a/src/Control/Monad/Metrics/Internal.hs +++ b/src/Control/Monad/Metrics/Internal.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE RankNTypes #-} - {-| Module : Control.Monad.Metrics.Internal Description : An easy interface to recording metrics. @@ -16,11 +14,11 @@ -} module Control.Monad.Metrics.Internal where -import Control.Monad.Reader (asks) import Data.IORef -import Data.Map (Map) +import Data.HashMap.Strict (HashMap) import Data.Text (Text) import Lens.Micro +import System.Clock (TimeSpec (..)) import System.Metrics (Store) import System.Metrics.Counter (Counter) import System.Metrics.Distribution (Distribution) @@ -31,35 +29,35 @@ -- -- * /Since v0.1.0.0/ data Metrics = Metrics - { _metricsCounters :: IORef (Map Text Counter) - , _metricsGauges :: IORef (Map Text Gauge) - , _metricsDistributions :: IORef (Map Text Distribution) - , _metricsLabels :: IORef (Map Text Label) + { _metricsCounters :: IORef (HashMap Text Counter) + , _metricsGauges :: IORef (HashMap Text Gauge) + , _metricsDistributions :: IORef (HashMap Text Distribution) + , _metricsLabels :: IORef (HashMap Text Label) , _metricsStore :: Store } -- | A lens into the 'Counter's provided by the 'Metrics'. -- -- * /Since v0.1.0.0/ -metricsCounters :: Lens' Metrics (IORef (Map Text Counter)) +metricsCounters :: Lens' Metrics (IORef (HashMap Text Counter)) metricsCounters f (Metrics c g d l s) = fmap (\c' -> Metrics c' g d l s) (f c) -- | A lens into the 'Gauge's provided by the 'Metrics'. -- -- * /Since v0.1.0.0/ -metricsGauges :: Lens' Metrics (IORef (Map Text Gauge)) +metricsGauges :: Lens' Metrics (IORef (HashMap Text Gauge)) metricsGauges f (Metrics c g d l s) = fmap (\g' -> Metrics c g' d l s) (f g) -- | A lens into the 'Distribution's provided by the 'Metrics'. -- -- * /Since v0.1.0.0/ -metricsDistributions :: Lens' Metrics (IORef (Map Text Distribution)) +metricsDistributions :: Lens' Metrics (IORef (HashMap Text Distribution)) metricsDistributions f (Metrics c g d l s) = fmap (\d' -> Metrics c g d' l s) (f d) -- | A lens into the 'Label's provided by the 'Metrics'. -- -- * /Since v0.1.0.0/ -metricsLabels :: Lens' Metrics (IORef (Map Text Label)) +metricsLabels :: Lens' Metrics (IORef (HashMap Text Label)) metricsLabels f (Metrics c g d l s) = fmap (\l' -> Metrics c g d l' s) (f l) -- | A lens into the 'Store' provided by the 'Metrics'. @@ -81,3 +79,34 @@ | Hours | Days deriving (Eq, Show, Ord, Enum) + +diffTime :: Resolution -> TimeSpec -> TimeSpec -> Double +diffTime res (TimeSpec seca nseca) (TimeSpec secb nsecb) = + let secs = seca - secb + nsecs = nseca - nsecb + in convertTimeSpecTo res (TimeSpec secs nsecs) + +convertTimeSpecTo :: Resolution -> TimeSpec -> Double +convertTimeSpecTo res (TimeSpec secs' nsecs') = + case res of + Nanoseconds -> nsecs + sToNs secs + Microseconds -> nsToUs nsecs + sToUs secs + Milliseconds -> nsToMs nsecs + sToMs secs + Seconds -> nsToS nsecs + secs + Minutes -> sToMin (nsToS nsecs + secs) + Hours -> sToHour (nsToS nsecs + secs) + Days -> sToDay (nsToS nsecs + secs) + where + nsecs = fromIntegral nsecs' + secs = fromIntegral secs' + +nsToUs, nsToMs, nsToS, sToMin, sToHour, sToDay, sToNs, sToUs, sToMs :: Double -> Double +nsToUs = (/ 10^(3 :: Int)) +nsToMs = (/ 10^(6 :: Int)) +nsToS = (/ 10^(9 :: Int)) +sToMin = (/ 60) +sToHour = sToMin . sToMin +sToDay = (/ 24) . sToHour +sToNs = (* 10^(9 :: Int)) +sToUs = (* 10^(6 :: Int)) +sToMs = (* 10^(3 :: Int))