Dimensional counters

System/Compat.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE CPP #-}
+
+module System.Compat
+#if !MIN_VERSION_base(4,8,0)
+    ((<$!>))
+#else
+#endif
+  where
+
+-- | Import <$!> from base-4.8 for ghc 7 compat
+#if !MIN_VERSION_base(4,8,0)
+infixl 4 <$!>
+
+-- | Strict version of 'Data.Functor.<$>'.
+--
+-- @since 4.8.0.0
+(<$!>) :: Monad m => (a -> b) -> m a -> m b
+{-# INLINE (<$!>) #-}
+f <$!> m = do
+  x <- m
+  let z = f x
+  z `seq` return z
+#endif

System/Metrics.hs

@@ -49,13 +49,18 @@ module System.Metrics
     , registerLabel
     , registerDistribution
     , registerGroup
+    , registerDimensional
 
       -- ** Convenience functions
       -- $convenience
     , createCounter
     , createGauge
     , createLabel
     , createDistribution
+    , createDimensionalCounter
+    , createDimensionalGauge
+    , createDimensionalLabel
+    , createDimensionalDistribution
 
       -- ** Predefined metrics
       -- $predefined
@@ -69,8 +74,16 @@ module System.Metrics
     ) where
 
 import Control.Applicative ((<$>))
+#if MIN_VERSION_base(4,8,0)
+import Control.Monad (forM, (<$!>))
+#else
 import Control.Monad (forM)
+import System.Compat ((<$!>))
+#endif
+import Data.Either (partitionEithers)
 import Data.Int (Int64)
+import Data.Traversable (traverse)
+import Data.Monoid ((<>))
 import qualified Data.IntMap.Strict as IM
 import Data.IORef (IORef, atomicModifyIORef, newIORef, readIORef)
 import qualified Data.HashMap.Strict as M
@@ -86,6 +99,8 @@ import System.Metrics.Gauge (Gauge)
 import qualified System.Metrics.Gauge as Gauge
 import System.Metrics.Label (Label)
 import qualified System.Metrics.Label as Label
+import System.Metrics.Dimensional (Dimensional)
+import qualified System.Metrics.Dimensional as Dimensional
 
 -- $naming
 -- Compound metric names should be separated using underscores.
@@ -137,6 +152,7 @@ data MetricSampler = CounterS !(IO Int64)
                    | GaugeS !(IO Int64)
                    | LabelS !(IO T.Text)
                    | DistributionS !(IO Distribution.Stats)
+                   | DimensionalS !Dimensional.Dimensions !(IO (M.HashMap Dimensional.Point Value))
 
 -- | Create a new, empty metric store.
 newStore :: IO Store
@@ -192,6 +208,16 @@ registerDistribution
 registerDistribution name sample store =
     register name (DistributionS sample) store
 
+-- | Registers a dimensional metric.
+registerDimensional
+    :: Dimensional a
+    -> (a -> IO Value)        -- ^ Function to sample the dimensional metric to a Value.
+    -> Store                  -- ^ Metric store
+    -> IO ()
+registerDimensional d f store =
+    let x = readIORef (Dimensional.dimensionalPoints d) >>= traverse f in
+    register (Dimensional.dimensionalName d) (DimensionalS (Dimensional.dimensionalDimensions d) x) store
+
 register :: T.Text
          -> MetricSampler
          -> Store
@@ -323,6 +349,48 @@ createDistribution name store = do
     registerDistribution name (Distribution.read event) store
     return event
 
+-- | Create and register a zero-initialized dimensional counter.
+createDimensionalCounter :: T.Text                 -- ^ Counter name
+                         -> Store                  -- ^ Metric store
+                         -> Dimensional.Dimensions -- ^ Dimension names.
+                         -> IO (Dimensional Counter)
+createDimensionalCounter name store dims = do
+    counter <- Dimensional.newDimensional Counter.new name "" dims
+    registerDimensional counter (fmap Counter . Counter.read) store
+    return counter
+
+-- | Create and register a zero-initialized dimensional gauge.
+createDimensionalGauge :: T.Text                 -- ^ Gauge name
+                         -> Store                  -- ^ Metric store
+                         -> Dimensional.Dimensions -- ^ Dimension names.
+                         -> IO (Dimensional Gauge)
+createDimensionalGauge name store dims = do
+    gauge <- Dimensional.newDimensional Gauge.new name "" dims
+    registerDimensional gauge (fmap Gauge . Gauge.read) store
+    return gauge
+
+-- | Create and register a zero-initialized dimensional label.
+createDimensionalLabel :: T.Text                 -- ^ Label name
+                         -> Store                  -- ^ Metric store
+                         -> Dimensional.Dimensions -- ^ Dimension names.
+                         -> IO (Dimensional Label)
+createDimensionalLabel name store dims = do
+    label <- Dimensional.newDimensional Label.new name "" dims
+    registerDimensional label (fmap Label . Label.read) store
+    return label
+
+-- | Create and register a zero-initialized dimensional distribution.
+createDimensionalDistribution :: T.Text                 -- ^ Distribution name
+                         -> Store                  -- ^ Metric store
+                         -> Dimensional.Dimensions -- ^ Dimension names.
+                         -> IO (Dimensional Distribution)
+createDimensionalDistribution name store dims = do
+    distribution <- Dimensional.newDimensional Distribution.new name "" dims
+    registerDimensional distribution (fmap Distribution . Distribution.read) store
+    return distribution
+
+
+
 ------------------------------------------------------------------------
 -- * Predefined metrics
 
