From e04e80fd3de13e312ac54a4cc48f1d20dbbced26 Mon Sep 17 00:00:00 2001 From: Ian Duncan Date: Wed, 27 Jul 2022 14:33:12 -0700 Subject: [PATCH 1/4] fix async interrupt breaking bookkeeping in an observer --- prometheus-client/src/Prometheus/Metric/Summary.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/prometheus-client/src/Prometheus/Metric/Summary.hs b/prometheus-client/src/Prometheus/Metric/Summary.hs index dcc5b5d..3324eab 100644 --- a/prometheus-client/src/Prometheus/Metric/Summary.hs +++ b/prometheus-client/src/Prometheus/Metric/Summary.hs @@ -79,7 +79,7 @@ summary info quantiles_ = Metric $ do instance Observer Summary where -- | Adds a new observation to a summary metric. - observe s v = doIO $ withMVar (reqSketch s) (`ReqSketch.insert` v) + observe s v = doIO $ withMVarMasked (reqSketch s) (\rs -> rs `ReqSketch.insert` v) -- | Retrieves a list of tuples containing a quantile and its associated value. getSummary :: MonadIO m => Summary -> m [(Rational, Double)] From eb4c76049cb9f4d80160157a89e6f06bf5e76f0e Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 24 Jun 2025 15:35:05 -0600 Subject: [PATCH 2/4] Use stm-containers to avoid contention in Vector --- .gitignore | 4 +- prometheus-client/prometheus-client.cabal | 4 + .../src/Prometheus/Metric/Vector.hs | 75 +++++++++++-------- stack.yaml | 6 +- 4 files changed, 53 insertions(+), 36 deletions(-) diff --git a/.gitignore b/.gitignore index 10c1a6e..cf27c75 100644 --- a/.gitignore +++ b/.gitignore @@ -4,4 +4,6 @@ cabal.sandbox.config cabal.config .stack-work */*.yaml.lock -.devcontainer \ No newline at end of file +.devcontainer +dist-newstyle/ +stack.yaml.lock diff --git a/prometheus-client/prometheus-client.cabal b/prometheus-client/prometheus-client.cabal index c016b0a..4a3eccb 100644 --- a/prometheus-client/prometheus-client.cabal +++ b/prometheus-client/prometheus-client.cabal @@ -49,6 +49,10 @@ library , utf8-string , exceptions , text + , stm-containers + , focus + , list-t + , hashable , data-sketches ghc-options: -Wall diff --git a/prometheus-client/src/Prometheus/Metric/Vector.hs b/prometheus-client/src/Prometheus/Metric/Vector.hs index 117cc84..f7c5a4b 100644 --- a/prometheus-client/src/Prometheus/Metric/Vector.hs +++ b/prometheus-client/src/Prometheus/Metric/Vector.hs @@ -13,25 +13,31 @@ import Prometheus.MonadMonitor import Control.Applicative ((<$>)) 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) +import System.IO.Unsafe (unsafeInterleaveIO) + +import Control.Concurrent.STM (atomically) +import Control.Monad.Trans (lift) +import qualified StmContainers.Map as Map +import qualified Focus +import qualified ListT +import Data.Hashable type VectorState l m = (Metric m, Map.Map l (m, IO [SampleGroup])) -data Vector l m = MkVector (IORef.IORef (VectorState l m)) +data Vector l m = MkVector (VectorState l m) instance NFData (Vector l m) where - rnf (MkVector ioref) = seq ioref () + rnf (MkVector (gen, ioref)) = seq ioref `seq` seq gen () -- | Creates a new vector of metrics given a label. vector :: Label l => l -> Metric m -> Metric (Vector l m) vector labels gen = Metric $ do - ioref <- checkLabelKeys labels $ IORef.newIORef (gen, Map.empty) - return (MkVector ioref, collectVector labels ioref) + m <- Map.newIO + vec <- checkLabelKeys labels $ pure $ (gen, m) + return (MkVector vec, collectVector labels vec) checkLabelKeys :: Label l => l -> a -> a checkLabelKeys keys r = foldl check r $ map (T.unpack . fst) $ labelPairs keys keys @@ -56,10 +62,10 @@ checkLabelKeys keys r = foldl check r $ map (T.unpack . fst) $ labelPairs keys k -- TODO(will): This currently makes the assumption that all the types and info -- for all sample groups returned by a metric's collect method will be the same. -- It is not clear that this will always be a valid assumption. -collectVector :: Label l => l -> IORef.IORef (VectorState l m) -> IO [SampleGroup] -collectVector keys ioref = do - (_, metricMap) <- IORef.readIORef ioref - joinSamples <$> concat <$> mapM collectInner (Map.assocs metricMap) +collectVector :: Label l => l -> VectorState l m -> IO [SampleGroup] +collectVector keys (_, metricMap) = do + assocs <- ListT.toList $ Map.listTNonAtomic metricMap + joinSamples <$> concat <$> mapM collectInner assocs where collectInner (labels, (_metric, sampleGroups)) = map (adjustSamples labels) <$> sampleGroups @@ -79,38 +85,45 @@ collectVector keys ioref = do getVectorWith :: Vector label metric -> (metric -> IO a) -> IO [(label, a)] -getVectorWith (MkVector valueTVar) f = do - (_, metricMap) <- IORef.readIORef valueTVar - Map.assocs <$> forM metricMap (f . fst) +getVectorWith (MkVector (_, metricMap)) f = do + ListT.toList $ do + (l, (m, _collect)) <- Map.listTNonAtomic metricMap + a <- lift $ f m + pure (l, a) + -- | Given a label, applies an operation to the corresponding metric in the -- vector. -withLabel :: (Label label, MonadMonitor m) +withLabel :: (Hashable label, Label label, MonadMonitor m) => Vector label metric -> label -> (metric -> IO ()) -> m () -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 -> ((Metric gen, updatedMap), newMetric) - Just metric -> ((Metric gen, metricMap), metric) +withLabel (MkVector (gen, metricMap)) label f = doIO $ do + newMetric <- unsafeInterleaveIO $ construct gen + metric <- + atomically $ + Map.focus + (Focus.alter (\mmetric -> + case mmetric of + Nothing -> + Just newMetric + Just metric -> + Just metric) + *> Focus.lookupWithDefault newMetric) + label + metricMap + f (fst metric) -- | Removes a label from a vector. -removeLabel :: (Label label, MonadMonitor m) +removeLabel :: (Hashable label, Label label, MonadMonitor m) => Vector label metric -> label -> m () -removeLabel (MkVector valueTVar) label = - doIO $ Atomics.atomicModifyIORefCAS_ valueTVar f - where f (desc, metricMap) = (desc, Map.delete label metricMap) +removeLabel (MkVector (_, metricMap)) label = + doIO $ atomically $ Map.delete label metricMap -- | Removes all labels from a vector. clearLabels :: (Label label, MonadMonitor m) => Vector label metric -> m () -clearLabels (MkVector valueTVar) = - doIO $ Atomics.atomicModifyIORefCAS_ valueTVar f - where f (desc, _) = (desc, Map.empty) +clearLabels (MkVector (_, metricMap)) = + doIO $ atomically $ Map.reset metricMap diff --git a/stack.yaml b/stack.yaml index ec9efad..b64b3e5 100644 --- a/stack.yaml +++ b/stack.yaml @@ -5,7 +5,5 @@ packages: - prometheus-metrics-ghc - prometheus-proc - wai-middleware-prometheus -extra-deps: -- unix-memory-0.1.2 -- data-sketches-0.3.0.0 -resolver: lts-18.5 + +resolver: lts-23.25 From bc1ea93f76bbf62d7023c401d7d8f2a04c2d4196 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Wed, 25 Jun 2025 10:46:44 -0600 Subject: [PATCH 3/4] Fix tests --- prometheus-client/prometheus-client.cabal | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/prometheus-client/prometheus-client.cabal b/prometheus-client/prometheus-client.cabal index 4a3eccb..1d93e5c 100644 --- a/prometheus-client/prometheus-client.cabal +++ b/prometheus-client/prometheus-client.cabal @@ -66,12 +66,17 @@ test-suite doctest base >=4.7 && <5 , doctest , prometheus-client + , list-t + , hashable + , stm-containers test-suite spec type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: src, tests main-is: Spec.hs + build-tool-depends: + hspec-discover:hspec-discover build-depends: QuickCheck , atomic-primops @@ -91,6 +96,10 @@ test-suite spec , text , primitive , data-sketches + , focus + , list-t + , hashable + , stm-containers ghc-options: -Wall benchmark bench From 5320b3e0a32b83b41a742285ebcdb5f667454d4a Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Wed, 25 Jun 2025 10:50:50 -0600 Subject: [PATCH 4/4] Make Label require Hashable, fewer visible changes --- prometheus-client/src/Prometheus/Label.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/prometheus-client/src/Prometheus/Label.hs b/prometheus-client/src/Prometheus/Label.hs index 4067e21..1d60fd9 100644 --- a/prometheus-client/src/Prometheus/Label.hs +++ b/prometheus-client/src/Prometheus/Label.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Prometheus.Label ( Label (..) @@ -17,6 +18,15 @@ module Prometheus.Label ( ) where import Data.Text +import Data.Hashable + +instance (Hashable a, Hashable b, Hashable c, Hashable d, Hashable e, Hashable f, Hashable g, Hashable h) => Hashable (a, b, c, d, e, f, g, h) where + hashWithSalt s (a, b, c, d, e, f, g, h) = + s `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c `hashWithSalt` d `hashWithSalt` e `hashWithSalt` f `hashWithSalt` g `hashWithSalt` h + +instance (Hashable a, Hashable b, Hashable c, Hashable d, Hashable e, Hashable f, Hashable g, Hashable h, Hashable i) => Hashable (a, b, c, d, e, f, g, h, i) where + hashWithSalt s (a, b, c, d, e, f, g, h, i) = + s `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c `hashWithSalt` d `hashWithSalt` e `hashWithSalt` f `hashWithSalt` g `hashWithSalt` h `hashWithSalt` i -- | A list of tuples where the first value is the label and the second is the -- value of that label. @@ -24,7 +34,7 @@ type LabelPairs = [(Text, Text)] -- | Label describes a class of types that can be used to as the label of -- a vector. -class Ord l => Label l where +class Hashable l => Label l where labelPairs :: l -> l -> LabelPairs type Label0 = ()