From 1a16acd71ae9759cf169c5703258a1097d2dc803 Mon Sep 17 00:00:00 2001 From: Matthieu Morel Date: Sun, 18 Nov 2018 16:37:11 +0100 Subject: [PATCH] add documentation and cosmetic changes --- System/Metrics.hs | 4 +- System/Metrics/Dimensional.hs | 79 +++++++++++++++++++++-------------- examples/Dimensional.hs | 15 +++++++ 3 files changed, 64 insertions(+), 34 deletions(-) create mode 100644 examples/Dimensional.hs diff --git a/System/Metrics.hs b/System/Metrics.hs index 8a1ad2d..d745645 100644 --- a/System/Metrics.hs +++ b/System/Metrics.hs @@ -209,8 +209,8 @@ registerDimensional -> Store -- ^ Metric store -> IO () registerDimensional d f store = - let x = readIORef (Dimensional._points d) >>= traverse f in - register (Dimensional._name d) (DimensionalS (Dimensional._dimensions d) x) store + let x = readIORef (Dimensional.dimensionalPoints d) >>= traverse f in + register (Dimensional.dimensionalName d) (DimensionalS (Dimensional.dimensionalDimensions d) x) store register :: T.Text -> MetricSampler diff --git a/System/Metrics/Dimensional.hs b/System/Metrics/Dimensional.hs index 78fb80d..aeef6e4 100644 --- a/System/Metrics/Dimensional.hs +++ b/System/Metrics/Dimensional.hs @@ -1,5 +1,10 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} + +-- | 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 @@ -7,34 +12,43 @@ import qualified System.Metrics.Distribution as Distribution import qualified System.Metrics.Gauge as Gauge import qualified System.Metrics.Label as Label -import Prelude hiding (lookup) -import GHC.Exception (Exception) import Control.Exception (throwIO) -import Data.Text (Text) -import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) 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 GHC.Exception (Exception) +import Prelude hiding (lookup) type Name = Text + type Explanation = Text + type Dimensions = [Text] + type Point = [Text] -data Dimensional a = Dimensional { - _create :: !(IO a) - , _name :: !Name - , _explanation :: !Explanation - , _dimensions :: !Dimensions - , _points :: !(IORef (HashMap Point a)) +-- | Dimensional metrics storage +data Dimensional a = Dimensional + { dimensionalCreate :: !(IO a) + , dimensionalName :: !Name + , dimensionalExplanation :: !Explanation + , dimensionalDimensions :: !Dimensions + , dimensionalPoints :: !(IORef (HashMap Point a)) } -newDimensional :: IO a -> Name -> Explanation -> Dimensions -> IO (Dimensional 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 + Dimensional new name explanation dimensions <$> newIORef empty -data DimensionError - = DimensionError !Name !Dimensions !Point +data DimensionError = + DimensionError !Name + !Dimensions + !Point deriving (Show, Ord, Eq) + instance Exception DimensionError data LookupFailure @@ -42,47 +56,48 @@ data LookupFailure | NotFound deriving (Show, Ord, Eq) +-- | Returns dimensional metric with specified labels lookup :: Dimensional a -> Point -> IO (Either LookupFailure a) lookup d pt - | not $ matchDimensions (_dimensions d) pt = pure $ Left (UnmatchedDimensions err) + | not $ matchDimensions (dimensionalDimensions d) pt = + pure $ Left (UnmatchedDimensions err) | otherwise = do - toLookupResult . HashMap.lookup pt <$> readIORef (_points d) + toLookupResult . HashMap.lookup pt <$> readIORef (dimensionalPoints d) where err :: DimensionError - err = DimensionError (_name d) (_dimensions d) pt - + 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 (_dimensions d) pt = throwIO err + | not $ matchDimensions (dimensionalDimensions d) pt = throwIO err | otherwise = do - v <- _create d - atomicModifyIORef' (_points d) (\store -> (HashMap.insert pt v store, ())) - return v + v <- dimensionalCreate d + atomicModifyIORef' + (dimensionalPoints d) + (\store -> (HashMap.insert pt v store, ())) + return v where err :: DimensionError - err = DimensionError (_name d) (_dimensions d) pt + 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 +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 -example :: IO () -example = do - c <- newDimensional Counter.new "foo" "a foo" ["url", "status"] - let url = "/hello" - let status = "200" - x <- lookupOrCreate c [url, status] - Counter.inc x +type Distribution = Dimensional Distribution.Distribution 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