@@ -590,7 +658,8 @@ gcParTotBytesCopied = Stats.parAvgBytesCopied
 -- metrics atomically.
 
 -- | A sample of some metrics.
-type Sample = M.HashMap T.Text Value
+type Sample = M.HashMap (T.Text, [(T.Text, T.Text)]) Value
+
 
 -- | Sample all metrics. Sampling is /not/ atomic in the sense that
 -- some metrics might have been mutated before they're sampled but
@@ -601,9 +670,10 @@ sampleAll store = do
     let metrics = stateMetrics state
         groups = stateGroups state
     cbSample <- sampleGroups $ IM.elems groups
-    sample <- readAllRefs metrics
-    let allSamples = sample ++ cbSample
-    return $! M.fromList allSamples
+    (dimSamples, sample) <- partitionEithers <$> readAllRefs metrics
+    let noDimSamples = [((k,[]),v) | (k,v) <- sample ++ cbSample]
+    let flatDimSamples = [ ((k,zip ds dvs),v) | (k, ds, pointVals) <- dimSamples, (dvs,v) <- pointVals]
+    return $! M.fromList (noDimSamples ++ flatDimSamples)
 
 -- | Sample all metric groups.
 sampleGroups :: [GroupSampler] -> IO [(T.Text, Value)]
