diff --git a/System/Compat.hs b/System/Compat.hs new file mode 100644 index 0000000..71c36f2 --- /dev/null +++ b/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 diff --git a/System/Metrics.hs b/System/Metrics.hs index bca8339..34e4e05 100644 --- a/System/Metrics.hs +++ b/System/Metrics.hs @@ -49,6 +49,7 @@ module System.Metrics , registerLabel , registerDistribution , registerGroup + , registerDimensional -- ** Convenience functions -- $convenience @@ -56,6 +57,10 @@ module System.Metrics , 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) diff --git a/System/Metrics/Dimensional.hs b/System/Metrics/Dimensional.hs new file mode 100644 index 0000000..9ff2f72 --- /dev/null +++ b/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 diff --git a/ekg-core.cabal b/ekg-core.cabal index b5257a6..aade445 100644 --- a/ekg-core.cabal +++ b/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 diff --git a/examples/Dimensional.hs b/examples/Dimensional.hs new file mode 100644 index 0000000..f6bf133 --- /dev/null +++ b/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