diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/src/System/Metrics/StatsD.hs b/src/System/Metrics/StatsD.hs --- a/src/System/Metrics/StatsD.hs +++ b/src/System/Metrics/StatsD.hs @@ -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 diff --git a/src/System/Metrics/StatsD/Internal.hs b/src/System/Metrics/StatsD/Internal.hs --- a/src/System/Metrics/StatsD/Internal.hs +++ b/src/System/Metrics/StatsD/Internal.hs @@ -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 diff --git a/statsd-rupp.cabal b/statsd-rupp.cabal --- a/statsd-rupp.cabal +++ b/statsd-rupp.cabal @@ -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 category: System diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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