@@ -621,17 +691,22 @@ data Value = Counter {-# UNPACK #-} !Int64
            | Distribution !Distribution.Stats
            deriving (Eq, Show)
 
-sampleOne :: MetricSampler -> IO Value
-sampleOne (CounterS m)      = Counter <$> m
-sampleOne (GaugeS m)        = Gauge <$> m
-sampleOne (LabelS m)        = Label <$> m
-sampleOne (DistributionS m) = Distribution <$> m
+type Value2 = Either (Dimensional.Dimensions, [(Dimensional.Point, Value)]) Value
+
+sampleOne :: MetricSampler -> IO Value2
+sampleOne (CounterS m)      = Right . Counter <$> m
+sampleOne (GaugeS m)        = Right . Gauge <$> m
+sampleOne (LabelS m)        = Right . Label <$> m
+sampleOne (DistributionS m) = Right . Distribution <$> m
+sampleOne (DimensionalS dims m)  = Left . (\pairs -> (dims, pairs)) . M.toList <$!> m
 
 -- | Get a snapshot of all values.  Note that we're not guaranteed to
 -- see a consistent snapshot of the whole map.
 readAllRefs :: M.HashMap T.Text (Either MetricSampler GroupId)
-            -> IO [(T.Text, Value)]
+            -> IO [Either (T.Text, Dimensional.Dimensions, [(Dimensional.Point, Value)]) (T.Text, Value)] 
 readAllRefs m = do
     forM ([(name, ref) | (name, Left ref) <- M.toList m]) $ \ (name, ref) -> do
         val <- sampleOne ref
-        return (name, val)
+        return $! case val of
+            Left (dims, pairs) -> Left (name, dims, pairs)
+            Right v -> Right (name, v)

System/Metrics/Dimensional.hs

@@ -0,0 +1,112 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE CPP #-}
+
+-- | This module defines a type for mutable dimensional string-valued label.
+-- Dimensional label are variable values and can be used to track e.g. the
+-- current number of call to an api endpoint by its http return code.
+-- All operations on Dimensional label are thread-safe.
+module System.Metrics.Dimensional where
+
+import qualified System.Metrics.Counter as Counter
+import qualified System.Metrics.Distribution as Distribution
+import qualified System.Metrics.Gauge as Gauge
+import qualified System.Metrics.Label as Label
+
+import Control.Applicative ((<$>), pure)
+import Control.Exception (throwIO)
+#if MIN_VERSION_base(4,8,0)
+import Control.Monad ((<$!>))
+#else
+import System.Compat ((<$!>))
+#endif
+import Data.HashMap.Strict (HashMap, empty)
+import qualified Data.HashMap.Strict as HashMap
+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)
+import Data.Text (Text)
+import Data.Typeable
+import GHC.Exception (Exception)
+import Prelude hiding (lookup)
+
+type Name = Text
+
+type Explanation = Text
+
+type Dimensions = [Text]
+
+type Point = [Text]
+
+-- | Dimensional metrics storage
+data Dimensional a = Dimensional
+  { dimensionalCreate :: !(IO a)
+  , dimensionalName :: !Name
+  , dimensionalExplanation :: !Explanation
+  , dimensionalDimensions :: !Dimensions
+  , dimensionalPoints :: !(IORef (HashMap Point a))
+  }
+
+-- | Create a new empty dimensional metrics
+newDimensional ::
+     IO a -> Name -> Explanation -> Dimensions -> IO (Dimensional a)
+newDimensional new name explanation dimensions =
+  Dimensional new name explanation dimensions <$> newIORef empty
+
+data DimensionError =
+  DimensionError !Name
+                 !Dimensions
+                 !Point
+  deriving (Show, Ord, Eq, Typeable)
+
+instance Exception DimensionError
+
+data LookupFailure
+  = UnmatchedDimensions DimensionError
+  | NotFound
+  deriving (Show, Ord, Eq)
+
+-- | Returns dimensional metric with specified labels
+lookup :: Dimensional a -> Point -> IO (Either LookupFailure a)
+lookup d pt
+  | not $ matchDimensions (dimensionalDimensions d) pt =
+    pure $ Left (UnmatchedDimensions err)
+  | otherwise = do
+    toLookupResult . HashMap.lookup pt <$!> readIORef (dimensionalPoints d)
+  where
+    err :: DimensionError
+    err = DimensionError (dimensionalName d) (dimensionalDimensions d) pt
+    toLookupResult Nothing = Left NotFound
+    toLookupResult (Just x) = Right x
+
+matchDimensions :: Dimensions -> Point -> Bool
+matchDimensions ds ps = length ds == length ps
+
+-- | Initialize a new empty dimensional metric with specified labels
+create :: Dimensional a -> Point -> IO a
+create d pt
+  | not $ matchDimensions (dimensionalDimensions d) pt = throwIO err
+  | otherwise = do
+    v <- dimensionalCreate d
+    atomicModifyIORef'
+      (dimensionalPoints d)
+      (\store -> (HashMap.insert pt v store, ()))
+    return v
+  where
+    err :: DimensionError
+    err = DimensionError (dimensionalName d) (dimensionalDimensions d) pt
+
+-- | Returns dimensional metric with specified labels, creating it if not exists
+lookupOrCreate :: Dimensional a -> Point -> IO a
+lookupOrCreate d pt =
+  lookup d pt >>= \case
+    Left NotFound -> create d pt
+    Left (UnmatchedDimensions err) -> throwIO err
+    Right x -> return x
+
+type Counter = Dimensional Counter.Counter
+
+type Gauge = Dimensional Gauge.Gauge
+
+type Label = Dimensional Label.Label
+
+type Distribution = Dimensional Distribution.Distribution

ekg-core.cabal

@@ -1,6 +1,6 @@
 cabal-version:       1.18
 name:                ekg-core
-version:             0.1.1.6
+version:             0.2.0.0
 synopsis:            Tracking of system metrics
 description:
   This library lets you defined and track system metrics.
@@ -21,7 +21,9 @@ tested-with:         GHC == 8.6.2, GHC == 8.4.4,  GHC == 8.2.2,
 library
   exposed-modules:
     System.Metrics
+    System.Compat
     System.Metrics.Counter
+    System.Metrics.Dimensional
     System.Metrics.Distribution
     System.Metrics.Distribution.Internal
     System.Metrics.Gauge

examples/Dimensional.hs

@@ -0,0 +1,15 @@
+import qualified System.Metrics.Counter as Counter
+import System.Metrics.Dimensional
+
+main :: IO ()
+main = do
+  c <-
+    newDimensional
+      Counter.new
+      "wai.response"
+      "endpoints status response"
+      ["url", "status"]
+  let url = "/hello"
+  let status = "200"
+  x <- lookupOrCreate c [url, status]
+  Counter.inc x