packages feed

prometheus-client 0.3.0 → 1.0.0

raw patch · 15 files changed

+474/−254 lines, 15 filesdep +deepseqdep +exceptionsdep +textdep ~criterionnew-uploader

Dependencies added: deepseq, exceptions, text, transformers-compat

Dependency ranges changed: criterion

Files

benchmarks/Main.hs view
@@ -1,44 +1,149 @@+{-# language FlexibleContexts #-}+{-# language OverloadedStrings #-}++module Main (main) where+ import Prometheus  import Control.Monad+import Criterion import Criterion.Main+import Data.Foldable (for_)+import qualified Data.Text as T import System.Random +withMetric m =+  envWithCleanup+    (register m)+    (const unregisterAll) +withCounter =+  withMetric (counter (Info "a" "b"))++withGauge =+  withMetric (gauge (Info "a" "b"))++withSummary quantiles =+  withMetric (summary (Info "a" "b") quantiles)++withHistogram buckets =+  withMetric (histogram (Info "a" "b") buckets)+ main :: IO ()-main = defaultMain [-        bgroup "incCounter" $ expandBenches incCounterThenCollect-    ,   bgroup "withLabelIncCounter" $ expandBenches withLabelIncCounter-    ,   bgroup "addGauge" $ expandBenches $ withGaugeThenCollect (addGauge 47.0)-    ,   bgroup "subGauge" $ expandBenches $ withGaugeThenCollect (subGauge 47.0)-    ,   bgroup "setGauge" $ expandBenches $ withGaugeThenCollect (setGauge 47.0)-    ,   bgroup "observe" $ expandBenches observeThenCollect+main =+  defaultMain+    [ benchCounter+    , benchGauge+    , benchSummary+    , benchHistogram+    , benchExport     ] -expandBenches :: (Int -> IO a) -> [Benchmark]-expandBenches = flip expand [1, 10, 100, 1000, 10000]-    where expand b = map (\i -> bench (show i) (whnfIO (b i))) -incCounterThenCollect :: Int -> IO [SampleGroup]-incCounterThenCollect i = do-    c <- counter (Info "name" "help")-    replicateM_ i (incCounter c)-    collect c+-- Counter benchmarks -withLabelIncCounter :: Int -> IO [SampleGroup]-withLabelIncCounter i = do-    v <- vector ("a", "b")  $ counter (Info "name" "help")-    replicateM_ i (withLabel ("c", "d") incCounter v)-    collect v -withGaugeThenCollect :: (Metric Gauge -> IO ()) -> Int -> IO [SampleGroup]-withGaugeThenCollect a i = do-    g <- gauge (Info "name" "help")-    replicateM_ i (a g)-    collect g+benchCounter =+  withCounter $ \counter ->+    bgroup "Counter"+      [ benchIncCounter counter+      , benchAddCounter counter+      , benchAddDurationToCounter counter+      ] -observeThenCollect :: Int -> IO [SampleGroup]-observeThenCollect i = do-    s <- summary (Info "name" "help") defaultQuantiles-    replicateM_ i (randomIO >>= flip observe s)-    collect s+benchIncCounter testCounter =+  bench "incCounter" $ whnfIO (incCounter testCounter)++benchAddCounter testCounter =+  bench "addCounter" $ whnfIO (addCounter testCounter 50)++benchAddDurationToCounter testCounter =+  bench "addDurationToCounter" $ whnfIO (addDurationToCounter testCounter $ return ())++++-- Gauge benchmarks+++benchGauge =+  withGauge $ \gauge ->+    bgroup "Gauge"+      [ benchIncGauge gauge+      , benchAddGauge gauge+      , benchSubGauge gauge+      , benchSetGaugeToDuration gauge+      ]++benchIncGauge testGauge =+  bench "incGauge" $ whnfIO (incGauge testGauge)++benchAddGauge testGauge =+  bench "addGauge" $ whnfIO (addGauge testGauge 50)++benchSubGauge testGauge =+  bench "subGauge" $ whnfIO (subGauge testGauge 50)++benchSetGaugeToDuration testGauge =+  bench "setGaugeToDuration" $ whnfIO (setGaugeToDuration testGauge $ return ())++++-- Summary benchmarks+++benchSummary =+  bgroup "Summary"+    (map benchSummaryWithQuantiles [defaultQuantiles])++benchSummaryWithQuantiles q =+  withSummary q $ \summary ->+    bgroup ("Quantiles = " ++ show q)+      [ benchSummaryObserve summary+      ]++benchSummaryObserve s =+  bench "observe" $ whnfIO (observe s 42)++++-- Histogram benchmarks+++benchHistogram =+  bgroup "Histogram"+    (map benchHistogramWithQuantiles [defaultBuckets])++benchHistogramWithQuantiles q =+  withHistogram q $ \histogram ->+    bgroup ("Buckets = " ++ show q)+      [ benchHistogramObserve histogram+      ]++benchHistogramObserve s =+  bench "observe" $ whnfIO (observe s 42)++++-- Exporter benchmarks++benchExport =+  bgroup "exportMetricsAsText"+    [ bgroup "Export counters" (map benchExportCounters [100, 1000, 10000])+    , bgroup "Export histograms" (map benchExportHistograms [100, 1000, 10000])+    ]++benchExportCounters nCounters =+  envWithCleanup setup teardown ( const benchmark )+  where+    benchmark = bench (show nCounters ++ " counters") (nfIO exportMetricsAsText)+    setup = replicateM_ nCounters $ do+      register $ counter (Info (T.pack $ show nCounters) "")+    teardown _ = unregisterAll++benchExportHistograms nHistograms =+  envWithCleanup setup teardown ( const benchmark )+  where+    benchmark = bench (show nHistograms ++ " histograms") (nfIO exportMetricsAsText)+    setup = replicateM_ nHistograms $ do+      register $ histogram (Info (T.pack $ show nHistograms) "") defaultBuckets+    teardown _ = unregisterAll
prometheus-client.cabal view
@@ -1,5 +1,5 @@ name:                prometheus-client-version:             0.3.0+version:             1.0.0 synopsis:            Haskell client library for http://prometheus.io. description:         Haskell client library for http://prometheus.io. homepage:            https://github.com/fimad/prometheus-haskell@@ -40,10 +40,14 @@     , bytestring         >=0.9     , clock     , containers+    , deepseq     , mtl                >=2     , stm                >=2.3     , transformers+    , transformers-compat     , utf8-string+    , exceptions+    , text   ghc-options: -Wall  test-suite doctest@@ -74,7 +78,11 @@     , random-shuffle     , stm     , transformers+    , transformers-compat     , utf8-string+    , deepseq+    , exceptions+    , text   ghc-options: -Wall  benchmark bench@@ -85,8 +93,9 @@   build-depends:       base               >=4.7 && <5     , bytestring-    , criterion          >=1.1+    , criterion          >=1.2     , prometheus-client     , random     , utf8-string+    , text   ghc-options: -Wall
src/Prometheus.hs view
@@ -34,11 +34,11 @@ -- A Counter is typically used to count requests served, tasks completed, -- errors occurred, etc. ----- >>> myCounter <- counter (Info "my_counter" "An example counter")+-- >>> myCounter <- register $ counter (Info "my_counter" "An example counter") -- >>> replicateM_ 47 (incCounter myCounter) -- >>> getCounter myCounter -- 47.0--- >>> void $ addCounter 10 myCounter+-- >>> void $ addCounter myCounter 10 -- >>> getCounter myCounter -- 57.0 @@ -48,6 +48,7 @@ ,   addCounter ,   unsafeAddCounter ,   addDurationToCounter+,   countExceptions ,   getCounter  -- ** Gauge@@ -55,10 +56,10 @@ -- | A gauge models an arbitrary floating point value. There are operations to -- set the value of a gauge as well as add and subtract arbitrary values. ----- >>> myGauge <- gauge (Info "my_gauge" "An example gauge")--- >>> setGauge 100 myGauge--- >>> addGauge 50 myGauge--- >>> subGauge 25 myGauge+-- >>> myGauge <- register $ gauge (Info "my_gauge" "An example gauge")+-- >>> setGauge myGauge 100 +-- >>> addGauge myGauge 50+-- >>> subGauge myGauge 25 -- >>> getGauge myGauge -- 125.0 @@ -93,8 +94,8 @@ -- sum, and rank estimations. A typical use case for summaries is measuring -- HTTP request latency. ----- >>> mySummary <- summary (Info "my_summary" "") defaultQuantiles--- >>> observe 0 mySummary+-- >>> mySummary <- register $ summary (Info "my_summary" "") defaultQuantiles+-- >>> observe mySummary 0 -- >>> getSummary mySummary -- [(1 % 2,0.0),(9 % 10,0.0),(99 % 100,0.0)] @@ -111,8 +112,8 @@ -- for histograms is measuring HTTP request latency. Histograms are unlike -- summaries in that they can be meaningfully aggregated across processes. ----- >>> myHistogram <- histogram (Info "my_histogram" "") defaultBuckets--- >>> observe 0 myHistogram+-- >>> myHistogram <- register $ histogram (Info "my_histogram" "") defaultBuckets+-- >>> observe myHistogram 0  -- >>> getHistogram myHistogram -- fromList [(5.0e-3,1),(1.0e-2,0),(2.5e-2,0),(5.0e-2,0),(0.1,0),(0.25,0),(0.5,0),(1.0,0),(2.5,0),(5.0,0),(10.0,0)] ,   Histogram@@ -127,15 +128,14 @@ -- | A vector models a collection of metrics that share the same name but are -- partitioned across a set of dimensions. ----- >>> myVector <- vector ("method", "code") $ counter (Info "http_requests" "")--- >>> register myVector--- >>> withLabel ("GET", "200") incCounter myVector--- >>> withLabel ("GET", "200") incCounter myVector--- >>> withLabel ("GET", "404") incCounter myVector--- >>> withLabel ("POST", "200") incCounter myVector--- >>> getVectorWith getCounter myVector+-- >>> myVector <- register $ vector ("method", "code") $ counter (Info "http_requests" "")+-- >>> withLabel myVector ("GET", "200") incCounter +-- >>> withLabel myVector ("GET", "200") incCounter +-- >>> withLabel myVector ("GET", "404") incCounter +-- >>> withLabel myVector ("POST", "200") incCounter +-- >>> getVectorWith myVector getCounter  -- [(("GET","200"),2.0),(("GET","404"),1.0),(("POST","200"),1.0)]--- >>> exportMetricsAsText >>= Data.ByteString.putStr+-- >>> exportMetricsAsText >>= Data.ByteString.Lazy.putStr -- # HELP http_requests -- # TYPE http_requests counter -- http_requests{method="GET",code="200"} 2.0@@ -157,7 +157,7 @@ -- specifying the types of vectors more concise. -- -- >>> :{--- >>> let myVector :: IO (Metric (Vector Label3 Counter));+-- >>> let myVector :: Metric (Vector Label3 Counter); -- >>>     myVector = vector ("a", "b", "c") $ counter (Info "some_counter" "") -- >>> :} @@ -202,9 +202,9 @@ -- >>> let toSample = Sample "cpu_time" [] . toValue -- >>> let toSampleGroup = (:[]) . SampleGroup info GaugeType . (:[]) . toSample -- >>> let collectCPUTime = fmap toSampleGroup getCPUTime--- >>> let cpuTimeMetric = Metric (MkCPUTime ()) collectCPUTime+-- >>> let cpuTimeMetric = Metric (return (MkCPUTime (), collectCPUTime)) -- >>> register cpuTimeMetric--- >>> exportMetricsAsText >>= Data.ByteString.putStr+-- >>> exportMetricsAsText >>= Data.ByteString.Lazy.putStr -- # HELP cpu_time The current CPU time -- # TYPE cpu_time gauge -- cpu_time ...@@ -224,7 +224,7 @@ -- Note that the changes to numAdds are not reflected until the updateMetrics -- value has been evaluated in the IO monad. ----- >>> numAdds <- counter (Info "num_adds" "The number of additions")+-- >>> numAdds <- register $ counter (Info "num_adds" "The number of additions") -- >>> let add x y = incCounter numAdds >> return (x + y) -- >>> let (3, updateMetrics) = runMonitor $ (add 1 1) >>= (add 1) -- >>> getCounter numAdds@@ -265,4 +265,5 @@ -- $setup -- >>> :module +Prometheus -- >>> :module +Control.Monad+-- >>> :set -XOverloadedStrings -- >>> unregisterAll
src/Prometheus/Export/Text.hs view
@@ -1,19 +1,26 @@+{-# language OverloadedStrings #-}+ module Prometheus.Export.Text (     exportMetricsAsText ) where  import Prometheus.Info-import Prometheus.Label import Prometheus.Metric import Prometheus.Registry -import Data.List (intersperse, intercalate)-import qualified Data.ByteString as BS-import qualified Data.ByteString.UTF8 as BS+import Control.Monad.IO.Class+import qualified Data.ByteString.Builder as Build+import qualified Data.ByteString.Lazy as BS+import Data.Foldable (foldMap)+import Data.Monoid ((<>), mempty, mconcat)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T   -- $setup -- >>> :module +Prometheus+-- >>> :set -XOverloadedStrings -- >>> unregisterAll  -- | Export all registered metrics in the Prometheus 0.0.4 text exposition@@ -23,52 +30,53 @@ -- <http://prometheus.io/docs/instrumenting/exposition_formats/ documentation>. -- -- >>> :m +Data.ByteString--- >>> myCounter <- registerIO $ counter (Info "my_counter" "Example counter")+-- >>> myCounter <- register $ counter (Info "my_counter" "Example counter") -- >>> incCounter myCounter--- >>> exportMetricsAsText >>= Data.ByteString.putStr+-- >>> exportMetricsAsText >>= Data.ByteString.Lazy.putStr -- # HELP my_counter Example counter -- # TYPE my_counter counter -- my_counter 1.0-exportMetricsAsText :: IO BS.ByteString+exportMetricsAsText :: MonadIO m => m BS.ByteString exportMetricsAsText = do     samples <- collectMetrics-    let exportedSamples = map exportSampleGroup samples ++ [BS.empty]-    return $ BS.concat $ intersperse (BS.fromString "\n") exportedSamples+    return $ Build.toLazyByteString $ foldMap exportSampleGroup samples -exportSampleGroup :: SampleGroup -> BS.ByteString+exportSampleGroup :: SampleGroup -> Build.Builder exportSampleGroup (SampleGroup info ty samples) =-    if BS.null exportedSamples-        then BS.empty-        else prefix `BS.append` exportedSamples+    if null samples+        then mempty+        else prefix <> exportedSamples     where         exportedSamples = exportSamples samples         name = metricName info         help = metricHelp info-        prefix =  BS.fromString $ unlines [-                "# HELP " ++ name ++ " " ++ escape help-            ,   "# TYPE " ++ name ++ " " ++ show ty+        prefix = Build.byteString $ T.encodeUtf8 $ T.unlines [+                "# HELP " <> name <> " " <> T.concatMap escape help+            ,   "# TYPE " <> name <> " " <> T.pack (show ty)             ]-        escape []        = []-        escape ('\n':xs) = '\\' : 'n' : escape xs-        escape ('\\':xs) = '\\' : '\\' : escape xs-        escape (x:xs)    = x : escape xs--exportSamples :: [Sample] -> BS.ByteString-exportSamples = BS.intercalate (BS.fromString "\n") . map exportSample--exportSample :: Sample -> BS.ByteString-exportSample (Sample name [] value) = BS.concat [-        BS.fromString name, BS.fromString " ", value-    ]-exportSample (Sample name labels value) = BS.concat [-        BS.fromString name-    ,   BS.fromString "{", exportLabels labels, BS.fromString "} "-    ,   value-    ]+        escape '\n' = "\\n"+        escape '\\' = "\\\\"+        escape other = T.pack [other] -exportLabels :: LabelPairs -> BS.ByteString-exportLabels labels = BS.fromString $ intercalate "," $ map exportLabel labels+exportSamples :: [Sample] -> Build.Builder+exportSamples samples =+  mconcat [ exportSample s <> Build.charUtf8 '\n' | s <- samples ] -exportLabel :: (String, String) -> String-exportLabel (key, value) = key ++ "=" ++ show value+exportSample :: Sample -> Build.Builder+exportSample (Sample name labels value) =+  Build.byteString (T.encodeUtf8 name)+    <> (case labels of+         [] -> mempty+         l:ls ->+           Build.charUtf8 '{'+             <> exportLabel l+             <> mconcat [ Build.charUtf8 ',' <> exportLabel l' | l' <- ls ]+             <> Build.charUtf8 '}')+    <> Build.charUtf8 ' '+    <> Build.byteString value +exportLabel :: (Text, Text) -> Build.Builder+exportLabel (key, value) =+  Build.byteString (T.encodeUtf8 key)+    <> Build.charUtf8 '='+    <> Build.stringUtf8 (show value)
src/Prometheus/Info.hs view
@@ -3,30 +3,32 @@ ,   checkInfo ) where +import Data.Text (Text)+import qualified Data.Text as T  -- | Meta data about a metric including its name and a help string that -- describes the value that the metric is measuring. data Info = Info {-    metricName :: String-,   metricHelp :: String+    metricName :: Text+,   metricHelp :: Text } deriving (Read, Show, Eq, Ord)  checkInfo :: Info -> a -> a checkInfo info a-    | (x:_)       <- name, not $ validStart x     = errorInvalid-    | (_:xs)      <- name, not $ all validRest xs = errorInvalid-    | ('_':'_':_) <- name                         = errorPrefix-    | []          <- name                         = errorEmpty+    | (x:_)       <- T.unpack name, not $ validStart x     = errorInvalid+    | (_:xs)      <- T.unpack name, not $ all validRest xs = errorInvalid+    | ('_':'_':_) <- T.unpack name                         = errorPrefix+    | []          <- T.unpack name                         = errorEmpty     | otherwise                                   = a     where         name = metricName info          errorInvalid = error $ concat [-                "The metric '", name, "' contains invalid characters."+                "The metric '", T.unpack name, "' contains invalid characters."             ]          errorPrefix = error $ concat [-                "The metric '", name, "' cannot start with '__'."+                "The metric '", T.unpack name, "' cannot start with '__'."             ]          errorEmpty = error "Empty metric names are not allowed."
src/Prometheus/Label.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+ module Prometheus.Label (     Label (..) ,   LabelPairs@@ -14,10 +16,11 @@ ,   Label9 ) where +import Data.Text  -- | A list of tuples where the first value is the label and the second is the -- value of that label.-type LabelPairs = [(String, String)]+type LabelPairs = [(Text, Text)]  -- | Label describes a class of types that can be used to as the label of -- a vector.@@ -29,60 +32,58 @@ instance Label () where     labelPairs () () = [] -type Label1 = String+type Label1 = Text -instance Label String where+instance Label Text where     labelPairs key value = [(key, value)] -type Label2 = (String, String)+type Label2 = (Text, Text) -instance Label (String, String)  where+instance (a ~ Text, b ~ a) => Label (a, b)  where     labelPairs (k1, k2) (v1, v2) = [(k1, v1), (k2, v2)] -type Label3 = (String, String, String)+type Label3 = (Text, Text, Text) -instance Label (String, String, String)  where+instance (a ~ Text, b ~ a, c ~ a) => Label (a, b, c)  where     labelPairs (k1, k2, k3) (v1, v2, v3) = [(k1, v1), (k2, v2), (k3, v3)] -type Label4 = (String, String, String, String)+type Label4 = (Text, Text, Text, Text) -instance Label (String, String, String, String)  where+instance (a ~ Text, b ~ a, c ~ a, d ~ a) => Label (a, b, c, d)  where     labelPairs (k1, k2, k3, k4) (v1, v2, v3, v4) =             [(k1, v1), (k2, v2), (k3, v3), (k4, v4)] -type Label5 = (String, String, String, String, String)+type Label5 = (Text, Text, Text, Text, Text) -instance Label (String, String, String, String, String)  where+instance (a ~ Text, b ~ a, c ~ a, d ~ a, e ~ a) => Label (a, b, c, d, e)  where     labelPairs (k1, k2, k3, k4, k5) (v1, v2, v3, v4, v5) =             [(k1, v1), (k2, v2), (k3, v3), (k4, v4), (k5, v5)] -type Label6 = (String, String, String, String, String, String)+type Label6 = (Text, Text, Text, Text, Text, Text) -instance Label (String, String, String, String, String, String)  where+instance (a ~ Text, b ~ a, c ~ a, d ~ a, e ~ a, f ~ a) => Label (a, b, c, d, e, f)  where     labelPairs (k1, k2, k3, k4, k5, k6) (v1, v2, v3, v4, v5, v6) =             [(k1, v1), (k2, v2), (k3, v3), (k4, v4), (k5, v5), (k6, v6)] -type Label7 = (String, String, String, String, String, String, String)+type Label7 = (Text, Text, Text, Text, Text, Text, Text) -instance Label (String, String, String, String, String, String, String)  where+instance (a ~ Text, b ~ a, c ~ a, d ~ a, e ~ a, f ~ a, g ~ a) => Label (a, b, c, d, e, f, g)  where     labelPairs (k1, k2, k3, k4, k5, k6, k7) (v1, v2, v3, v4, v5, v6, v7) =             [(k1, v1), (k2, v2), (k3, v3), (k4, v4), (k5, v5), (k6, v6),              (k7, v7)] -type Label8 = (String, String, String, String, String, String, String, String)+type Label8 = (Text, Text, Text, Text, Text, Text, Text, Text) -instance Label (String, String, String, String, String, String, String,-                String)  where+instance (a ~ Text, b ~ a, c ~ a, d ~ a, e ~ a, f ~ a, g ~ a, h ~ a) => Label (a, b, c, d, e, f, g, h) where     labelPairs (k1, k2, k3, k4, k5, k6, k7, k8)                (v1, v2, v3, v4, v5, v6, v7, v8) =             [(k1, v1), (k2, v2), (k3, v3), (k4, v4), (k5, v5), (k6, v6),              (k7, v7), (k8, v8)] -type Label9 = (String, String, String, String, String, String, String, String,-               String)+type Label9 = (Text, Text, Text, Text, Text, Text, Text, Text,+               Text) -instance Label (String, String, String, String, String, String, String,-                String, String)  where+instance (a ~ Text, b ~ a, c ~ a, d ~ a, e ~ a, f ~ a, g ~ a, h ~ a, i ~ a) => Label (a, b, c, d, e, f, g, h, i) where     labelPairs (k1, k2, k3, k4, k5, k6, k7, k8, k9)                (v1, v2, v3, v4, v5, v6, v7, v8, v9) =             [(k1, v1), (k2, v2), (k3, v3), (k4, v4), (k5, v5), (k6, v6),
src/Prometheus/Metric.hs view
@@ -1,3 +1,5 @@+{-# language GeneralizedNewtypeDeriving #-}+ module Prometheus.Metric (     Metric (..) ,   Sample (..)@@ -8,7 +10,9 @@ import Prometheus.Info import Prometheus.Label +import Control.DeepSeq import qualified Data.ByteString as BS+import Data.Text (Text)   -- | The type of a sample. This corresponds to the 5 types of metrics supported@@ -30,7 +34,7 @@ -- | A single value recorded at a moment in time. The sample type contains the -- name of the sample, a list of labels and their values, and the value encoded -- as a ByteString.-data Sample = Sample String LabelPairs BS.ByteString+data Sample = Sample Text LabelPairs BS.ByteString     deriving (Show)  -- | A Sample group is a list of samples that is tagged with meta data@@ -42,7 +46,21 @@ -- of a handle value and a collect method. The handle value is typically a new -- type wrapped value that provides access to the internal state of the metric. -- The collect method samples the current value of the metric.-data Metric s = Metric {-        handle  :: s-    ,   collect :: IO [SampleGroup]+newtype Metric s =+  Metric+    { -- | 'construct' is an 'IO' action that creates a new instance of a metric.+      -- For example, in a counter, this 'IO' action would create a mutable reference+      -- to maintain the state of the counter.+      --+      -- 'construct' returns two things:+      --+      -- 1. The state of the metric itself, which can be used to modify the+      --    metric. A counter would return state pointing to the mutable+      --    reference.+      -- 2. An 'IO' action that samples the metric and returns 'SampleGroup's.+      --    This is the data that will be stored by Prometheus. +      construct :: IO (s, IO [SampleGroup])     }++instance NFData a => NFData (Metric a) where+  rnf (Metric a) = a `seq` ()
src/Prometheus/Metric/Counter.hs view
@@ -6,6 +6,7 @@ ,   unsafeAddCounter ,   addDurationToCounter ,   getCounter+,   countExceptions ) where  import Prometheus.Info@@ -13,6 +14,9 @@ import Prometheus.Metric.Observer (timeAction) import Prometheus.MonadMonitor +import Control.DeepSeq+import Control.Monad.Catch+import Control.Monad.IO.Class import Control.Monad (unless) import qualified Data.Atomics as Atomics import qualified Data.ByteString.UTF8 as BS@@ -21,29 +25,29 @@  newtype Counter = MkCounter (IORef.IORef Double) +instance NFData Counter where+  rnf (MkCounter ioref) = seq ioref ()+ -- | Creates a new counter metric with a given name and help string.-counter :: Info -> IO (Metric Counter)-counter info = do+counter :: Info -> Metric Counter+counter info = Metric $ do     ioref <- IORef.newIORef 0-    return Metric {-            handle = MkCounter ioref-        ,   collect = collectCounter info ioref-        }+    return (MkCounter ioref, collectCounter info ioref)  withCounter :: MonadMonitor m-          => Metric Counter+          => Counter           -> (Double -> Double)           -> m ()-withCounter Metric {handle = MkCounter ioref} f =+withCounter (MkCounter ioref) f =     doIO $ Atomics.atomicModifyIORefCAS_ ioref f  -- | Increments the value of a counter metric by 1.-incCounter :: MonadMonitor m => Metric Counter -> m ()+incCounter :: MonadMonitor m => Counter -> m () incCounter c = withCounter c (+ 1)  -- | Add the given value to the counter, if it is zero or more.-addCounter :: MonadMonitor m => Double -> Metric Counter -> m Bool-addCounter x c+addCounter :: MonadMonitor m => Counter -> Double -> m Bool+addCounter c x   | x < 0 = return False   | otherwise = do       withCounter c add@@ -51,25 +55,47 @@   where add i = i `seq` x `seq` i + x  -- | Add the given value to the counter. Panic if it is less than zero.-unsafeAddCounter :: MonadMonitor m => Double -> Metric Counter -> m ()-unsafeAddCounter x c = do-  added <- addCounter x c+unsafeAddCounter :: MonadMonitor m => Counter -> Double -> m ()+unsafeAddCounter c x = do+  added <- addCounter c x   unless added $     error $ "Tried to add negative value to counter: " ++ show x  -- | Add the duration of an IO action (in seconds) to a counter.-addDurationToCounter :: IO a -> Metric Counter -> IO a-addDurationToCounter io metric = do+--+-- If the IO action throws, no duration is added.+addDurationToCounter :: (MonadIO m, MonadMonitor m) => Counter -> m a -> m a+addDurationToCounter metric io = do     (result, duration) <- timeAction io-    _ <- addCounter duration metric+    _ <- addCounter metric duration      return result  -- | Retrieves the current value of a counter metric.-getCounter :: Metric Counter -> IO Double-getCounter Metric {handle = MkCounter ioref} = IORef.readIORef ioref+getCounter :: MonadIO m => Counter -> m Double+getCounter (MkCounter ioref) = liftIO $ IORef.readIORef ioref  collectCounter :: Info -> IORef.IORef Double -> IO [SampleGroup] collectCounter info c = do     value <- IORef.readIORef c     let sample = Sample (metricName info) [] (BS.fromString $ show value)     return [SampleGroup info CounterType [sample]]++-- | Count the amount of times an action throws any synchronous exception.+--+-- >>> exceptions <- register $ counter (Info "exceptions_total" "Total amount of exceptions thrown")+-- >>> countExceptions exceptions $ return ()+-- >>> getCounter exceptions+-- 0.0+-- >>> countExceptions exceptions (error "Oh no!") `catch` (\SomeException{} -> return ())+-- >>> getCounter exceptions+-- 1.0+--+-- It's important to note that this will count *all* synchronous exceptions. If+-- you want more granular counting of exceptions, you will need to write custom+-- code using 'incCounter'.+countExceptions :: (MonadCatch m, MonadMonitor m) => Counter -> m a -> m a+countExceptions m io = io `onException` incCounter m++-- $setup+-- >>> :module +Prometheus+-- >>> :set -XOverloadedStrings
src/Prometheus/Metric/Gauge.hs view
@@ -15,6 +15,8 @@ import Prometheus.Metric.Observer (timeAction) import Prometheus.MonadMonitor +import Control.DeepSeq+import Control.Monad.IO.Class import qualified Data.Atomics as Atomics import qualified Data.ByteString.UTF8 as BS import qualified Data.IORef as IORef@@ -22,54 +24,54 @@  newtype Gauge = MkGauge (IORef.IORef Double) +instance NFData Gauge where+  rnf (MkGauge ioref) = seq ioref ()+ -- | Create a new gauge metric with a given name and help string.-gauge :: Info -> IO (Metric Gauge)-gauge info = do+gauge :: Info -> Metric Gauge+gauge info = Metric $ do     ioref <- IORef.newIORef 0-    return Metric {-            handle = MkGauge ioref-        ,   collect = collectGauge info ioref-        }+    return (MkGauge ioref, collectGauge info ioref)  withGauge :: MonadMonitor m-          => Metric Gauge+          => Gauge           -> (Double -> Double)           -> m ()-withGauge (Metric {handle = MkGauge ioref}) f =+withGauge (MkGauge ioref) f =     doIO $ Atomics.atomicModifyIORefCAS_ ioref f  -- | Adds a value to a gauge metric.-addGauge :: MonadMonitor m => Double -> Metric Gauge -> m ()-addGauge x g = withGauge g add+addGauge :: MonadMonitor m => Gauge -> Double -> m ()+addGauge g x = withGauge g add     where add i = i `seq` x `seq` i + x  -- | Subtracts a value from a gauge metric.-subGauge :: MonadMonitor m => Double -> Metric Gauge -> m ()-subGauge x g = withGauge g sub+subGauge :: MonadMonitor m => Gauge -> Double -> m ()+subGauge g x = withGauge g sub     where sub i = i `seq` x `seq` i - x  -- | Increments a gauge metric by 1.-incGauge :: MonadMonitor m => Metric Gauge -> m ()+incGauge :: MonadMonitor m => Gauge -> m () incGauge g = withGauge g (+ 1)  -- | Decrements a gauge metric by 1.-decGauge :: MonadMonitor m => Metric Gauge -> m ()+decGauge :: MonadMonitor m => Gauge -> m () decGauge g = withGauge g (+ (-1))  -- | Sets a gauge metric to a specific value.-setGauge :: MonadMonitor m => Double -> Metric Gauge -> m ()-setGauge r g = withGauge g set+setGauge :: MonadMonitor m => Gauge -> Double -> m ()+setGauge g r = withGauge g set     where set _ = r  -- | Retrieves the current value of a gauge metric.-getGauge :: Metric Gauge -> IO Double-getGauge (Metric {handle = MkGauge ioref}) = IORef.readIORef ioref+getGauge :: MonadIO m => Gauge -> m Double+getGauge (MkGauge ioref) = liftIO $ IORef.readIORef ioref  -- | Sets a gauge metric to the duration in seconds of an IO action.-setGaugeToDuration :: IO a -> Metric Gauge -> IO a-setGaugeToDuration io metric = do+setGaugeToDuration :: (MonadIO m, MonadMonitor m) => Gauge -> m a -> m a+setGaugeToDuration metric io = do     (result, duration) <- timeAction io-    setGauge duration metric+    setGauge metric duration      return result  collectGauge :: Info -> IORef.IORef Double -> IO [SampleGroup]
src/Prometheus/Metric/Histogram.hs view
@@ -1,3 +1,6 @@+{-# language BangPatterns #-}+{-# language OverloadedStrings #-}+ module Prometheus.Metric.Histogram (     Histogram ,   histogram@@ -19,25 +22,30 @@  import Control.Applicative ((<$>)) import qualified Control.Concurrent.STM as STM+import Control.DeepSeq+import Control.Monad.IO.Class import qualified Data.ByteString.UTF8 as BS import qualified Data.Map.Strict as Map+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T import Numeric (showFFloat)  -- | A histogram. Counts the number of observations that fall within the -- specified buckets. newtype Histogram = MkHistogram (STM.TVar BucketCounts) +instance NFData Histogram where+  rnf (MkHistogram a) = seq a ()+ -- | Create a new 'Histogram' metric with a given name, help string, and -- list of buckets. Panics if the list of buckets is not strictly increasing. -- A good default list of buckets is 'defaultBuckets'. You can also create -- buckets with 'linearBuckets' or 'exponentialBuckets'.-histogram :: Info -> [Bucket] -> IO (Metric Histogram)-histogram info buckets = do+histogram :: Info -> [Bucket] -> Metric Histogram+histogram info buckets = Metric $ do   countsTVar <- STM.newTVarIO  (emptyCounts buckets)-  return Metric {-          handle = MkHistogram countsTVar-      ,   collect = collectHistogram info countsTVar-      }+  return (MkHistogram countsTVar, collectHistogram info countsTVar)  -- | Upper-bound for a histogram bucket. type Bucket = Double@@ -63,20 +71,20 @@  instance Observer Histogram where     -- | Add a new observation to a histogram metric.-    observe v h = withHistogram h (insert v)+    observe h v = withHistogram h (insert v)  -- | Transform the contents of a histogram. withHistogram :: MonadMonitor m-              => Metric Histogram -> (BucketCounts -> BucketCounts) -> m ()-withHistogram Metric {handle = MkHistogram bucketCounts} f =+              => Histogram -> (BucketCounts -> BucketCounts) -> m ()+withHistogram (MkHistogram !bucketCounts) f =   doIO $ STM.atomically $ STM.modifyTVar' bucketCounts f  -- | Retries a map of upper bounds to counts of values observed that are -- less-than-or-equal-to that upper bound, but greater than any other upper -- bound in the map.-getHistogram :: Metric Histogram -> IO (Map.Map Bucket Int)-getHistogram Metric {handle = MkHistogram bucketsTVar} =-    histCountsPerBucket <$> STM.atomically (STM.readTVar bucketsTVar)+getHistogram :: MonadIO m => Histogram -> m (Map.Map Bucket Int)+getHistogram (MkHistogram bucketsTVar) =+    liftIO $ histCountsPerBucket <$> STM.atomically (STM.readTVar bucketsTVar)  -- | Record an observation. insert :: Double -> BucketCounts -> BucketCounts@@ -92,19 +100,19 @@ collectHistogram :: Info -> STM.TVar BucketCounts -> IO [SampleGroup] collectHistogram info bucketCounts = STM.atomically $ do     BucketCounts total count counts <- STM.readTVar bucketCounts-    let sumSample = Sample (name ++ "_sum") [] (bsShow total)-    let countSample = Sample (name ++ "_count") [] (bsShow count)-    let infSample = Sample (name ++ "_bucket") [(bucketLabel, "+Inf")] (bsShow count)+    let sumSample = Sample (name <> "_sum") [] (bsShow total)+    let countSample = Sample (name <> "_count") [] (bsShow count)+    let infSample = Sample (name <> "_bucket") [(bucketLabel, "+Inf")] (bsShow count)     let samples = map toSample (cumulativeSum (Map.toAscList counts))     return [SampleGroup info HistogramType $ samples ++ [infSample, sumSample, countSample]]     where         toSample (upperBound, count') =-            Sample (name ++ "_bucket") [(bucketLabel, formatFloat upperBound)] $ bsShow count'+            Sample (name <> "_bucket") [(bucketLabel, formatFloat upperBound)] $ bsShow count'         name = metricName info          -- We don't particularly want scientific notation, so force regular         -- numeric representation instead.-        formatFloat x = showFFloat Nothing x ""+        formatFloat x = T.pack (showFFloat Nothing x "")          cumulativeSum xs = zip (map fst xs) (scanl1 (+) (map snd xs)) @@ -113,7 +121,7 @@  -- | The label that defines the upper bound of a bucket of a histogram. @"le"@ -- is short for "less than or equal to".-bucketLabel :: String+bucketLabel :: Text bucketLabel = "le"  -- | The default Histogram buckets. These are tailored to measure the response
src/Prometheus/Metric/Observer.hs view
@@ -5,32 +5,34 @@ ) where  import Data.Ratio ((%))-import Prometheus.Metric import Prometheus.MonadMonitor +import Control.Monad.IO.Class import System.Clock (Clock(..), diffTimeSpec, getTime, toNanoSecs)  -- | Interface shared by 'Summary' and 'Histogram'. class Observer metric where     -- | Observe that a particular floating point value has occurred.     -- For example, observe that this request took 0.23s.-    observe :: MonadMonitor m => Double -> Metric metric -> m ()+    observe :: MonadMonitor m => metric -> Double -> m ()  -- | Adds the duration in seconds of an IO action as an observation to an -- observer metric.-observeDuration :: Observer metric => IO a -> Metric metric -> IO a-observeDuration io metric = do+--+-- If the IO action throws an exception no duration will be observed.+observeDuration :: (Observer metric, MonadIO m, MonadMonitor m) => metric -> m a -> m a+observeDuration metric io = do     (result, duration) <- timeAction io-    observe duration metric+    observe metric duration      return result   -- | Evaluate @io@ and return its result as well as how long it took to evaluate, -- in seconds.-timeAction :: IO a -> IO (a, Double)+timeAction :: MonadIO m => m a -> m (a, Double) timeAction io = do-    start  <- getTime Monotonic+    start  <- liftIO $ getTime Monotonic     result <- io-    end    <- getTime Monotonic+    end    <- liftIO $ getTime Monotonic     let duration = toNanoSecs (end `diffTimeSpec` start) % 1000000000     return (result, fromRational duration)
src/Prometheus/Metric/Summary.hs view
@@ -1,3 +1,6 @@+{-# language BangPatterns #-}+{-# language OverloadedStrings #-}+ module Prometheus.Metric.Summary (     Summary ,   Quantile@@ -22,39 +25,43 @@ import Prometheus.Metric.Observer import Prometheus.MonadMonitor -import Data.Int (Int64)-import Data.Foldable (foldr') import qualified Control.Concurrent.STM as STM+import Control.DeepSeq+import Control.Monad.IO.Class import qualified Data.ByteString.UTF8 as BS+import Data.Foldable (foldr')+import Data.Int (Int64)+import Data.Monoid ((<>))+import qualified Data.Text as T   newtype Summary = MkSummary (STM.TVar Estimator) +instance NFData Summary where+  rnf (MkSummary a) = a `seq` ()+ -- | Creates a new summary metric with a given name, help string, and a list of -- quantiles. A reasonable set set of quantiles is provided by -- 'defaultQuantiles'.-summary :: Info -> [Quantile] -> IO (Metric Summary)-summary info quantiles = do+summary :: Info -> [Quantile] -> Metric Summary+summary info quantiles = Metric $ do     valueTVar <- STM.newTVarIO (emptyEstimator quantiles)-    return Metric {-            handle = MkSummary valueTVar-        ,   collect = collectSummary info valueTVar-        }+    return (MkSummary valueTVar, collectSummary info valueTVar)  withSummary :: MonadMonitor m-            => Metric Summary -> (Estimator -> Estimator) -> m ()-withSummary (Metric {handle = MkSummary valueTVar}) f =+            => Summary -> (Estimator -> Estimator) -> m ()+withSummary (MkSummary !valueTVar) f =     doIO $ STM.atomically $ do         STM.modifyTVar' valueTVar compress         STM.modifyTVar' valueTVar f  instance Observer Summary where     -- | Adds a new observation to a summary metric.-    observe v s = withSummary s (insert v)+    observe s v = withSummary s (insert v)  -- | Retrieves a list of tuples containing a quantile and its associated value.-getSummary :: Metric Summary -> IO [(Rational, Double)]-getSummary (Metric {handle = MkSummary valueTVar}) = do+getSummary :: MonadIO m => Summary -> m [(Rational, Double)]+getSummary (MkSummary valueTVar) = liftIO $ do     estimator <- STM.atomically $ do         STM.modifyTVar' valueTVar compress         STM.readTVar valueTVar@@ -68,22 +75,22 @@     estimator@(Estimator count itemSum _ _) <- STM.readTVar valueTVar     let quantiles = map fst $ estQuantiles estimator     let samples =  map (toSample estimator) quantiles-    let sumSample = Sample (metricName info ++ "_sum") [] (bsShow itemSum)-    let countSample = Sample (metricName info ++ "_count") [] (bsShow count)+    let sumSample = Sample (metricName info <> "_sum") [] (bsShow itemSum)+    let countSample = Sample (metricName info <> "_count") [] (bsShow count)     return [SampleGroup info SummaryType $ samples ++ [sumSample, countSample]]     where         bsShow :: Show s => s -> BS.ByteString         bsShow = BS.fromString . show          toSample estimator q =-            Sample (metricName info) [("quantile", show $ toDouble q)] $+            Sample (metricName info) [("quantile", T.pack . show $ toDouble q)] $                 bsShow $ query estimator q          toDouble :: Rational -> Double         toDouble = fromRational -dumpEstimator :: Metric Summary -> IO Estimator-dumpEstimator (Metric {handle = MkSummary valueTVar}) =+dumpEstimator :: Summary -> IO Estimator+dumpEstimator (MkSummary valueTVar) =     STM.atomically $ STM.readTVar valueTVar  -- | A quantile is a pair of a quantile value and an associated acceptable error
src/Prometheus/Metric/Vector.hs view
@@ -12,27 +12,29 @@ import Prometheus.MonadMonitor  import Control.Applicative ((<$>))-import Data.Traversable (forM)+import Control.DeepSeq import qualified Data.Atomics as Atomics import qualified Data.IORef as IORef import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import Data.Traversable (forM)  -type VectorState l m = (IO (Metric m), Map.Map l (Metric m))+type VectorState l m = (Metric m, Map.Map l (m, IO [SampleGroup]))  data Vector l m = MkVector (IORef.IORef (VectorState l m)) +instance NFData (Vector l m) where+  rnf (MkVector ioref) = seq ioref ()+ -- | Creates a new vector of metrics given a label.-vector :: Label l => l -> IO (Metric m) -> IO (Metric (Vector l m))-vector labels gen = do+vector :: Label l => l -> Metric m -> Metric (Vector l m)+vector labels gen = Metric $ do     ioref <- checkLabelKeys labels $ IORef.newIORef (gen, Map.empty)-    return Metric {-            handle  = MkVector ioref-        ,   collect = collectVector labels ioref-        }+    return (MkVector ioref, collectVector labels ioref)  checkLabelKeys :: Label l => l -> a -> a-checkLabelKeys keys r = foldl check r $ map fst $ labelPairs keys keys+checkLabelKeys keys r = foldl check r $ map (T.unpack . fst) $ labelPairs keys keys     where         check _ "instance" = error "The label 'instance' is reserved."         check _ "job"      = error "The label 'job' is reserved."@@ -59,8 +61,8 @@     (_, metricMap) <- IORef.readIORef ioref     joinSamples <$> concat <$> mapM collectInner (Map.assocs metricMap)     where-        collectInner (labels, metric) =-            map (adjustSamples labels) <$> collect metric+        collectInner (labels, (_metric, sampleGroups)) =+            map (adjustSamples labels) <$> sampleGroups          adjustSamples labels (SampleGroup info ty samples) =             SampleGroup info ty (map (prependLabels labels) samples)@@ -74,41 +76,41 @@         extract [] = []         extract (SampleGroup _ _ s:xs) = s ++ extract xs -getVectorWith :: (Metric metric -> IO a)-              -> Metric (Vector label metric)+getVectorWith :: Vector label metric+              -> (metric -> IO a)               -> IO [(label, a)]-getVectorWith f (Metric {handle = MkVector valueTVar}) = do+getVectorWith (MkVector valueTVar) f = do     (_, metricMap) <- IORef.readIORef valueTVar-    Map.assocs <$> forM metricMap f+    Map.assocs <$> forM metricMap (f . fst)  -- | Given a label, applies an operation to the corresponding metric in the -- vector. withLabel :: (Label label, MonadMonitor m)-          => label-          -> (Metric metric -> IO ())-          -> Metric (Vector label metric)+          => Vector label metric+          -> label+          -> (metric -> IO ())           -> m ()-withLabel label f (Metric {handle = MkVector ioref}) = doIO $ do-    (gen, _) <- IORef.readIORef ioref+withLabel (MkVector ioref) label f = doIO $ do+    (Metric gen, _) <- IORef.readIORef ioref     newMetric <- gen     metric <- Atomics.atomicModifyIORefCAS ioref $ \(_, metricMap) ->         let maybeMetric = Map.lookup label metricMap             updatedMap  = Map.insert label newMetric metricMap         in  case maybeMetric of-                Nothing     -> ((gen, updatedMap), newMetric)-                Just metric -> ((gen, metricMap), metric)-    f metric+                Nothing     -> ((Metric gen, updatedMap), newMetric)+                Just metric -> ((Metric gen, metricMap), metric)+    f (fst metric)  -- | Removes a label from a vector. removeLabel :: (Label label, MonadMonitor m)-            => Metric (Vector label metric) -> label -> m ()-removeLabel (Metric {handle = MkVector valueTVar}) label =+            => Vector label metric -> label -> m ()+removeLabel (MkVector valueTVar) label =     doIO $ Atomics.atomicModifyIORefCAS_ valueTVar f     where f (desc, metricMap) = (desc, Map.delete label metricMap)  -- | Removes all labels from a vector. clearLabels :: (Label label, MonadMonitor m)-            => Metric (Vector label metric) -> m ()-clearLabels (Metric {handle = MkVector valueTVar}) =+            => Vector label metric -> m ()+clearLabels (MkVector valueTVar) =     doIO $ Atomics.atomicModifyIORefCAS_ valueTVar f     where f (desc, _) = (desc, Map.empty)
src/Prometheus/MonadMonitor.hs view
@@ -1,4 +1,7 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+ module Prometheus.MonadMonitor (     MonadMonitor (..) ,   Monitor@@ -9,17 +12,44 @@  import Control.Applicative (Applicative) import Control.Monad.Identity (Identity, runIdentity)+import Control.Monad.Trans.Class import Control.Monad.Trans.Class (MonadTrans)+import Control.Monad.Trans.Error (ErrorT, Error)+import Control.Monad.Trans.Except (ExceptT)+import Control.Monad.Trans.Identity (IdentityT)+import Control.Monad.Trans.Maybe (MaybeT)+import qualified Control.Monad.Trans.RWS.Lazy as L+import qualified Control.Monad.Trans.RWS.Strict as S+import Control.Monad.Trans.Reader (ReaderT)+import qualified Control.Monad.Trans.State.Lazy as L+import qualified Control.Monad.Trans.State.Strict as S+import qualified Control.Monad.Trans.Writer.Lazy as L+import qualified Control.Monad.Trans.Writer.Strict as S import Control.Monad.Writer.Strict (WriterT, runWriterT, tell)+import Data.Monoid (Monoid)   -- | MonadMonitor describes a class of Monads that are capable of performing -- asynchronous IO operations. class Monad m => MonadMonitor m where     doIO :: IO () -> m ()+    default doIO :: (MonadTrans t, MonadMonitor n, m ~ t n) => IO () -> m ()+    doIO = lift . doIO  instance MonadMonitor IO where     doIO = id++instance (Error e, MonadMonitor m) => MonadMonitor (ErrorT e m)+instance (MonadMonitor m) => MonadMonitor (ExceptT e m)+instance (MonadMonitor m) => MonadMonitor (IdentityT m)+instance (MonadMonitor m) => MonadMonitor (MaybeT m)+instance (MonadMonitor m, Monoid w) => MonadMonitor (L.RWST r w s m)+instance (MonadMonitor m, Monoid w) => MonadMonitor (S.RWST r w s m) +instance (MonadMonitor m) => MonadMonitor (ReaderT r m)+instance (MonadMonitor m) => MonadMonitor (L.StateT s m)+instance (MonadMonitor m) => MonadMonitor (S.StateT s m) +instance (MonadMonitor m, Monoid w) => MonadMonitor (L.WriterT w m)+instance (MonadMonitor m, Monoid w) => MonadMonitor (S.WriterT w m)   -- | Monitor allows the use of Prometheus metrics in pure code. When using -- Monitor, all of the metric operations will be collected and queued into
src/Prometheus/Registry.hs view
@@ -11,6 +11,7 @@ import Prometheus.Metric  import Control.Applicative ((<$>))+import Control.Monad.IO.Class import System.IO.Unsafe (unsafePerformIO) import qualified Control.Concurrent.STM as STM @@ -19,30 +20,31 @@ -- >>> :module +Prometheus -- >>> unregisterAll -data RegisteredMetric = forall s. MkRegisteredMetric (Metric s)--type Registry = [RegisteredMetric]+-- | A 'Registry' is a list of all registered metrics, currently represented by+-- their sampling functions.+type Registry = [IO [SampleGroup]]  {-# NOINLINE globalRegistry #-} globalRegistry :: STM.TVar Registry globalRegistry = unsafePerformIO $ STM.newTVarIO []  -- | Registers a metric with the global metric registry.-register :: Metric s -> IO (Metric s)-register metric = do-    let addToRegistry = (MkRegisteredMetric metric :)-    STM.atomically $ STM.modifyTVar' globalRegistry addToRegistry+register :: MonadIO m => Metric s -> m s+register (Metric mk) = liftIO $ do+    (metric, sampleGroups) <- mk+    let addToRegistry = (sampleGroups :)+    liftIO $ STM.atomically $ STM.modifyTVar' globalRegistry addToRegistry     return metric  -- | Registers a metric with the global metric registry.-registerIO :: IO (Metric s) -> IO (Metric s)+registerIO :: MonadIO m => m (Metric s) -> m s registerIO metricGen = metricGen >>= register  -- | Registers a metric with the global metric registry. -- -- __IMPORTANT__: This method should only be used to register metrics as top -- level symbols, it should not be run from other pure code.-unsafeRegister :: Metric s -> Metric s+unsafeRegister :: Metric s -> s unsafeRegister = unsafePerformIO . register  -- | Registers a metric with the global metric registry.@@ -57,12 +59,12 @@ --  let c = unsafeRegisterIO $ counter (Info "my_counter" "An example metric") -- :} -- ...-unsafeRegisterIO :: IO (Metric s) -> Metric s+unsafeRegisterIO :: IO (Metric s) -> s unsafeRegisterIO = unsafePerformIO . registerIO  -- | Removes all currently registered metrics from the registry.-unregisterAll :: IO ()-unregisterAll = STM.atomically $ STM.writeTVar globalRegistry []+unregisterAll :: MonadIO m => m ()+unregisterAll = liftIO $ STM.atomically $ STM.writeTVar globalRegistry []  -- | Collect samples from all currently registered metrics. In typical use cases -- there is no reason to use this function, instead you should use@@ -70,10 +72,7 @@ -- -- This function is likely only of interest if you wish to export metrics in -- a non-supported format for use with another monitoring service.-collectMetrics :: IO [SampleGroup]-collectMetrics = do+collectMetrics :: MonadIO m => m [SampleGroup]+collectMetrics = liftIO $ do     registry <- STM.atomically $ STM.readTVar globalRegistry-    concat <$> mapM collectRegistered registry--collectRegistered :: RegisteredMetric -> IO [SampleGroup]-collectRegistered (MkRegisteredMetric metric) = collect metric+    concat <$> sequence registry