statsd-rupp 0.4.0.0 → 0.4.0.1
raw patch · 5 files changed
+137/−75 lines, 5 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- System.Metrics.StatsD.Internal: extractPercentiles :: StatConfig -> [Int]
Files
- CHANGELOG.md +3/−1
- src/System/Metrics/StatsD.hs +8/−1
- src/System/Metrics/StatsD/Internal.hs +86/−58
- statsd-rupp.cabal +1/−1
- test/Spec.hs +39/−14
CHANGELOG.md view
@@ -6,7 +6,9 @@ and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). -## Unreleased+## 0.4.0.1 - 2023-09-05++- Improve resilience against bad input. ## 0.4.0.0 - 2023-09-04
src/System/Metrics/StatsD.hs view
@@ -28,6 +28,7 @@ ) where +import Control.Monad (when) import Data.ByteString.Char8 qualified as C import Data.HashSet qualified as HashSet import System.Metrics.StatsD.Internal@@ -46,7 +47,7 @@ processSample, statsLoop, )-import UnliftIO (MonadIO, MonadUnliftIO)+import UnliftIO (MonadIO, MonadUnliftIO, throwIO) import UnliftIO.Async (link, withAsync) type Key = String@@ -72,6 +73,9 @@ newStatCounter :: (MonadIO m) => Stats -> Key -> Int -> m StatCounter newStatCounter stats key sampling = do+ when (sampling < 0) $+ throwIO $+ userError "Counter sampling rate should not be negative" newMetric stats (C.pack key) (CounterData 0) return $ StatCounter stats (C.pack key) sampling @@ -83,6 +87,9 @@ newStatTiming :: (MonadIO m) => Stats -> Key -> Int -> m StatTiming newStatTiming stats key sampling = do+ when (sampling < 0) $+ throwIO $+ userError "Timing sampling rate should not be negative" newMetric stats (C.pack key) (TimingData []) return $ StatTiming stats (C.pack key) sampling
src/System/Metrics/StatsD/Internal.hs view
@@ -35,7 +35,6 @@ statReports, TimingStats (..), makeTimingStats,- extractPercentiles, timingReports, trimPercentile, percentileSuffix,@@ -56,7 +55,7 @@ ) where -import Control.Monad (MonadPlus (..), forM_, forever, void, when)+import Control.Monad (MonadPlus (..), forM_, forever, guard, unless, void, when) import Data.Bool (bool) import Data.ByteString (ByteString) import Data.ByteString qualified as B@@ -68,7 +67,7 @@ import Data.HashMap.Strict qualified as HashMap import Data.HashSet (HashSet) import Data.HashSet qualified as HashSet-import Data.List (sort)+import Data.List (nub, sort) import Data.Vector (Vector, (!)) import Data.Vector qualified as V import Network.Socket (Socket)@@ -188,39 +187,48 @@ if params.stats then Just dat else Nothing newMetric :: (MonadIO m) => Stats -> ByteString -> MetricData -> m ()-newMetric stats key store- | validateKey key = do- e <- atomically $ do- exists <- HashMap.member key <$> readTVar stats.metrics- if exists- then return True- else do- modifyTVar- stats.metrics- (addMetric stats.params key store)- return False- when e $- throwIO $- userError $- "A metric already exists with key: " <> C.unpack key- | otherwise =- throwIO $ userError $ "Metric key is invalid: " <> C.unpack key+newMetric stats key store = do+ unless (validateKey key) $ do+ throwIO $ userError "Metric key is invalid"+ e <- atomically $ do+ exists <- HashMap.member key <$> readTVar stats.metrics+ if exists+ then return True+ else do+ modifyTVar+ stats.metrics+ (addMetric stats.params key store)+ return False+ when e $ throwIO $ userError $ "StatsD key exists: " <> C.unpack key validateKey :: ByteString -> Bool validateKey t = not (C.null t) && C.all valid t where valid c = elem c ("._-" :: [Char]) || isAscii c && isAlphaNum c +validateValue :: Value -> Bool+validateValue (Counter c) = c > 0+validateValue (Gauge g False) = g > 0+validateValue (Gauge _ True) = True+validateValue (Timing t) = t > 0+validateValue (Set e) = validateKey e+ addReading :: Value -> ByteString -> Metrics -> Metrics addReading reading = HashMap.adjust adjust where adjust m = m {index = m.index + 1, dat = change <$> m.dat} change store = case (reading, store) of- (Counter c, CounterData s) -> CounterData (s + c)- (Gauge i False, GaugeData _) -> GaugeData i- (Gauge i True, GaugeData g) -> GaugeData (max 0 (g + i))- (Timing t, TimingData s) -> TimingData (t : s)- (Set e, SetData s) -> SetData (HashSet.insert e s)+ (Counter c, CounterData s) ->+ CounterData (s + c)+ (Gauge i False, GaugeData _) ->+ GaugeData i+ (Gauge i True, GaugeData g)+ | i > maxBound - g -> GaugeData maxBound+ | otherwise -> GaugeData (max 0 (g + i))+ (Timing t, TimingData s) ->+ TimingData (t : s)+ (Set e, SetData s) ->+ SetData (HashSet.insert e s) _ -> error "Stats reading mismatch" newReading :: Stats -> ByteString -> Value -> STM Int@@ -232,6 +240,12 @@ processSample :: (MonadIO m) => Stats -> Int -> ByteString -> Value -> m () processSample stats sampling key val = do+ when (0 > sampling) $+ throwIO $+ userError "StatsD sampling rate must not be negative"+ unless (validateValue val) $+ throwIO $+ userError "StatsD value is not valid" idx <- atomically $ newReading stats key val when stats.params.samples $ submit stats $@@ -241,28 +255,38 @@ newMetrics = newTVarIO HashMap.empty newParams :: StatConfig -> StatParams-newParams cfg =- StatParams- { pfx = p,- pfxCounter = s <> C.pack cfg.prefixCounter <> ".",- pfxGauge = s <> C.pack cfg.prefixGauge <> ".",- pfxTimer = s <> C.pack cfg.prefixTimer <> ".",- pfxSet = s <> C.pack cfg.prefixSet <> ".",- newline = cfg.appendNewline,- stats = cfg.reportStats,- samples = cfg.reportSamples,- percentiles = extractPercentiles cfg,- flush = abs cfg.flushInterval- }+newParams cfg+ | v =+ StatParams+ { pfx = pfx,+ pfxCounter = s <> bc <> ".",+ pfxGauge = s <> bg <> ".",+ pfxTimer = s <> bt <> ".",+ pfxSet = s <> be <> ".",+ newline = cfg.appendNewline,+ stats = cfg.reportStats,+ samples = cfg.reportSamples,+ percentiles = 100 : nub cfg.timingPercentiles,+ flush = cfg.flushInterval+ }+ | otherwise = error "StatsD config invalid" where- p =+ bn = C.pack cfg.namespace+ bs = C.pack cfg.prefixStats+ bg = C.pack cfg.prefixGauge+ bc = C.pack cfg.prefixCounter+ bt = C.pack cfg.prefixTimer+ be = C.pack cfg.prefixSet+ v =+ all validateKey [bs, bg, bc, bt, be]+ && bool (validateKey bn) True (null cfg.namespace)+ && 0 <= cfg.flushInterval+ && all (\pc -> pc > 0 && 100 > pc) cfg.timingPercentiles+ pfx = if null cfg.namespace then ""- else C.pack cfg.namespace <> "."- s =- if null cfg.prefixStats- then p- else p <> C.pack cfg.prefixStats <> "."+ else bn <> "."+ s = pfx <> bs <> "." newStats :: StatConfig -> TVar Metrics -> Socket -> Stats newStats cfg metrics socket =@@ -341,14 +365,6 @@ where sorted = sort timings -extractPercentiles :: StatConfig -> [Int]-extractPercentiles =- (100 :)- . HashSet.toList- . HashSet.fromList- . filter (\x -> x > 0 && x < 100)- . (.timingPercentiles)- timingReports :: StatParams -> ByteString -> [Int] -> [Report] timingReports params key timings = concatMap (timingStats params key tstats) params.percentiles@@ -504,22 +520,29 @@ parseKeyValue kv t = do case C.split ':' kv of [key, v] -> do+ guard (validateKey key) value <- parseValue v t return (key, value) _ -> mzero parseValue v t = case C.unpack t of- "c" -> Counter <$> parseRead v+ "c" -> Counter <$> parseNatural v "g" -> case C.uncons v of- Just ('+', n) -> Gauge <$> parseInt n <*> pure True+ Just ('+', _) -> Gauge <$> parseInt v <*> pure True Just ('-', _) -> Gauge <$> parseInt v <*> pure True- _ -> Gauge <$> parseRead v <*> pure False- "s" -> return $ Set v- "ms" -> Timing <$> parseRead v+ _ -> Gauge <$> parseNatural v <*> pure False+ "s" -> do+ guard (validateKey v)+ return (Set v)+ "ms" -> Timing <$> parseNatural v _ -> mzero parseRate r = case C.uncons r of- Just ('@', s) -> parseRead s+ Just ('@', s) -> do+ t <- parseRead s+ guard (t > 0.0)+ guard (t < 1.0)+ return t _ -> mzero parseRead :: (MonadPlus m, Read a) => ByteString -> m a@@ -528,4 +551,9 @@ parseInt :: (MonadPlus m) => ByteString -> m Int parseInt bs = case C.readInt bs of Just (i, bs') | B.null bs' -> return i+ _ -> mzero++parseNatural :: (MonadPlus m) => ByteString -> m Int+parseNatural bs = case C.readInt bs of+ Just (i, bs') | B.null bs' -> guard (0 <= i) >> return i _ -> mzero
statsd-rupp.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: statsd-rupp-version: 0.4.0.0+version: 0.4.0.1 synopsis: Simple StatsD Client description: Please see the README on GitHub at <https://github.com/jprupp/statsd-rupp#readme> category: System
test/Spec.hs view
@@ -21,6 +21,17 @@ import Test.Hspec.QuickCheck import Test.QuickCheck import UnliftIO+ ( MonadIO (liftIO),+ MonadUnliftIO,+ atomically,+ bracket,+ link,+ newTQueueIO,+ newTVarIO,+ readTQueue,+ withAsync,+ writeTQueue,+ ) main :: IO () main = hspec $ do@@ -214,22 +225,39 @@ forM_ gauges (setGauge g) replicateM_ (length gauges) report rs <- replicateM 2 report- let rs' = replicate 2 $ Report "stats.gauges.radius" (Gauge 55 False) 1.0+ let rs' =+ replicate 2 $+ Report "stats.gauges.radius" (Gauge 55 False) 1.0 rs `shouldMatchList` rs' it "increments and decrements value" $ \(stats, report) -> do g <- newStatGauge stats "breadth" 50+ let sk = "breadth"+ tk = "stats.gauges.breadth"+ r k v t = Report k (Gauge v t) 1.0 incrementGauge g 5- report `shouldReturn` Report "breadth" (Gauge 5 True) 1.0- report `shouldReturn` Report "stats.gauges.breadth" (Gauge 55 False) 1.0+ report `shouldReturn` r sk 5 True+ report `shouldReturn` r tk 55 False incrementGauge g (-10)- report `shouldReturn` Report "breadth" (Gauge (-10) True) 1.0- report `shouldReturn` Report "stats.gauges.breadth" (Gauge 45 False) 1.0+ report `shouldReturn` r sk (-10) True+ report `shouldReturn` r tk 45 False decrementGauge g 50- report `shouldReturn` Report "breadth" (Gauge (-50) True) 1.0- report `shouldReturn` Report "stats.gauges.breadth" (Gauge 0 False) 1.0+ report `shouldReturn` r sk (-50) True+ report `shouldReturn` r tk 0 False decrementGauge g (-25)- report `shouldReturn` Report "breadth" (Gauge 25 True) 1.0- report `shouldReturn` Report "stats.gauges.breadth" (Gauge 25 False) 1.0+ report `shouldReturn` r sk 25 True+ report `shouldReturn` r tk 25 False+ incrementGauge g maxBound+ report `shouldReturn` r sk maxBound True+ report `shouldReturn` r tk maxBound False+ decrementGauge g minBound+ report `shouldReturn` r sk minBound True+ report `shouldReturn` r tk 0 False+ incrementGauge g maxBound+ report `shouldReturn` r sk maxBound True+ report `shouldReturn` r tk maxBound False+ decrementGauge g 5+ report `shouldReturn` r sk (-5) True+ report `shouldReturn` r tk (maxBound - 5) False describe "set" $ do it "reports events" $ \(stats, report) -> do let set = ["one", "two", "three", "three"]@@ -327,14 +355,11 @@ oneof [counter, gauge, timing, set] where counter = Counter <$> genNatural- timing = Timing <$> arbitrary+ timing = Timing <$> genNatural set = Set <$> genValidString gauge = do t <- arbitrary- v <-- if t- then arbitrary- else genNatural+ v <- if t then arbitrary else genNatural return $ Gauge v t instance Arbitrary Report where