From 9fe069302397eb2cd7a4b0c1b1d384bbae7d6861 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Wed, 17 Jun 2026 22:15:09 +0200 Subject: [PATCH 01/17] window-stats: sliding windows with fixed sizes These modules provide a fingertree-backed sliding window with fixed element count. The fingertree backend caches a user-supplied monoidal measure `v` which updates incrementally as elements are added and evicted, which allows for constant time lookup of its value regardless of window size. The Window.Count module exposes a public API, and the private internal implementation is exposed by the Internal.Count module without any guarantees that it stays compatible between any releases. The Measures module exposes some common and practical prebuilt measures. --- window-stats/lib/Data/Window/Count.hs | 94 +++++ .../lib/Data/Window/Internal/Count.hs | 352 ++++++++++++++++++ .../lib/Data/Window/Internal/Measures.hs | 121 ++++++ 3 files changed, 567 insertions(+) create mode 100644 window-stats/lib/Data/Window/Count.hs create mode 100644 window-stats/lib/Data/Window/Internal/Count.hs create mode 100644 window-stats/lib/Data/Window/Internal/Measures.hs diff --git a/window-stats/lib/Data/Window/Count.hs b/window-stats/lib/Data/Window/Count.hs new file mode 100644 index 0000000000..9876b776d6 --- /dev/null +++ b/window-stats/lib/Data/Window/Count.hs @@ -0,0 +1,94 @@ +-- | +-- Module : Data.Window.Count +-- Description : Count-based sliding window backed by a finger tree. +-- Stability : experimental +-- +-- This module provides the core sliding window data structure, 'Window', +-- which retains a fixed number of the most recently inserted elements. +-- Elements are evicted from the oldest end of the window automatically +-- on insertion once the window reaches its maximum size. +-- +-- The window is backed by a finger tree ('Data.FingerTree.FingerTree'), +-- giving O(1) amortised insertion (and on-insert eviction); the bulk +-- eviction primitives ('evictOldestN', 'trimByMeasure', 'resize') run +-- in O(log w). The window measure is a product of an element count +-- and a user-supplied monoid @v@, cached at the root of the finger +-- tree and accessible in O(1) via 'windowMeasure'. +-- +-- The user-supplied measure @v@ is updated incrementally as elements +-- are inserted and evicted — no recomputation of the entire window is +-- needed. Combine this module with "Data.Window.DigestCount" from the +-- @with-tdigest@ sublibrary for approximate-quantile statistics, or +-- define your own measure type for other rolling statistics. +-- +-- This module is intended to be imported qualified. +-- +-- = Ordering convention +-- +-- The window's underlying finger tree always has the newest element +-- at the left end and the oldest at the right. The construction +-- functions differ in the expected input order — see the per-function +-- haddocks — so refer to those when feeding pre-collected data. +-- +-- = Example +-- +-- @ +-- -- Build a window of size 5 tracking a running sum: +-- let samples = [10.0, 9.0 .. 1.0] :: [Double] +-- window = fromListN 5 samples :: Window (Sum Double) (SumSample Double) +-- in windowSum window +-- -- => Just 40.0 +-- +-- let window' = insert (11.0 :: Double) window +-- in windowSum window' +-- -- => Just 45.0 +-- @ +-- +-- = Integration with other libraries +-- +-- For approximate quantile statistics, see "Data.Window.DigestCount". +-- For time-based windowing, see "Data.Window.Timed". +-- For a combination of the above two, see "Data.Window.DigestTimed". +-- For integration with the @foldl@ package, see the @with-foldl@ sublibrary. +-- +module Data.Window.Count + ( -- * Types + Window + -- * Construction + , empty + , singleton + -- ** From collections + , fromListN + , fromFoldable + -- * Insertion + , insert + , insertMany + -- * Querying + , size + , windowMaxSize + , isFull + , isEmpty + , windowMeasure + -- ** Statistics + , SumSample (..) + , windowSum + , MinMaxV + , MinMaxSample (..) + , windowMinMax + , MomentSample (..) + , WelfordMeasure + , windowMean + , windowVariance + , windowStdDev + -- * Splitting + , evictOldest + , evictOldestN + , trimByMeasure + , resize + -- * Conversions + , toNewestFirst + , toOldestFirst + ) where + +import Data.Window.Internal.Count +import Data.Window.Internal.Measures diff --git a/window-stats/lib/Data/Window/Internal/Count.hs b/window-stats/lib/Data/Window/Internal/Count.hs new file mode 100644 index 0000000000..fed9c233ba --- /dev/null +++ b/window-stats/lib/Data/Window/Internal/Count.hs @@ -0,0 +1,352 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.Window.Internal.Count where + +import Control.DeepSeq +import Data.Coerce +import Data.FingerTree qualified as FT +import Data.Foldable +import Data.Monoid +import GHC.Generics + +import Data.Window.Internal.Measures + +-- | A measure that tracks the count of elements, +-- and the user-supplied measure. +-- +data WindowMeasure v = WindowMeasure + { wmCount :: {-# UNPACK #-} !Int + , wmV :: v + } + deriving (Generic, NFData, Show) + +instance Semigroup v => Semigroup (WindowMeasure v) where + WindowMeasure c1 v1 <> WindowMeasure c2 v2 = + WindowMeasure (c1 + c2) (v1 <> v2) + +instance Monoid v => Monoid (WindowMeasure v) where + {-# INLINE mempty #-} + mempty = WindowMeasure 0 mempty + +-- | A sample wrapper +-- +newtype Sample a = Sample { sampleValue :: a } + deriving (Generic, Show) + deriving anyclass NFData + +instance FT.Measured v a => FT.Measured (WindowMeasure v) (Sample a) where + {-# INLINE measure #-} + measure = WindowMeasure 1 . FT.measure . sampleValue + + +-- | A window over a stream of samples, evicting elements +-- spilling past 'windowMaxSize' +-- +data Window v a = Window + { windowMaxSize :: {-# UNPACK #-} !Int + , windowTree :: !(FT.FingerTree (WindowMeasure v) (Sample a)) + } + deriving (Generic, NFData, Show) + +instance Foldable (Window v) where + foldMap f Window { windowTree } = foldMap (f . sampleValue) windowTree + + +-- | The user-supplied measure of the current window contents. +-- +windowMeasure :: FT.Measured v a + => Window v a + -> v +windowMeasure = wmV . FT.measure . windowTree +{-# INLINE windowMeasure #-} + + +-- | retrieve the sum over the sliding window +-- \(O(1)\) +-- +windowSum :: Num a => Window (Sum a) (SumSample a) -> Maybe a +windowSum w + | size w == 0 = Nothing + | otherwise = Just . getSum . windowMeasure $ w +{-# INLINE windowSum #-} + + +-- | retrieve min/max values over the sliding window +-- \(O(1)\) +-- +windowMinMax :: Ord a => Window (MinMaxV a) (MinMaxSample a) -> Maybe (a, a) +windowMinMax = getMinMaxV . windowMeasure +{-# INLINE windowMinMax #-} + + +-- | retrieve the running mean (via Welford's algorithm) over the +-- sliding window. +-- \(O(1)\) +-- +windowMean :: Fractional a => Window (WelfordMeasure a) (MomentSample a) -> Maybe a +windowMean w + | size w == 0 = Nothing + | otherwise = Just . welfordMean . windowMeasure $ w +{-# INLINE windowMean #-} + + +-- | retrieve the running sample variance (denominator @n - 1@) over +-- the sliding window. +-- \(O(1)\) +-- +windowVariance :: Fractional a => Window (WelfordMeasure a) (MomentSample a) -> Maybe a +windowVariance w + | welfordN m < 2 = Nothing + | otherwise = Just (welfordM2 m / fromIntegral (welfordN m - 1)) + where m = windowMeasure w +{-# INLINE windowVariance #-} + + +-- | retrieve the running sample standard deviation over the sliding +-- window. +-- \(O(1)\) +-- +windowStdDev :: Floating a => Window (WelfordMeasure a) (MomentSample a) -> Maybe a +windowStdDev = fmap sqrt . windowVariance +{-# INLINE windowStdDev #-} + + +-- | Returns the count of elements in the window +-- \(O(1)\) +-- +size :: FT.Measured v a + => Window v a + -> Int +size = wmCount . FT.measure . windowTree +{-# INLINE size #-} + + +-- | Constructs an empty window with capacity of @windowMaxSize@ +-- +empty :: FT.Measured v a => Int -> Window v a +empty windowMaxSize = Window { windowMaxSize, windowTree = FT.empty } + + +-- | Constructs a window with capacity of @windowMaxSize@ containing a single sample +-- +singleton :: (FT.Measured v b, Coercible a b) => Int -> a -> Window v b +singleton windowMaxSize a = + Window { windowMaxSize, windowTree = FT.singleton (Sample (coerce a)) } + + +-- | Insert a new sample, then evict if the window has +-- exceeded @windowMaxSize@. +-- +-- @a@ must be the unwrapped version of b. +-- +-- /Invariant:/ assumes the input window satisfies +-- @'size' w '<=' 'windowMaxSize' w@. Insert evicts at most one +-- element, so handing 'insert' an over-full window leaves it +-- over-full. Windows produced by any function in this module satisfy +-- the invariant, so this only matters if you construct or mutate the +-- 'Window' record by hand. +-- +-- \(O(1)\) amortized, \(O(\log w)\) w/c +-- +insert :: (FT.Measured v b, Coercible a b) + => a + -> Window v b + -> Window v b +insert val win@Window { windowMaxSize, windowTree } = win { windowTree = ftree' } + where + ftree = Sample (coerce val) FT.<| windowTree + ftree' = if size win >= windowMaxSize + then case FT.viewr ftree of + FT.EmptyR -> error "impossible" + prefix FT.:> _ -> prefix + else ftree + !_ = FT.measure ftree' + + +-- | Insert many samples into the window, evicting as soon +-- as the size exceeds @windowMaxSize@. For a bulk add followed by single trim +-- operation, see 'fromFoldable'. +-- Elements should be provided in in order of freshest samples in the __tail__. +-- \(O(\n log w)\), use when n >> w +-- +insertMany :: (FT.Measured v b, Foldable f, Coercible a b) + => f a + -> Window v b + -> Window v b +insertMany as w = foldl' (flip insert) w as + + +-- | Discard the oldest sample +-- \(O(1)\) amortized, \(O(\log w)\) w/c +-- +evictOldest :: FT.Measured v a + => Window v a + -> Window v a +evictOldest win@Window { windowTree } = + case FT.viewr windowTree of + FT.EmptyR -> win + prefix FT.:> _ -> + let !_ = FT.measure prefix + in win { windowTree = prefix } + + +-- | Discard N oldest samples +-- \(O(\log w)\) +-- +evictOldestN :: FT.Measured v a + => Int + -> Window v a + -> Window v a +evictOldestN n win + | n <= 0 = win + | n >= total = win { windowTree = FT.empty } + | otherwise = takeUntil (\v -> wmCount v > keep) win + where + total = size win + keep = total - n + + +-- | Returns the longest newest-end prefix of the window whose +-- accumulated 'WindowMeasure' does __not__ satisfy the predicate. +-- Equivalently, walks the window from newest to oldest, accumulating +-- the measure, and stops at the first point where the predicate flips +-- to 'True' — discarding everything from that point on (the oldest +-- tail). +-- +-- /Precondition:/ the predicate must be __monotone__ along the prefix: +-- once it returns 'True' for some prefix, it must continue to return +-- 'True' for every longer prefix. Calling 'takeUntil' with a +-- non-monotone predicate (for example one phrased over the running +-- variance carried by 'WelfordMeasure') yields an unspecified split +-- point and is almost never what you want. +-- +-- This function lives in the internal module as the primitive used by +-- 'evictOldestN' and 'trimByMeasure'. Public callers should prefer +-- 'Data.Window.Count.trimByMeasure' (which hides 'WindowMeasure' and +-- works on the user-supplied measure @v@) or the dedicated helper +-- 'evictOldestN'. +-- \(O(\log w)\) +-- +takeUntil :: FT.Measured v a + => (WindowMeasure v -> Bool) + -> Window v a + -> Window v a +takeUntil p win@Window { windowTree } = win { windowTree = windowTree' } + where + windowTree' = FT.takeUntil p windowTree + !_ = wmV $ FT.measure windowTree' + + +-- | Trim the window from the oldest end, keeping the longest +-- newest-end prefix whose cumulative user-supplied measure @v@ does +-- __not__ satisfy the predicate. +-- +-- For example, to retain only the most recent samples whose cumulative +-- weight (a 'Data.Monoid.Sum') stays under a budget: +-- +-- @ +-- trimByMeasure (\\s -> 'Data.Monoid.getSum' s > budget) window +-- @ +-- +-- /Precondition:/ the predicate must be __monotone__ along the prefix. +-- See 'takeUntil' for the full caveat. +-- \(O(\log w)\) +-- +trimByMeasure :: FT.Measured v a + => (v -> Bool) + -> Window v a + -> Window v a +trimByMeasure p = takeUntil (p . wmV) + + +-- | Set a new maximum size for the window, evicting the oldest +-- samples if the new size is smaller than the current count. +-- \(O(\log w)\) +-- +resize :: FT.Measured v a + => Int + -> Window v a + -> Window v a +resize n win + | n <= 0 = win { windowMaxSize = 0, windowTree = FT.empty } + | size win > n = let win' = win { windowMaxSize = n } + in takeUntil (\v -> wmCount v > n) win' + | otherwise = win { windowMaxSize = n } + + +-- | Tests if window is full +-- \(O(1)\) +-- +isFull :: FT.Measured v a => Window v a -> Bool +isFull w = size w >= windowMaxSize w +{-# INLINE isFull #-} + + +-- | Tests if window is empty +-- \(O(1)\) +-- +isEmpty :: FT.Measured v a => Window v a -> Bool +isEmpty = (== 0) . size +{-# INLINE isEmpty #-} + + +-- | This is a more efficient alternative to 'fromFoldable' for +-- creating a window from a list for cases where the length of the input +-- list is significantly greater than the provided window size: +-- only the first @windowMaxSize@ elements of the input are consumed. +-- +-- Elements should be provided in the order of freshest samples at the __head__ +-- for correct behaviour (__note__: this is opposite from 'insertMany' and 'fromFoldable') +-- \(O(\w log w)\) +-- +fromListN :: forall v a b. (FT.Measured v b, Coercible a b) + => Int -- ^ window size + -> [a] + -> Window v b +fromListN windowMaxSize as = + Window + { windowMaxSize + , windowTree = windowTree' + } + where + windowTree' = FT.fromList . map (Sample . coerce) . take windowMaxSize $ as + !_ = FT.measure windowTree' + + +-- | Construct a window from a 'Foldable' collection, +-- which first creates a window from all available elements and performs +-- a single trim operation at the end. +-- Elements should be provided in the order of freshest samples in the __tail__ +-- \(O(\n log n)\), use when n ~= w +-- +fromFoldable :: forall t v a b. (FT.Measured v b, Foldable t, Coercible a b) + => Int -- ^ window size + -> t a + -> Window v b +fromFoldable n as = takeUntil (\v -> wmCount v > n) win + where + win = Window { windowMaxSize = n, windowTree } + windowTree = foldl' (\ft a -> Sample (coerce a) FT.<| ft) FT.empty as + + +-- | Yields the window in order, ie. newest elements at the head +-- \(O(n)\) +-- +toNewestFirst :: Coercible a b => Window v a -> [b] +toNewestFirst = coerce . toList +{-# INLINE toNewestFirst #-} + + +-- | Yields the window in reverse, ie. oldest elements at the head +-- \(O(n)\) +-- +toOldestFirst :: Coercible a b => Window v a -> [b] +toOldestFirst = coerce . foldl' (flip (:)) [] diff --git a/window-stats/lib/Data/Window/Internal/Measures.hs b/window-stats/lib/Data/Window/Internal/Measures.hs new file mode 100644 index 0000000000..341f34f95d --- /dev/null +++ b/window-stats/lib/Data/Window/Internal/Measures.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Data.Window.Internal.Measures +-- Description : Prebuilt sample wrappers and cached measure types. +-- Stability : internal +-- +-- The sample wrappers ('SumSample', 'MinMaxSample', 'MomentSample') +-- and their associated cached-measure types ('MinMaxV', +-- 'WelfordMeasure') used by the prebuilt statistics in +-- 'Data.Window.Count' / 'Data.Window.Timed'. The public modules +-- re-export the sample wrappers (with constructors) and the measure +-- types (opaquely); the measure internals — constructors and field +-- accessors — live here. +-- +-- This module is __internal__. Importing it grants the access needed +-- for things like combining 'WelfordMeasure' values from disjoint +-- windows, computing population variance from the running +-- 'welfordM2' / 'welfordN', serialising the cached measure for +-- telemetry, or seeding a window with a precomputed measure. Use at +-- your own risk: field names and representations may change between +-- minor versions without corresponding changes to the stable public +-- API. +-- +module Data.Window.Internal.Measures + ( -- * Sum + SumSample (..) + -- * Min/Max + , MinMaxSample (..) + , MinMaxV (..) + -- * Welford moments + , MomentSample (..) + , WelfordMeasure (..) + ) where + +import Control.Applicative ((<|>)) +import Control.DeepSeq +import Data.FingerTree +import Data.Monoid +import GHC.Generics + +-- | Wrapper for computing sums over the sliding window +-- +newtype SumSample a = SumSample { getSumSample :: a } + deriving (Generic, Show) + deriving anyclass NFData + deriving newtype Num + +instance Num a => Measured (Sum a) (SumSample a) where + {-# INLINE measure #-} + measure (SumSample s) = Sum s + + +newtype MinMaxSample a = MinMaxSample { getMinMaxSample :: a } + deriving (Generic, Show) + deriving anyclass NFData + +-- | Wrapper for capturing min/max over the sliding window +newtype MinMaxV a = MinMaxV { getMinMaxV :: Maybe (a, a) } + deriving (Eq, Show) + +instance Ord a => Semigroup (MinMaxV a) where + {-# INLINEABLE (<>) #-} + MinMaxV v1 <> MinMaxV v2 = + case (v1, v2) of + (Just (l1, u1), Just (l2, u2)) -> + let !l = min l1 l2 + !u = max u1 u2 + in MinMaxV $ Just (l, u) + _otherwise -> MinMaxV $ v1 <|> v2 + +instance Ord a => Monoid (MinMaxV a) where + {-# INLINE mempty #-} + mempty = MinMaxV Nothing + +instance Ord a => Measured (MinMaxV a) (MinMaxSample a) where + {-# INLINE measure #-} + measure (MinMaxSample s) = MinMaxV $ Just (s, s) + + +newtype MomentSample a = MomentSample { getMomentSample :: a } + deriving (Generic, Show) + deriving anyclass NFData + +data WelfordMeasure a = WelfordMeasure + { welfordN :: {-# UNPACK #-} !Int + , welfordMean :: !a + , welfordM2 :: !a + } + deriving (Generic, NFData, Eq, Show) + +instance (Fractional a) => Semigroup (WelfordMeasure a) where + {-# INLINEABLE (<>) #-} + WelfordMeasure nA mA m2A <> WelfordMeasure nB mB m2B + | nA == 0 = WelfordMeasure nB mB m2B + | nB == 0 = WelfordMeasure nA mA m2A + | otherwise = + let n = nA + nB + delta = mB - mA + mean = mA + delta * fromIntegral nB / fromIntegral n + m2 = m2A + m2B + delta * delta + * fromIntegral nA + * fromIntegral nB + / fromIntegral n + in WelfordMeasure n mean m2 + +instance Fractional a => Monoid (WelfordMeasure a) where + {-# INLINE mempty #-} + mempty = WelfordMeasure 0 0 0 + +instance Fractional a => Measured (WelfordMeasure a) (MomentSample a) where + {-# INLINE measure #-} + measure (MomentSample x) = WelfordMeasure 1 x 0 From fca9c6e1c1e50f629e62f160de034a59c1b671e4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Wed, 17 Jun 2026 22:24:24 +0200 Subject: [PATCH 02/17] window-stats: Time-based sliding windows These modules keep samples within a configured duration of the newest sample's timestamp. These variants abstract over the timestamp type via the 'TimeLike' class, which have two implementations defined: - `UTCTime` / `NominalDiffTime` (wall-clock, from `time`) - `Time` / `DiffTime` (monotonic, from `io-classes:si-timers`) Monotonic is preferred when sliding-window correctness must not be perturbed by NTP corrections or wall-clock jumps; wall-clock fits data that already carries `UTCTime` timestamps. --- .../lib/Data/Window/Internal/Timed.hs | 444 ++++++++++++++++++ window-stats/lib/Data/Window/TimeLike.hs | 73 +++ window-stats/lib/Data/Window/Timed.hs | 81 ++++ 3 files changed, 598 insertions(+) create mode 100644 window-stats/lib/Data/Window/Internal/Timed.hs create mode 100644 window-stats/lib/Data/Window/TimeLike.hs create mode 100644 window-stats/lib/Data/Window/Timed.hs diff --git a/window-stats/lib/Data/Window/Internal/Timed.hs b/window-stats/lib/Data/Window/Internal/Timed.hs new file mode 100644 index 0000000000..e7273f4bdb --- /dev/null +++ b/window-stats/lib/Data/Window/Internal/Timed.hs @@ -0,0 +1,444 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.Window.Internal.Timed where + +import Control.DeepSeq +import Control.Monad.Class.MonadTime.SI (Time) +import Data.Coerce +import Data.FingerTree (FingerTree, ViewL (..), ViewR (..)) +import Data.FingerTree qualified as FT +import Data.Foldable +import Data.Maybe (listToMaybe) +import Data.Monoid (Last(..), Sum(..)) +import Data.Time (UTCTime) +import GHC.Generics + +import Data.Window.Internal.Measures +import Data.Window.TimeLike + + +-- | A measure that tracks the count of elements, the timestamp +-- bounds, and the user-supplied measure. +-- +data TimedMeasure t v = TimedMeasure + { tmStart :: !(Maybe t) + -- ^ oldest timestamp in the window prefix + , tmCount :: {-# UNPACK #-} !Int + -- ^ number of samples in the window prefix + , tmV :: v + -- ^ user supplied measure + } + deriving (Generic, NFData, Show) + +instance Semigroup v => Semigroup (TimedMeasure t v) where + {-# INLINE (<>) #-} + TimedMeasure _s1 c1 v1 <> TimedMeasure s2 c2 v2 = + TimedMeasure s2 (c1 + c2) (v1 <> v2) + +instance Monoid v => Monoid (TimedMeasure t v) where + {-# INLINE mempty #-} + mempty = TimedMeasure Nothing 0 mempty + +instance FT.Measured v a => FT.Measured (TimedMeasure t v) (TimedSample t a) where + {-# INLINE measure #-} + measure (TimedSample t a) = + TimedMeasure + { tmStart = Just t + , tmCount = 1 + , tmV = FT.measure a + } + + +-- | Configured maximum duration of the window. +windowMaxDuration :: TimedWindow t v a -> Dur t +windowMaxDuration = twDuration +{-# INLINE windowMaxDuration #-} + + +-- | A sample wrapper with an associated timestamp. +-- +data TimedSample t a = TimedSample + { tsNow :: !t + , tsValue :: !a + } + deriving (Generic, NFData, Show) + + +-- | A window over a sequence of timestamped samples within the given +-- duration. Values are stored in non-increasing timestamp order, ie. +-- with freshest samples at the head. +data TimedWindow t v a = TimedWindow + { twDuration :: !(Dur t) + , twTree :: !(FingerTree (TimedMeasure t v) (TimedSample t a)) + } + deriving Generic + +deriving instance (Show (Dur t), Show t, Show v, Show a) + => Show (TimedWindow t v a) +deriving instance (NFData (Dur t), NFData t, NFData v, NFData a) + => NFData (TimedWindow t v a) + +instance Foldable (TimedWindow t v) where + foldMap f TimedWindow { twTree } = + foldMap (f . tsValue) twTree + + +-- | The user-supplied measure of the current window contents. +-- +windowMeasure :: FT.Measured v a + => TimedWindow t v a + -> v +windowMeasure = tmV . FT.measure . twTree +{-# INLINE windowMeasure #-} + + +-- | retrieve the sum over the sliding window +-- \(O(1)\) +-- +windowSum :: Num a + => TimedWindow t (Sum a) (SumSample a) -> Maybe a +windowSum w + | size w == 0 = Nothing + | otherwise = Just . getSum . windowMeasure $ w +{-# INLINE windowSum #-} + + +-- | retrieve min/max values over the sliding window +-- \(O(1)\) +-- +windowMinMax :: Ord a + => TimedWindow t (MinMaxV a) (MinMaxSample a) -> Maybe (a, a) +windowMinMax = getMinMaxV . windowMeasure +{-# INLINE windowMinMax #-} + + +-- | retrieve the running mean (via Welford's algorithm) over the +-- sliding window. +-- \(O(1)\) +-- +windowMean :: Fractional a + => TimedWindow t (WelfordMeasure a) (MomentSample a) -> Maybe a +windowMean w + | size w == 0 = Nothing + | otherwise = Just . welfordMean . windowMeasure $ w +{-# INLINE windowMean #-} + + +-- | retrieve the running sample variance (denominator @n - 1@) over +-- the sliding window. +-- \(O(1)\) +-- +windowVariance :: Fractional a + => TimedWindow t (WelfordMeasure a) (MomentSample a) -> Maybe a +windowVariance w + | welfordN m < 2 = Nothing + | otherwise = Just (welfordM2 m / fromIntegral (welfordN m - 1)) + where m = windowMeasure w +{-# INLINE windowVariance #-} + + +-- | retrieve the running sample standard deviation over the sliding +-- window. +-- \(O(1)\) +-- +windowStdDev :: Floating a + => TimedWindow t (WelfordMeasure a) (MomentSample a) -> Maybe a +windowStdDev = fmap sqrt . windowVariance +{-# INLINE windowStdDev #-} + + +-- | The number of elements currently in the window. +-- \(O(1)\) +-- +size :: FT.Measured v a + => TimedWindow t v a + -> Int +size = tmCount . FT.measure . twTree +{-# INLINE size #-} + + +-- | Actual duration covered by the samples in the window. 'Nothing' +-- for an empty window. +-- \(O(1)\) +-- +windowDuration :: (TimeLike t, FT.Measured v a) + => TimedWindow t v a + -> Maybe (Dur t) +windowDuration TimedWindow { twTree } = + do + start <- tmStart $ FT.measure twTree + finish <- finish' + pure $! finish `diffT` start + where + finish' = case FT.viewl twTree of + EmptyL -> error "TimedWindow: empty tree with non-empty measure - internal invariant broken" + TimedSample t _a :< _suffix -> Just t + + +-- | Constructs an empty time window of the given @timedWindowDuration@ duration +-- +empty :: FT.Measured v a + => Dur t + -> TimedWindow t v a +empty twDuration = + TimedWindow { twDuration, twTree = FT.empty } + + +-- | Constructs a window with duration of @timedWindowDuration@ containing a single sample +-- +singleton :: (FT.Measured v b, Coercible a b) + => Dur t + -> (t, a) + -> TimedWindow t v b +singleton twDuration (t, a) = + TimedWindow + { twDuration + , twTree = FT.singleton (TimedSample t (coerce a)) + } + + +-- | Insert a new timestamped sample, then evict any elements +-- that have spilled past the window duration. +-- +-- @a@ must be the unwrapped version of b. +-- \(O(1)\) amortized, \(O(\log w)\) w/c +-- +insert :: (TimeLike t, FT.Measured v b, Coercible a b) + => (t, a) + -> TimedWindow t v b + -> TimedWindow t v b +insert (t, a) win@TimedWindow { twDuration, twTree } = + evictBefore cutoff win { twTree = TimedSample t (coerce a) FT.<| twTree } + where + cutoff = negate twDuration `addT` t +{-# INLINEABLE insert #-} + + +-- | Insert a sequence of timestamped samples into the window, performing +-- a single trim operation at the end. +-- +-- Elements should be provided in __non-decreasing__ timestamp order for +-- correct eviction behaviour. +-- @a@ must be the unwrapped version of b. +-- \(O(\n log w)\), use when n >> w +-- +insertMany :: (TimeLike t, FT.Measured v b, Foldable f, Coercible a b) + => f (t, a) + -> TimedWindow t v b + -> TimedWindow t v b +insertMany as win@TimedWindow { twDuration, twTree } = maybe win (`evictBefore` toWin twTree') cutoff + where + step (ft, finish') (t, a) = (TimedSample t (coerce a) FT.<| ft, finish' <> pure t) + (!twTree', !finish) = foldl' step (twTree, mempty) as + cutoff = do + finish' <- getLast finish + pure $ negate twDuration `addT` finish' + + toWin ft = win { twTree = ft } + + +-- | Build a 'TimedWindow' from a list of timestamped samples, retaining +-- only elements within the given duration of the newest element. +-- +-- Elements should be provided in __non-increasing__ timestamp order +-- for correct behaviour (__note__: this is opposite from 'insertMany' and 'fromFoldable') +-- \(O(\w log w)\) +-- +fromListN :: (TimeLike t, FT.Measured v b, Coercible a b) + => Dur t + -> [(t, a)] + -> TimedWindow t v b +fromListN twDuration as = maybe (empty twDuration) (`evictBefore` win) cutoff + where + step ft (t, a) = ft FT.|> TimedSample t (coerce a) + twTree = foldl' step mempty as + cutoff = do + finish' <- fst <$> listToMaybe as + pure $ negate twDuration `addT` finish' + + win = TimedWindow { twDuration, twTree } + + +-- | Construct a window from a 'Foldable' collection, performing +-- a single trim operation at the end. +-- Elements should be provided in __non-decreasing__ timestamp order for +-- correct eviction behaviour. +-- \(O(\n log n)\), use when n ~= w +-- +fromFoldable :: (TimeLike t, FT.Measured v b, Foldable f, Coercible a b) + => Dur t + -> f (t, a) + -> TimedWindow t v b +fromFoldable twDuration as = maybe (empty twDuration) (`evictBefore` win) cutoff + where + step (ft, finish') (t, a) = (TimedSample t (coerce a) FT.<| ft, finish' <> pure t) + (!twTree, !finish) = foldl' step (mempty, mempty) as + cutoff = do + finish' <- getLast finish + pure $ negate twDuration `addT` finish' + + win = TimedWindow { twDuration, twTree } + + +-- | Trim the window from the oldest end, keeping the longest +-- newest-end prefix whose cumulative user-supplied measure @v@ does +-- __not__ satisfy the predicate. +-- +-- /Precondition:/ the predicate must be __monotone__ along the prefix. +-- See 'takeUntil' for the full caveat. +-- \(O(\log w)\) +-- +trimByMeasure :: FT.Measured v a + => (v -> Bool) + -> TimedWindow t v a + -> TimedWindow t v a +trimByMeasure p = takeUntil (p . tmV) +{-# INLINE trimByMeasure #-} + + +-- | Discard the oldest sample. +-- \(O(1)\) amortized, \(O(\log w)\) w/c +-- +evictOldest :: FT.Measured v a + => TimedWindow t v a + -> TimedWindow t v a +evictOldest win@TimedWindow { twTree } = + case FT.viewr twTree of + EmptyR -> win + prefix :> _ -> win { twTree = prefix } + + +-- | Discard the @n@ oldest samples. +-- \(O(\log w)\) +-- +evictOldestN :: FT.Measured v a + => Int + -> TimedWindow t v a + -> TimedWindow t v a +evictOldestN n win + | n <= 0 = win + | n >= total = win { twTree = FT.empty } + | otherwise = takeUntil (\m -> tmCount m > keep) win + where + total = size win + keep = total - n + + +-- | Evict all elements whose timestamp is older than the given cutoff time. +-- \(O(\log w)\) +-- +evictBefore :: (TimeLike t, FT.Measured v a) + => t + -> TimedWindow t v a + -> TimedWindow t v a +evictBefore cutoff = + takeUntil (maybe False (<= cutoff) . tmStart) + +{-# INLINEABLE evictBefore #-} +{-# SPECIALIZE evictBefore + :: FT.Measured v a + => UTCTime -> TimedWindow UTCTime v a -> TimedWindow UTCTime v a #-} +{-# SPECIALIZE evictBefore + :: FT.Measured v a + => Time -> TimedWindow Time v a -> TimedWindow Time v a #-} + + +-- | Set a new maximum duration for the window, evicting any samples +-- now older than that duration relative to the newest element. +-- \(O(\log w)\) +-- +resize :: (TimeLike t, FT.Measured v a) + => Dur t + -> TimedWindow t v a + -> TimedWindow t v a +resize twDuration win@TimedWindow { twTree } = + case FT.viewl twTree of + EmptyL -> win { twDuration } + TimedSample t _a :< _suffix -> + let cutoff = negate twDuration `addT` t + in evictBefore cutoff win { twDuration } + + +-- | Tests if window is empty +-- \(O(1)\) +-- +isEmpty :: FT.Measured v a => TimedWindow t v a -> Bool +isEmpty = (== 0) . size +{-# INLINE isEmpty #-} + + +-- | Yields the window in order, ie. newest elements at the head +-- \(O(w)\) +-- +toNewestFirst :: Coercible a b => TimedWindow t v a -> [b] +toNewestFirst = coerce . toList +{-# INLINE toNewestFirst #-} + + +-- | Yields the window in reverse, ie. oldest elements at the head +-- +toOldestFirst :: Coercible a b => TimedWindow t v a -> [b] +toOldestFirst = coerce . foldl' (flip (:)) [] + + +-- | Yields the window in order, ie. newest elements at the head, +-- with timestamps. +-- \(O(w)\) +-- +toTimedNewestFirst :: Coercible a b => TimedWindow t v a -> [(t, b)] +toTimedNewestFirst = + foldr (\(TimedSample t a) acc -> (t, coerce a) : acc) [] + . twTree +{-# INLINE toTimedNewestFirst #-} + + +-- | Yields the window in reverse, ie. oldest elements at the head +-- with timestamps +-- \(O(w)\) +-- +toTimedOldestFirst :: Coercible a b => TimedWindow t v a -> [(t, b)] +toTimedOldestFirst = + foldl' (\acc (TimedSample t a) -> (t, coerce a) : acc) [] + . twTree + + +--- INTERNAL --- + +-- | Returns the longest prefix of the window whose +-- accumulated 'TimedMeasure' does __not__ satisfy the predicate. +-- Equivalently, walks the window from newest to oldest, accumulating +-- the measure, and stops at the first point where the predicate flips +-- to 'True' — discarding everything from that point on (the oldest +-- tail). +-- +-- /Precondition:/ the predicate must be __monotone__ along the prefix: +-- once it returns 'True' for some prefix, it must continue to return +-- 'True' for every longer prefix. Calling 'takeUntil' with a +-- non-monotone predicate (for example one phrased over the running +-- variance carried by 'WelfordMeasure') yields an unspecified split +-- point and is almost never what you want. +-- +-- This function lives in the internal module as the primitive used by +-- 'evictBefore' and 'trimByMeasure'. Public callers should prefer +-- 'Data.Window.Timed.trimByMeasure' (which hides 'TimedMeasure' and +-- works on the user-supplied measure @v@) or the dedicated helper +-- 'evictBefore'. +-- \(O(\log w)\) +-- +takeUntil :: FT.Measured v a + => (TimedMeasure t v -> Bool) + -> TimedWindow t v a + -> TimedWindow t v a +takeUntil p win@TimedWindow { twTree } = win { twTree = twTree' } + where + twTree' = FT.takeUntil p twTree + !_ = tmV $ FT.measure twTree' diff --git a/window-stats/lib/Data/Window/TimeLike.hs b/window-stats/lib/Data/Window/TimeLike.hs new file mode 100644 index 0000000000..1ffc9ea61e --- /dev/null +++ b/window-stats/lib/Data/Window/TimeLike.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} + +-- | +-- Module : Data.Window.TimeLike +-- Description : Abstraction over absolute time and its duration. +-- Stability : experimental +-- +-- The time-based window machinery in 'Data.Window.Timed' is +-- parametrised over an absolute time type @t@ via the 'TimeLike' +-- class. Two stock instances are provided: +-- +-- * 'Data.Time.UTCTime' / 'Data.Time.NominalDiffTime' — wall-clock +-- semantics, standard from the @time@ package. +-- +-- * 'Control.Monad.Class.MonadTime.SI.Time' / 'Data.Time.DiffTime' +-- — monotonic semantics from @io-classes@/@si-timers@. Preferred +-- when sliding-window correctness must not be perturbed by NTP +-- adjustments or clock jumps. +-- +-- Users may add their own instance for any time representation that +-- satisfies the laws below. The internal windowing code is marked +-- 'INLINEABLE' and 'SPECIALIZE'd for the two stock instances, so a +-- downstream user wanting dictionary-free code for a custom time +-- type only needs to add a 'SPECIALIZE' pragma on the relevant +-- functions in their own module. +-- +-- = Laws +-- +-- For any @t1, t2 :: t@ and @d :: 'Dur' t@: +-- +-- @ +-- ('diffT' t2 t1) \`'addT'\` t1 == t2 +-- 'diffT' ('addT' d t) t == d +-- @ +-- +module Data.Window.TimeLike (TimeLike (..)) where + +import Control.Monad.Class.MonadTime.SI + +-- | Absolute time type @t@ paired with its associated duration type +-- @'Dur' t@. +-- +-- The 'Dur' type family is __injective__: given the duration GHC can +-- recover the time, so users rarely need explicit type annotations. +-- +class (Ord t, Ord (Dur t), Num (Dur t)) => TimeLike t where + -- | The duration type associated with @t@. + type Dur t = d | d -> t + + -- | @'diffT' t2 t1@ is the duration from @t1@ to @t2@. + diffT :: t -> t -> Dur t + + -- | @'addT' d t@ shifts @t@ forward (or backward, for negative @d@) + -- by @d@. + addT :: Dur t -> t -> t + + +instance TimeLike UTCTime where + type Dur UTCTime = NominalDiffTime + diffT = diffUTCTime + {-# INLINE diffT #-} + addT = addUTCTime + {-# INLINE addT #-} + + +instance TimeLike Time where + type Dur Time = DiffTime + diffT (Time a) (Time b) = a - b + {-# INLINE diffT #-} + addT d (Time t) = Time (d + t) + {-# INLINE addT #-} diff --git a/window-stats/lib/Data/Window/Timed.hs b/window-stats/lib/Data/Window/Timed.hs new file mode 100644 index 0000000000..9db8bdf90c --- /dev/null +++ b/window-stats/lib/Data/Window/Timed.hs @@ -0,0 +1,81 @@ +-- | +-- Module : Data.Window.Timed +-- Description : Time-based sliding window backed by a finger tree. +-- Stability : experimental +-- +-- This module provides a time-based sliding window data structure, +-- 'TimedWindow', which retains elements within a specified duration +-- of the newest element in the window. Elements older than the +-- duration are evicted automatically on insertion. +-- +-- The time representation is abstracted via the 'TimeLike' class. Two +-- stock instances are provided in "Data.Window.TimeLike": +-- +-- * @'TimedWindow' 'Data.Time.UTCTime' v a@ for wall-clock timestamps +-- from the @time@ package. +-- +-- * @'TimedWindow' 'Control.Monad.Class.MonadTime.SI.Time' v a@ for +-- monotonic timestamps from @io-classes@/@si-timers@. +-- +-- The window is backed by a finger tree ('Data.FingerTree.FingerTree'), +-- giving O(1) amortised insertion and O(log w) eviction. The window +-- measure is cached at the root of the finger tree and accessible in +-- O(1) via 'windowMeasure', making it efficient to query rolling +-- statistics. +-- +-- This module is intended to be imported qualified. +-- +-- = Ordering convention +-- +-- The window's underlying finger tree always has the newest element +-- at the left end and the oldest at the right. The construction +-- functions differ in the expected input order — see the per-function +-- haddocks — so refer to those when feeding pre-collected data. +-- +module Data.Window.Timed + ( -- * Types + TimedWindow + -- * Time abstraction + , TimeLike (..) + -- * Construction + , empty + , singleton + -- * From collections + , fromListN + , fromFoldable + -- * Insertion + , insert + , insertMany + -- * Querying + , size + , windowMaxDuration + , isEmpty + , windowDuration + , windowMeasure + -- ** Statistics + , SumSample (..) + , windowSum + , MinMaxV + , MinMaxSample (..) + , windowMinMax + , MomentSample (..) + , WelfordMeasure + , windowMean + , windowVariance + , windowStdDev + -- * Splitting + , evictOldest + , evictOldestN + , evictBefore + , trimByMeasure + , resize + -- * Conversions + , toNewestFirst + , toTimedNewestFirst + , toOldestFirst + , toTimedOldestFirst + ) where + +import Data.Window.Internal.Measures +import Data.Window.Internal.Timed +import Data.Window.TimeLike From c674eb28868e8c76b51a55c5b908b55659f12875 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Wed, 17 Jun 2026 22:27:15 +0200 Subject: [PATCH 03/17] window-stats: approximate-quantile backend via tdigest These modules expose sliding windows backed by an approximate t-digest measure, which permit efficient computations of quantiles in bounded memory. --- .../tdigest/Data/Window/DigestTimeBatched.hs | 64 +++++ .../Data/Window/Internal/DigestTimeBatched.hs | 228 ++++++++++++++++++ 2 files changed, 292 insertions(+) create mode 100644 window-stats/tdigest/Data/Window/DigestTimeBatched.hs create mode 100644 window-stats/tdigest/Data/Window/Internal/DigestTimeBatched.hs diff --git a/window-stats/tdigest/Data/Window/DigestTimeBatched.hs b/window-stats/tdigest/Data/Window/DigestTimeBatched.hs new file mode 100644 index 0000000000..6353be06b6 --- /dev/null +++ b/window-stats/tdigest/Data/Window/DigestTimeBatched.hs @@ -0,0 +1,64 @@ +-- | +-- Module : Data.Window.DigestTimeBatched +-- Description : Approximate quantile statistics over a time-based sliding window. +-- Stability : experimental +-- +-- A time-based sliding window backed by a t-digest, supporting +-- approximate quantile queries over the specified duration. +-- The window is quantized by buckets of some shorter duration, and +-- samples are inserted into the newest bucket's t-digest object. +-- Once the bucket is sealed, it is inserted into the window, and buckets +-- which spill past the end of the window are evicted. This implies that +-- the granularity of statistics is determined by the ratio of bucket duration +-- to the overall window duration. The digest is cached at the +-- root of the underlying finger tree and accessible in \(O(1)\), so +-- multiple quantiles can be queried cheaply over the same window +-- without recomputing. +-- +-- The time representation is abstracted via 'TimeLike' from +-- "Data.Window.TimeLike", so the same combinators work for wall-clock +-- ('UTCTime') and monotonic +-- ('Control.Monad.Class.MonadTime.SI.Time') timestamps. +-- +-- = Approximate quantiles and memory +-- +-- Estimates are approximate; error is bounded by the compression +-- parameter @comp@ (higher @comp@ = more accurate, larger digest). +-- The digest size is \(O(\delta)\) in @comp@, independent of the +-- window's element count — attractive for large or long-running +-- windows where an exact sorted structure would need \(O(w)\) memory. +-- +module Data.Window.DigestTimeBatched + ( -- * Types + TimedDigestWindow + -- * Construction + , empty + -- TODO: From collections + -- , fromListN + -- , fromFoldable + -- * Insertion + , insert + -- TODO: , insertMany + -- * Querying + , sampleCount + , windowDuration + , windowDigest + -- ** Statistics + , windowQuantile + , windowMedian + , windowMean + , windowVariance + , windowStdDev + , windowMinMaxValues + -- * Adjustments + , evictBefore + , reset + -- * re-exports + , TimeLike (..) + , TDigest + ) where + +import Data.TDigest (TDigest) + +import Data.Window.Internal.DigestTimeBatched +import Data.Window.TimeLike diff --git a/window-stats/tdigest/Data/Window/Internal/DigestTimeBatched.hs b/window-stats/tdigest/Data/Window/Internal/DigestTimeBatched.hs new file mode 100644 index 0000000000..7016bb1427 --- /dev/null +++ b/window-stats/tdigest/Data/Window/Internal/DigestTimeBatched.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.Window.Internal.DigestTimeBatched where + +import Control.DeepSeq +import Control.Exception (assert) +import Data.FingerTree (FingerTree, ViewL (..)) +import Data.FingerTree qualified as FT +import Data.TDigest (TDigest) +import Data.TDigest qualified as TD +import Data.TDigest.Internal (Mean) +import GHC.Generics +import GHC.TypeLits + +import Data.Window.TimeLike + + +-- | Finger-tree measure over the sealed buckets. +data BucketMeasure t (comp :: Nat) = BucketMeasure + { bmFinish :: !(Maybe t) + -- ^ Time at insertion of a sealed bucket + , bmCount :: {-# UNPACK #-} !Int + -- ^ Number of samples in the prefix + -- the sliding window is bounded and therefore so is space usage, + -- but tactical forcing will even allow us to not compute the measure + -- for the elements which are evicted from the window, which is + -- fortunate as combining digests, which the finger tree does frequently, + -- is \(O(delta)\). + , bmDigest :: TDigest comp + } + deriving (Show, Generic, NFData) + +-- | A sealed bucket +data SealedBucket t (comp :: Nat) = SealedBucket + { sbFinish :: !t + -- ^ newest sample time ie. when bucket is inserted into the finger tree + , sbCount :: {-# UNPACK #-} !Int + -- ^ Number of samples in the bucket + , sbDigest :: !(TDigest comp) + } + deriving (Show, Generic, NFData) + +instance KnownNat comp => Semigroup (BucketMeasure t comp) where + BucketMeasure _f1 c1 d1 <> BucketMeasure f2 c2 d2 = BucketMeasure f2 (c1 + c2) (d1 <> d2) + +instance KnownNat comp => Monoid (BucketMeasure t comp) where + mempty = BucketMeasure Nothing 0 mempty + +instance KnownNat comp => FT.Measured (BucketMeasure t comp) (SealedBucket t comp) where + {-# INLINE measure #-} + measure (SealedBucket sealed count digest) = BucketMeasure (pure sealed) count digest + +-- | The open (in-progress) bucket. +data OpenBucket t (comp :: Nat) = OpenBucket + { obStart :: !t -- ^ first sample time + , obFinish :: !t -- ^ latest sample time + , obCount :: {-# UNPACK #-} !Int + , obDigest :: !(TDigest comp) + } + deriving (Show, Generic, NFData) + +-- | A time-bucketed sliding window. The finger tree holds sealed buckets, +-- newest at the right; 'tdwBucket' is the bucket currently being filled. +data TimedDigestWindow t (comp :: Nat) = TimedDigestWindow + { tdwDuration :: !(Dur t) -- ^ duration of the whole window + , tdwBucketDuration :: !(Dur t) -- ^ duration of a single bucket + , tdwBucket :: !(Maybe (OpenBucket t comp)) + , tdwTree :: !(FingerTree (BucketMeasure t comp) (SealedBucket t comp)) + } + +deriving instance (Show (Dur t), Show t) => Show (TimedDigestWindow t comp) + + +-- | An empty window with the given bucket width and retention duration (a multiple +-- of bucket width). +empty :: (TimeLike t, KnownNat comp) => Dur t -> Int -> TimedDigestWindow t comp +empty tdwBucketDuration r = + TimedDigestWindow + { tdwDuration = fromIntegral r * tdwBucketDuration + , tdwBucketDuration + , tdwBucket = Nothing + , tdwTree = FT.empty + } + + +-- | Resets the window, keeping only the retention durations +reset :: KnownNat comp => TimedDigestWindow t comp -> TimedDigestWindow t comp +reset tdw = tdw { tdwBucket = Nothing, tdwTree = FT.empty } + + +-- | Returns the number of samples which were inserted into the fingertree +-- and which are still within the retention duration. +sampleCount :: KnownNat comp => TimedDigestWindow t comp -> Int +sampleCount TimedDigestWindow { tdwBucket, tdwTree } = + case tdwBucket of + Nothing -> 0 + Just bucket -> let count = bmCount $ FT.measure tdwTree + in count + obCount bucket + + +-- | Returns the digest of the sliding window, or Nothing if there are no samples +windowDigest :: KnownNat comp => TimedDigestWindow t comp -> Maybe (TDigest comp) +windowDigest TimedDigestWindow { tdwTree, tdwBucket } = + case tdwBucket of + Nothing -> Nothing + Just OpenBucket { obDigest } -> + let treeDigest = bmDigest $ FT.measure tdwTree + in Just $! treeDigest <> obDigest + + +-- | Insert a new timestamped sample, then evict any buckets +-- that have spilled past the window duration. Note that eviction +-- occurs at the granularity of buckets so only when a new bucket +-- is added. +insert :: (TimeLike t, KnownNat comp) + => (t, Double) + -> TimedDigestWindow t comp + -> TimedDigestWindow t comp +insert (t, a) tdw@TimedDigestWindow { tdwBucketDuration, tdwDuration, tdwBucket, tdwTree} = + case fillBucket of + (Nothing, bucket) -> tdw { tdwBucket = Just $! bucket } + (Just sealed, bucket) -> + let sample = SealedBucket (obFinish sealed) (obCount sealed) (obDigest sealed) + tdwTree' = tdwTree FT.|> sample + cutoff = negate tdwDuration `addT` t + -- evictBefore will force the measure once after it's done + in evictBefore cutoff tdw { tdwBucket = Just $! bucket + , tdwTree = tdwTree' } + where + newBucket = OpenBucket + { obStart = t + , obFinish = t + , obCount = 1 + , obDigest = TD.singleton a + } + + fillBucket = case tdwBucket of + Nothing -> (Nothing, newBucket) + Just bucket@OpenBucket { obStart, obFinish, obCount, obDigest } -> + let dt = t `diffT` obStart + in if dt < tdwBucketDuration + then (Nothing, bucket { obFinish = max obFinish t + , obDigest = TD.insert a obDigest + , obCount = succ obCount + }) + else (tdwBucket, newBucket) + + +-- | Drop all buckets whose newest sample timestamp is older than the given value +-- +evictBefore :: (KnownNat comp, TimeLike t) + => t + -> TimedDigestWindow t comp + -> TimedDigestWindow t comp +evictBefore cutoff win = win { tdwTree = tdwTree', tdwBucket = tdwBucket' } + where + tdwBucket' = case tdwBucket win of + Nothing -> Nothing + Just bucket -> if obFinish bucket > cutoff + then tdwBucket win + else assert (FT.null tdwTree') Nothing + + tdwTree' = FT.dropUntil (maybe False (> cutoff) . bmFinish) + (tdwTree win) + -- we will not have to combine t-digests of the buckets + -- which we have dropped from the window + !_ = bmDigest $ FT.measure tdwTree' + +-- | Approximate duration covered by the samples in the window. 'Nothing' +-- for an empty window. The reported value may exceed the actual duration of +-- samples held by up to one bucket period over which actually there aren't +-- any samples held. +-- +windowDuration :: (KnownNat comp, TimeLike t) + => TimedDigestWindow t comp + -> Maybe (Dur t) +windowDuration TimedDigestWindow { tdwBucket, tdwBucketDuration, tdwTree } = + do + start <- start' + finish <- obFinish <$> tdwBucket + pure $! finish `diffT` start + where + start' = case FT.viewl tdwTree of + EmptyL -> obStart <$> tdwBucket + SealedBucket sealed _c _s :< _suffix -> Just $ negate tdwBucketDuration `addT` sealed + + +-- Convenience API -- + +-- | Returns the means of the outermost centroids - appoximations, not the actual min/max samples +windowMinMaxValues :: KnownNat comp => TimedDigestWindow t comp -> Maybe (Mean, Mean) +windowMinMaxValues TimedDigestWindow { tdwTree, tdwBucket } = + case tdwBucket of + Nothing -> Nothing + Just bucket -> + let !bucketDigest = obDigest bucket + !treeDigest = bmDigest $ FT.measure tdwTree + combined = treeDigest <> bucketDigest + in Just (TD.minimumValue combined, TD.maximumValue combined) + + +windowMedian :: KnownNat comp => TimedDigestWindow t comp -> Maybe Double +windowMedian = maybe Nothing TD.median . windowDigest + + +windowQuantile :: KnownNat comp => Double -> TimedDigestWindow t comp -> Maybe Double +windowQuantile q = maybe Nothing (TD.quantile q) . windowDigest + + +windowMean :: KnownNat comp => TimedDigestWindow t comp -> Maybe Double +windowMean = maybe Nothing TD.mean . windowDigest + + +windowVariance :: KnownNat comp => TimedDigestWindow t comp -> Maybe Double +windowVariance = maybe Nothing TD.variance . windowDigest + + +windowStdDev :: KnownNat comp => TimedDigestWindow t comp -> Maybe Double +windowStdDev = maybe Nothing TD.stddev . windowDigest From dc435a4992c9cc264e98c202e6576e3e3a3b5cb7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Thu, 9 Jul 2026 13:00:11 +0200 Subject: [PATCH 04/17] window-stats: Add cache to TimedDigestWindow --- .../Data/Window/Internal/DigestTimeBatched.hs | 60 ++++++++++++------- 1 file changed, 38 insertions(+), 22 deletions(-) diff --git a/window-stats/tdigest/Data/Window/Internal/DigestTimeBatched.hs b/window-stats/tdigest/Data/Window/Internal/DigestTimeBatched.hs index 7016bb1427..c0d55bbd94 100644 --- a/window-stats/tdigest/Data/Window/Internal/DigestTimeBatched.hs +++ b/window-stats/tdigest/Data/Window/Internal/DigestTimeBatched.hs @@ -75,6 +75,12 @@ data TimedDigestWindow t (comp :: Nat) = TimedDigestWindow , tdwBucketDuration :: !(Dur t) -- ^ duration of a single bucket , tdwBucket :: !(Maybe (OpenBucket t comp)) , tdwTree :: !(FingerTree (BucketMeasure t comp) (SealedBucket t comp)) + , tdwCacheDigest :: !(Maybe (TDigest comp)) + -- ^ Cached (treeDigest <> obDigest); 'Nothing' iff 'tdwBucket' is + -- 'Nothing'. The wrapped 'TDigest' is left as a thunk — set on every + -- 'insert'/'evictBefore' so the first 'windowDigest' after a batch + -- of writes materialises it and subsequent reads project the + -- field directly. } deriving instance (Show (Dur t), Show t) => Show (TimedDigestWindow t comp) @@ -89,12 +95,13 @@ empty tdwBucketDuration r = , tdwBucketDuration , tdwBucket = Nothing , tdwTree = FT.empty + , tdwCacheDigest = Nothing } -- | Resets the window, keeping only the retention durations reset :: KnownNat comp => TimedDigestWindow t comp -> TimedDigestWindow t comp -reset tdw = tdw { tdwBucket = Nothing, tdwTree = FT.empty } +reset tdw = tdw { tdwBucket = Nothing, tdwTree = FT.empty, tdwCacheDigest = Nothing } -- | Returns the number of samples which were inserted into the fingertree @@ -107,14 +114,13 @@ sampleCount TimedDigestWindow { tdwBucket, tdwTree } = in count + obCount bucket --- | Returns the digest of the sliding window, or Nothing if there are no samples +-- | Returns the digest of the sliding window, or 'Nothing' if there +-- are no samples. Forces the cached 'tdwCacheDigest' on the first +-- call after a batch of writes. windowDigest :: KnownNat comp => TimedDigestWindow t comp -> Maybe (TDigest comp) -windowDigest TimedDigestWindow { tdwTree, tdwBucket } = - case tdwBucket of - Nothing -> Nothing - Just OpenBucket { obDigest } -> - let treeDigest = bmDigest $ FT.measure tdwTree - in Just $! treeDigest <> obDigest +windowDigest tdw = case tdwCacheDigest tdw of + Nothing -> Nothing + Just !d -> Just d -- | Insert a new timestamped sample, then evict any buckets @@ -127,12 +133,16 @@ insert :: (TimeLike t, KnownNat comp) -> TimedDigestWindow t comp insert (t, a) tdw@TimedDigestWindow { tdwBucketDuration, tdwDuration, tdwBucket, tdwTree} = case fillBucket of - (Nothing, bucket) -> tdw { tdwBucket = Just $! bucket } + (Nothing, bucket) -> + -- Fits: tree is unchanged, only the open bucket grew. Refresh + -- the cache thunk so it closes over the new obDigest. + let cache = Just (bmDigest (FT.measure tdwTree) <> obDigest bucket) + in tdw { tdwBucket = Just $! bucket, tdwCacheDigest = cache } (Just sealed, bucket) -> let sample = SealedBucket (obFinish sealed) (obCount sealed) (obDigest sealed) tdwTree' = tdwTree FT.|> sample cutoff = negate tdwDuration `addT` t - -- evictBefore will force the measure once after it's done + -- evictBefore forces the tree measure and refreshes the cache w/o forcing in evictBefore cutoff tdw { tdwBucket = Just $! bucket , tdwTree = tdwTree' } where @@ -161,7 +171,10 @@ evictBefore :: (KnownNat comp, TimeLike t) => t -> TimedDigestWindow t comp -> TimedDigestWindow t comp -evictBefore cutoff win = win { tdwTree = tdwTree', tdwBucket = tdwBucket' } +evictBefore cutoff win = win { tdwTree = tdwTree' + , tdwBucket = tdwBucket' + , tdwCacheDigest = cache + } where tdwBucket' = case tdwBucket win of Nothing -> Nothing @@ -171,9 +184,16 @@ evictBefore cutoff win = win { tdwTree = tdwTree', tdwBucket = tdwBucket' } tdwTree' = FT.dropUntil (maybe False (> cutoff) . bmFinish) (tdwTree win) - -- we will not have to combine t-digests of the buckets - -- which we have dropped from the window - !_ = bmDigest $ FT.measure tdwTree' + -- Force the post-eviction tree measure. This bounds the tail + -- latency of the next 'windowDigest' by one '<>' with 'obDigest', + -- and drops thunks for evicted subtrees without ever combining + -- them. + !treeDigest = bmDigest $ FT.measure tdwTree' + + -- Lazy cache thunk closing over the post-eviction state. + cache = case tdwBucket' of + Nothing -> Nothing + Just bucket -> Just (treeDigest <> obDigest bucket) -- | Approximate duration covered by the samples in the window. 'Nothing' -- for an empty window. The reported value may exceed the actual duration of @@ -198,14 +218,10 @@ windowDuration TimedDigestWindow { tdwBucket, tdwBucketDuration, tdwTree } = -- | Returns the means of the outermost centroids - appoximations, not the actual min/max samples windowMinMaxValues :: KnownNat comp => TimedDigestWindow t comp -> Maybe (Mean, Mean) -windowMinMaxValues TimedDigestWindow { tdwTree, tdwBucket } = - case tdwBucket of - Nothing -> Nothing - Just bucket -> - let !bucketDigest = obDigest bucket - !treeDigest = bmDigest $ FT.measure tdwTree - combined = treeDigest <> bucketDigest - in Just (TD.minimumValue combined, TD.maximumValue combined) +windowMinMaxValues tdw = + case windowDigest tdw of + Nothing -> Nothing + Just d -> Just (TD.minimumValue d, TD.maximumValue d) windowMedian :: KnownNat comp => TimedDigestWindow t comp -> Maybe Double From 81557f610dfb4b93cc5f6c83e6b12ccfb580267f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Wed, 17 Jun 2026 22:31:58 +0200 Subject: [PATCH 05/17] window-stats: expose integration with the foldl package These expose some combinators which allow for summarising rolling statistics across a long stream in constant memory. --- .../fold/lib/Data/Window/Fold/Count.hs | 206 +++++++++++++++++ .../fold/lib/Data/Window/Fold/Timed.hs | 215 ++++++++++++++++++ 2 files changed, 421 insertions(+) create mode 100644 window-stats/fold/lib/Data/Window/Fold/Count.hs create mode 100644 window-stats/fold/lib/Data/Window/Fold/Timed.hs diff --git a/window-stats/fold/lib/Data/Window/Fold/Count.hs b/window-stats/fold/lib/Data/Window/Fold/Count.hs new file mode 100644 index 0000000000..a168120399 --- /dev/null +++ b/window-stats/fold/lib/Data/Window/Fold/Count.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Data.Window.Fold.Count +-- Description : @foldl@ combinators driving a count-based sliding window. +-- Stability : experimental +-- +-- 'F.Fold' combinators that maintain a sliding count window +-- ('Data.Window.Count.Window') over the input stream and surface its +-- rolling measure to a downstream fold. +-- +-- All combinators are polymorphic in the measure @v@ and the sample +-- type @a@ behind a 'FT.Measured' constraint, so they work unchanged +-- with any of the built-in sample wrappers +-- ('Data.Window.Count.SumSample', 'Data.Window.Count.MomentSample', +-- 'Data.Window.Count.MinMaxSample') and with user-defined measures. +-- +module Data.Window.Fold.Count + ( windowScan + , windowFoldWith + , windowFoldRolling + , windowFoldRollingFull + , windowFoldRollingM + , windowFoldRolling2 + , windowFoldRolling2Full + , windowFinal + , windowMeasureFinal + ) where + +import Control.Foldl qualified as F +import Data.FingerTree qualified as FT +import Data.Sequence qualified as S + +import Data.Window.Internal.Count qualified as W + +-- | Compute the window measure at each step as the window moves across the +-- input stream, collecting all intermediate measures into a sequence. +-- The sequence has the same length as the input stream, with the i-th element +-- being the measure of the window ending at the i-th input element. +-- +windowScan :: forall v a. FT.Measured v a + => Int + -> F.Fold a (S.Seq v) +windowScan n = F.Fold step initial extract + where + step :: (W.Window v a, S.Seq v) -> a -> (W.Window v a, S.Seq v) + step (w, ms) x = + let !w' = W.insert x w + !ms' = ms S.|> W.windowMeasure w' + in (w', ms') + initial = (W.empty n, S.empty) + extract = snd + +-- | Apply an extraction function to the window measure at each step, +-- producing a rolling sequence of statistics as the window moves across +-- the input stream. A specialisation of 'windowScan' for when you want +-- to post-process the measure at each step. +-- +windowFoldWith :: FT.Measured v a + => Int + -> (v -> b) + -> F.Fold a (S.Seq b) +windowFoldWith n f = fmap f <$> windowScan n + + +-- | Stream the rolling sequence of window measures into an inner +-- 'F.Fold'. Unlike 'windowScan' / 'windowFoldWith', the intermediate +-- measures are __not__ retained — each measure is fed to the inner +-- fold as soon as it is produced. This keeps the memory footprint +-- bounded by the inner fold's own state, independent of the input +-- length. +-- +-- Use this when you want to summarise the rolling statistics +-- (e.g. average them, take their max, fold them into a histogram) +-- rather than materialise every intermediate value. +-- +windowFoldRolling :: forall v a r. FT.Measured v a + => Int + -> F.Fold v r + -> F.Fold a r +windowFoldRolling n = F.purely $ \innerStep innerInit innerExtract -> + let step (w, s) x = + let !w' = W.insert x w + !s' = innerStep s (W.windowMeasure w') + in (w', s') + in F.Fold step (W.empty n :: W.Window v a, innerInit) (innerExtract . snd) + + +-- | Like 'windowFoldRolling' but only feeds a measure to the inner +-- fold once the window has reached its configured size. The first +-- @n - 1@ measures, which would otherwise be over a partially filled +-- window, are dropped. +-- +-- This is usually what you want for statistical measures (rolling +-- mean, variance, quantiles) where partial-window readings are +-- misleading. +-- +windowFoldRollingFull :: forall v a r. FT.Measured v a + => Int + -> F.Fold v r + -> F.Fold a r +windowFoldRollingFull n = F.purely $ \innerStep innerInit innerExtract -> + let step (w, s) x = + let !w' = W.insert x w + !s' = if W.isFull w' + then innerStep s (W.windowMeasure w') + else s + in (w', s') + in F.Fold step (W.empty n :: W.Window v a, innerInit) (innerExtract . snd) + + +-- | Monadic counterpart of 'windowFoldRolling', for combining a sliding +-- window with a 'F.FoldM' (e.g. one that emits each measure to an +-- effectful sink). +-- +windowFoldRollingM :: forall m v a r. (Monad m, FT.Measured v a) + => Int + -> F.FoldM m v r + -> F.FoldM m a r +windowFoldRollingM n = F.impurely $ \innerStep innerInit innerExtract -> + let step (w, s) x = do + let !w' = W.insert x w + !s' <- innerStep s (W.windowMeasure w') + return (w', s') + init' = do + s <- innerInit + return (W.empty n :: W.Window v a, s) + extract' (_, s) = innerExtract s + in F.FoldM step init' extract' + + +-- | Maintain two windows of different sizes over the same input +-- stream, feeding the pair of measures @(short, long)@ to the inner +-- fold at each step. Convenient for cross-window comparisons such as +-- short- versus long-period moving averages. +-- +-- A pair is emitted on every input, starting from one-sample windows. +-- The first @max short long - 1@ pairs therefore include at least one +-- partially-filled window; only from reading @max short long@ onward +-- are both windows full. If those partial readings are unwanted, use +-- 'windowFoldRolling2Full', which suppresses emission until both +-- windows are full. +-- +windowFoldRolling2 :: forall v a r. FT.Measured v a + => Int -- ^ short window size + -> Int -- ^ long window size + -> F.Fold (v, v) r + -> F.Fold a r +windowFoldRolling2 short long = F.purely $ \innerStep innerInit innerExtract -> + let step (ws, wl, s) x = + let !ws' = W.insert x ws + !wl' = W.insert x wl + !s' = innerStep s (W.windowMeasure ws', W.windowMeasure wl') + in (ws', wl', s') + init' = ( W.empty short :: W.Window v a + , W.empty long :: W.Window v a + , innerInit + ) + in F.Fold step init' (\(_, _, s) -> innerExtract s) + + +-- | Like 'windowFoldRolling2' but only emits a pair of measures once +-- __both__ windows are full. Use this when partial-window readings +-- would distort the comparison (typically for any statistical +-- measure). +-- +windowFoldRolling2Full :: forall v a r. FT.Measured v a + => Int -- ^ short window size + -> Int -- ^ long window size + -> F.Fold (v, v) r + -> F.Fold a r +windowFoldRolling2Full short long = F.purely $ \innerStep innerInit innerExtract -> + let step (ws, wl, s) x = + let !ws' = W.insert x ws + !wl' = W.insert x wl + !s' = if W.isFull ws' && W.isFull wl' + then innerStep s (W.windowMeasure ws', W.windowMeasure wl') + else s + in (ws', wl', s') + init' = ( W.empty short :: W.Window v a + , W.empty long :: W.Window v a + , innerInit + ) + in F.Fold step init' (\(_, _, s) -> innerExtract s) + + +-- | Return the window itself at the end of the input stream. Useful +-- when you want to query multiple statistics over the trailing window +-- after consuming a stream. +-- +windowFinal :: forall v a. FT.Measured v a + => Int + -> F.Fold a (W.Window v a) +windowFinal n = F.Fold (\w x -> W.insert x w) (W.empty n) id + + +-- | Return only the measure of the window at the end of the input +-- stream. The most common shorthand when you want a single rolling +-- statistic over the final @n@ samples. +-- +windowMeasureFinal :: forall v a. FT.Measured v a + => Int + -> F.Fold a v +windowMeasureFinal n = W.windowMeasure <$> windowFinal n diff --git a/window-stats/fold/lib/Data/Window/Fold/Timed.hs b/window-stats/fold/lib/Data/Window/Fold/Timed.hs new file mode 100644 index 0000000000..ecc6180470 --- /dev/null +++ b/window-stats/fold/lib/Data/Window/Fold/Timed.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Data.Window.Fold.Timed +-- Description : @foldl@ combinators driving a time-based sliding window. +-- Stability : experimental +-- +-- 'F.Fold' combinators that maintain a sliding time-based window +-- ('Data.Window.Timed.TimedWindow') over the input stream and surface +-- its rolling measure to a downstream fold. +-- +-- All combinators are polymorphic in the time type @t@ (behind a +-- 'TimeLike' constraint), the measure @v@, and the sample type @a@ +-- (behind a 'FT.Measured' constraint), so they work unchanged with +-- the wall-clock ('UTCTime') and monotonic +-- ('Control.Monad.Class.MonadTime.SI.Time') stock instances, with any +-- user-defined 'TimeLike' instance, and with any of the built-in +-- sample wrappers ('Data.Window.Timed.SumSample', +-- 'Data.Window.Timed.MomentSample', 'Data.Window.Timed.MinMaxSample'). +-- +module Data.Window.Fold.Timed + ( windowScan + , windowFoldWith + , windowFoldRolling + , windowFoldRollingFull + , windowFoldRollingM + , windowFoldRolling2 + , windowFoldRolling2Full + , windowFinal + , windowMeasureFinal + ) where + +import Control.Foldl qualified as F +import Data.FingerTree qualified as FT +import Data.Sequence qualified as S + +import Data.Window.Internal.Timed qualified as W +import Data.Window.TimeLike + + +-- | Compute the window measure at each step as the window moves across the +-- input stream, collecting all intermediate measures into a sequence. +-- The sequence has the same length as the input stream, with the i-th element +-- being the measure of the window ending at the i-th input element. +-- +windowScan :: forall t v a. (TimeLike t, FT.Measured v a) + => Dur t + -> F.Fold (t, a) (S.Seq v) +windowScan timedWindowDuration = F.Fold step initial extract + where + step :: (W.TimedWindow t v a, S.Seq v) -> (t, a) -> (W.TimedWindow t v a, S.Seq v) + step (w, ms) (t, a) = + let !w' = W.insert (t, a) w + !ms' = ms S.|> W.windowMeasure w' + in (w', ms') + initial = (W.empty timedWindowDuration, S.empty) + extract = snd + +-- | Apply an extraction function to the window measure at each step, +-- producing a rolling sequence of statistics as the window moves across +-- the input stream. A specialisation of 'windowScan' for when you want +-- to post-process the measure at each step. +-- +windowFoldWith :: (TimeLike t, FT.Measured v a) + => Dur t + -> (v -> b) + -> F.Fold (t, a) (S.Seq b) +windowFoldWith timedWindowDuration f = fmap f <$> windowScan timedWindowDuration + + +-- | Stream the rolling sequence of window measures into an inner +-- 'F.Fold'. Unlike 'windowScan' / 'windowFoldWith', the intermediate +-- measures are __not__ retained — each measure is fed to the inner +-- fold as soon as it is produced. This keeps the memory footprint +-- bounded by the inner fold's own state, independent of the input +-- length. +-- +-- Use this when you want to summarise the rolling statistics +-- (e.g. average them, take their max, fold them into a histogram) +-- rather than materialise every intermediate value. +-- +windowFoldRolling :: forall t v a r. (TimeLike t, FT.Measured v a) + => Dur t + -> F.Fold v r + -> F.Fold (t, a) r +windowFoldRolling timedWindowDuration = F.purely $ \innerStep innerInit innerExtract -> + let step (!w, !s) (t, a) = + let !w' = W.insert (t, a) w + !s' = innerStep s (W.windowMeasure w') + in (w', s') + in F.Fold step (W.empty timedWindowDuration :: W.TimedWindow t v a, innerInit) (innerExtract . snd) + + +-- | Like 'windowFoldRolling' but only feeds a measure to the inner +-- fold once the timestamps span at least the configured duration. +-- Measures over a window that has not yet been "filled" by the +-- duration are dropped. +-- +-- This is usually what you want for statistical measures (rolling +-- mean, variance, quantiles) where partial-window readings are +-- misleading. +-- +windowFoldRollingFull :: forall t v a r. (TimeLike t, FT.Measured v a) + => Dur t + -> F.Fold v r + -> F.Fold (t, a) r +windowFoldRollingFull timedWindowDuration = F.purely $ \innerStep innerInit innerExtract -> + let step (!w, !s) (t, a) = + let !w' = W.insert (t, a) w + !s' = if maybe False (>= timedWindowDuration) (W.windowDuration w') + then innerStep s (W.windowMeasure w') + else s + in (w', s') + in F.Fold step (W.empty timedWindowDuration :: W.TimedWindow t v a, innerInit) (innerExtract . snd) + + +-- | Monadic counterpart of 'windowFoldRolling', for combining a sliding +-- window with a 'F.FoldM' (e.g. one that emits each measure to an +-- effectful sink). +-- +windowFoldRollingM :: forall m t v a r. (Monad m, TimeLike t, FT.Measured v a) + => Dur t + -> F.FoldM m v r + -> F.FoldM m (t, a) r +windowFoldRollingM timedWindowDuration = F.impurely $ \innerStep innerInit innerExtract -> + let step (w, s) (t, a) = do + let !w' = W.insert (t, a) w + !s' <- innerStep s (W.windowMeasure w') + return (w', s') + init' = do + s <- innerInit + return (W.empty timedWindowDuration :: W.TimedWindow t v a, s) + extract' (_, s) = innerExtract s + in F.FoldM step init' extract' + + +-- | Maintain two windows of different durations over the same input +-- stream, feeding the pair of measures @(short, long)@ to the inner +-- fold at each step. Convenient for cross-window comparisons such as +-- short- versus long-period moving averages. +-- +-- A pair is emitted on every input, starting from a one-sample +-- window (zero duration). Until the input timestamps span at least +-- @max short long@, every emitted pair includes at least one +-- not-yet-spanned window. If those partial readings are unwanted, use +-- 'windowFoldRolling2Full', which suppresses emission until both +-- windows have been spanned by their configured duration. +-- +windowFoldRolling2 :: forall t v a r. (TimeLike t, FT.Measured v a) + => Dur t -- ^ short window duration + -> Dur t -- ^ long window duration + -> F.Fold (v, v) r + -> F.Fold (t, a) r +windowFoldRolling2 short long = F.purely $ \innerStep innerInit innerExtract -> + let step (ws, wl, s) (t, a) = + let !ws' = W.insert (t, a) ws + !wl' = W.insert (t, a) wl + !s' = innerStep s (W.windowMeasure ws', W.windowMeasure wl') + in (ws', wl', s') + init' = ( W.empty short :: W.TimedWindow t v a + , W.empty long :: W.TimedWindow t v a + , innerInit + ) + in F.Fold step init' (\(_, _, s) -> innerExtract s) + + +-- | Like 'windowFoldRolling2' but only emits a pair of measures once +-- __both__ windows have been spanned by their configured duration +-- (i.e. @windowDuration w >= configured duration@ for each window). +-- Use this when partial-window readings would distort the comparison +-- (typically for any statistical measure). +-- +windowFoldRolling2Full :: forall t v a r. (TimeLike t, FT.Measured v a) + => Dur t -- ^ short window duration + -> Dur t -- ^ long window duration + -> F.Fold (v, v) r + -> F.Fold (t, a) r +windowFoldRolling2Full short long = F.purely $ \innerStep innerInit innerExtract -> + let step (ws, wl, s) (t, a) = + let !ws' = W.insert (t, a) ws + !wl' = W.insert (t, a) wl + !s' = if maybe False (>= short) (W.windowDuration ws') + && maybe False (>= long) (W.windowDuration wl') + then innerStep s (W.windowMeasure ws', W.windowMeasure wl') + else s + in (ws', wl', s') + init' = ( W.empty short :: W.TimedWindow t v a + , W.empty long :: W.TimedWindow t v a + , innerInit + ) + in F.Fold step init' (\(_, _, s) -> innerExtract s) + + +-- | Return the window itself at the end of the input stream. Useful +-- when you want to query multiple statistics over the trailing window +-- after consuming a stream. +-- +windowFinal :: forall t v a. (TimeLike t, FT.Measured v a) + => Dur t + -> F.Fold (t, a) (W.TimedWindow t v a) +windowFinal timedWindowDuration = + F.Fold (\w ta -> W.insert ta w) (W.empty timedWindowDuration) id + + +-- | Return only the measure of the window at the end of the input +-- stream. The most common shorthand when you want a single rolling +-- statistic over the trailing duration. +-- +windowMeasureFinal :: forall t v a. (TimeLike t, FT.Measured v a) + => Dur t + -> F.Fold (t, a) v +windowMeasureFinal d = W.windowMeasure <$> windowFinal d From 5d6fec37d7c468238cd4cd99278cf2bb2e269132 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Wed, 17 Jun 2026 22:34:41 +0200 Subject: [PATCH 06/17] window-stats: add property tests --- window-stats/test/Main.hs | 338 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 338 insertions(+) create mode 100644 window-stats/test/Main.hs diff --git a/window-stats/test/Main.hs b/window-stats/test/Main.hs new file mode 100644 index 0000000000..1bb36d0060 --- /dev/null +++ b/window-stats/test/Main.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} + +module Main (main) where + +#if !MIN_VERSION_base(4,20,0) +import Data.Foldable +#endif +import Data.List (sort, sortBy, tails) +import Data.Maybe (isNothing) +import Data.Monoid (Sum (..)) +import Data.Ord (comparing) +import Data.Time (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime, + fromGregorian) +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck (testProperty) + +import Data.Window.Count qualified as C +import Data.Window.DigestTimeBatched qualified as DTB +import Data.Window.Timed qualified as T + + +-- Use Int rather than Double for arithmetic invariants — the +-- finger-tree-cached sum and the naive list sum can disagree by +-- floating-point ULPs even though both are "correct". +type CountW = C.Window (Sum Int) (C.SumSample Int) +type TimedW = T.TimedWindow UTCTime (Sum Int) (T.SumSample Int) + + +newtype Cap = Cap Int deriving Show +instance Arbitrary Cap where + arbitrary = Cap <$> choose (1, 32) + +newtype Dur = Dur NominalDiffTime deriving Show +instance Arbitrary Dur where + arbitrary = Dur . fromInteger <$> choose (1, 60) + + +-- Count --------------------------------------------------------------------- + +-- insertMany agrees with repeated insert (orientation invariant). +prop_insertMany_eq_foldl :: Cap -> [Int] -> Property +prop_insertMany_eq_foldl (Cap n) xs = + let w0 = C.empty n :: CountW + w1 = foldl' (flip C.insert) w0 xs + w2 = C.insertMany xs w0 + in (C.toNewestFirst w1 :: [Int]) === C.toNewestFirst w2 + +-- size after inserting xs into a fresh window is min n (length xs). +prop_size_bounded :: Cap -> [Int] -> Property +prop_size_bounded (Cap n) xs = + let w = C.insertMany xs (C.empty n :: CountW) + in C.size w === min n (length xs) + +-- windowSum matches the live elements' sum. +prop_sum_consistent :: Cap -> [Int] -> Property +prop_sum_consistent (Cap n) xs = + let w = C.insertMany xs (C.empty n :: CountW) + live = C.toNewestFirst w :: [Int] + expected = if null live then Nothing else Just (sum live) + in C.windowSum w === expected + +-- fromFoldable (oldest-first input) gives the same window as the +-- equivalent sequence of inserts. +prop_fromFoldable_orientation :: Cap -> [Int] -> Property +prop_fromFoldable_orientation (Cap n) xs = + let w1 = C.fromFoldable n xs :: CountW + w2 = foldl' (flip C.insert) (C.empty n :: CountW) xs + in (C.toNewestFirst w1 :: [Int]) === C.toNewestFirst w2 + +-- fromListN (newest-first input) is the reverse-input mirror of insert. +prop_fromListN_orientation :: Cap -> [Int] -> Property +prop_fromListN_orientation (Cap n) xs = + let w1 = C.fromListN n (reverse xs) :: CountW + w2 = foldl' (flip C.insert) (C.empty n :: CountW) xs + in (C.toNewestFirst w1 :: [Int]) === C.toNewestFirst w2 + +-- evictOldestN reduces the size as expected. +prop_evictOldestN :: Cap -> [Int] -> NonNegative Int -> Property +prop_evictOldestN (Cap n) xs (NonNegative k) = + let w = C.insertMany xs (C.empty n :: CountW) + w' = C.evictOldestN k w + in C.size w' === max 0 (C.size w - k) + + +-- Timed --------------------------------------------------------------------- + +-- evictBefore retains only samples with timestamp >= cutoff. Input is +-- sorted to honour the non-decreasing-timestamp invariant of insertMany. +prop_evictBefore :: Dur -> [(NonNegative Int, Int)] -> Int -> Property +prop_evictBefore (Dur d) tvs offset = + let base = UTCTime (fromGregorian 2024 1 1) 0 + sorted = sortBy (comparing fst) tvs + pairs = [ (fromIntegral s `addUTCTime` base, v) + | (NonNegative s, v) <- sorted ] + w = T.insertMany pairs (T.empty d :: TimedW) + cutoff = fromIntegral offset `addUTCTime` base + w' = T.evictBefore cutoff w + kept = T.toTimedNewestFirst w' :: [(UTCTime, Int)] + in conjoin [ counterexample (show t) (t >= cutoff) | (t, _) <- kept ] + +-- windowDuration on a freshly-built window from a non-decreasing +-- timestamp list equals (newest - oldest), within the configured cap. +prop_windowDuration :: Dur -> [NonNegative Int] -> Property +prop_windowDuration (Dur d) ts0 = + let sorted = sort (map getNonNegative ts0) + pairs = [ (mkT (fromIntegral s), 0 :: Int) | s <- sorted ] + w = T.insertMany pairs (T.empty d :: TimedW) + live = T.toTimedNewestFirst w :: [(UTCTime, Int)] + in case live of + [] -> T.windowDuration w === Nothing + x:xs -> + let newest = fst x + oldest = fst $ foldl' (\_ x' -> x') x xs + dur = newest `diffUTC` oldest + in T.windowDuration w === Just dur + where + diffUTC a b = realToFrac (utcTimeDiff a b) :: NominalDiffTime + utcTimeDiff a b = + let toS (UTCTime _ d') = realToFrac d' :: Double + in toS a - toS b + + +-- DigestTimeBatched --------------------------------------------------------- + +type Comp = 100 +type DigestW = DTB.TimedDigestWindow UTCTime Comp + +digestBase :: UTCTime +digestBase = UTCTime (fromGregorian 2024 1 1) 0 + +mkT :: Double -> UTCTime +mkT s = realToFrac s `addUTCTime` digestBase + +-- Sorted timestamps uniformly within [0, spanSec], sample values in +-- [-100, 100]. +genTimedSamplesIn + :: Double -- ^ maximum offset in seconds + -> Gen [(UTCTime, Double)] +genTimedSamplesIn spanSec = do + n <- choose (10, 200) + offsets <- sort <$> vectorOf n (choose (0, spanSec)) + values <- vectorOf n (choose (-100, 100)) + return + [ (mkT t, v) | (t, v) <- zip offsets values ] + +-- Same, but all sample values in [0, 100] for the accuracy tests. +genPositiveSamplesIn + :: Double + -> Gen [(UTCTime, Double)] +genPositiveSamplesIn spanSec = do + n <- choose (100, 500) + offsets <- sort <$> vectorOf n (choose (0, spanSec)) + values <- vectorOf n (choose (0, 100)) + return + [ (mkT t, v) | (t, v) <- zip offsets values ] + +buildDigestW :: NominalDiffTime -> Int -> [(UTCTime, Double)] -> DigestW +buildDigestW bucketDur retention = + foldl' (flip DTB.insert) (DTB.empty bucketDur retention) + + +-- Bug #1 (direct regression): a hand-picked sequence that spans two +-- bucket periods with multiple samples in the second period. Under +-- correct behaviour the open bucket accumulates the last three samples; +-- windowDuration reports 7. Under the bug, obFinish stays at 1 and +-- windowDuration reports 1. +-- +unit_dtb_openBucketResetsOnSeal :: Property +unit_dtb_openBucketResetsOnSeal = once $ + let samples = [ (mkT 0, 0), (mkT 1, 1) -- bucket [0, 2) + , (mkT 2, 2), (mkT 3, 3) -- bucket [2, 4) + , (mkT 5, 5) -- evicts first bucket + ] + w = buildDigestW 2 2 samples + in DTB.sampleCount w === 3 + .&&. DTB.windowDuration w === Just (4 :: NominalDiffTime) + + +-- Empty window semantics. +unit_dtb_emptySemantics :: Property +unit_dtb_emptySemantics = once $ + let w = DTB.empty (1 :: NominalDiffTime) 60 :: DigestW + in DTB.sampleCount w === 0 + .&&. counterexample "windowDigest" (isNothing (DTB.windowDigest w)) + .&&. DTB.windowDuration w === Nothing + .&&. DTB.windowMedian w === Nothing + .&&. DTB.windowQuantile 0.99 w === Nothing + + +-- reset returns an empty window. +prop_dtb_resetEmpties :: Property +prop_dtb_resetEmpties = + forAll (genTimedSamplesIn 100.0) $ \samples -> + let w = buildDigestW 1 60 samples + w' = DTB.reset w + in DTB.sampleCount w' === 0 + .&&. counterexample "windowDigest after reset" + (isNothing (DTB.windowDigest w')) + + +-- sampleCount counts every inserted sample when nothing has been +-- evicted (all samples fit within the window duration). +prop_dtb_sampleCountConservation :: Property +prop_dtb_sampleCountConservation = + forAll (genTimedSamplesIn 3.0) $ \samples -> + -- bucket_dur = 1s, retention = 5 → window = 5s ; all samples ≤ 3s + let w = buildDigestW 1.0 5 samples + in DTB.sampleCount w === length samples + + +-- A quantile query lies within [min, max] of the input samples that +-- are still in the window. +prop_dtb_quantileInRange :: Property +prop_dtb_quantileInRange = + forAll (genTimedSamplesIn 3.0) $ \samples -> + not (null samples) ==> + let w = buildDigestW 1.0 5 samples + values = map snd samples + lo = minimum values + hi = maximum values + in case DTB.windowMedian w of + Nothing -> counterexample "no median for non-empty window" False + Just m -> counterexample + (show m ++ " outside [" ++ show lo ++ ", " ++ show hi ++ "]") + (m >= lo && m <= hi) + + +-- The batched digest's median is within a tolerance of the exact +-- sample median, for reasonably-sized uniform inputs that all fit in +-- the window. +prop_dtb_quantileAccuracy :: Property +prop_dtb_quantileAccuracy = + forAll (genPositiveSamplesIn 30.0) $ \samples -> + let w = buildDigestW 1.0 60 samples + values = map snd samples + n = length values + sorted = sort values + exactMedian = if odd n + then sorted !! (n `div` 2) + else (sorted !! (n `div` 2 - 1) + sorted !! (n `div` 2)) / 2 + in case DTB.windowMedian w of + Nothing -> counterexample "no median for non-empty window" False + Just m -> counterexample + ("batched " ++ show m ++ " vs exact " ++ show exactMedian) + (abs (m - exactMedian) <= 5.0) -- generous + + +-- Eviction correctness: after inserting samples spread over +-- [0, 6 × windowDur], the sample count should be at most the count of +-- samples whose timestamps fall within the last windowDur (plus two +-- buckets' worth of slack). +prop_dtb_evictionRetainsOnlyRecent :: Property +prop_dtb_evictionRetainsOnlyRecent = + forAll gen $ \samples -> + not (null samples) ==> + let bucketDur = 1.0 :: NominalDiffTime + retention = 5 + windowDur = fromIntegral retention * bucketDur + w = buildDigestW bucketDur retention samples + lastT = maximum (map fst samples) + -- Two bucket durations of slack: eviction only runs on seal + -- events, so the last seal may have fired up to bucketDur before + -- lastT, and a retained bucket's oldest sample can be up to + -- bucketDur older than its sbFinish. + cutoff = negate (windowDur + 2 * bucketDur) `addUTCTime` lastT + liveCount = length (filter (\(t, _) -> t >= cutoff) samples) + in counterexample (show (DTB.sampleCount w, liveCount)) + (DTB.sampleCount w <= liveCount) + where + gen = do + n <- choose (50, 400) + offsets <- sort <$> vectorOf n (choose (0, 30)) -- 30s span, window 5s + values <- vectorOf n (choose (-100, 100)) + return [ (mkT t, v) | (t, v) <- zip offsets values ] + + +-- windowDuration reports a value bounded below by the actual sample +-- duration (newest - oldest) and above by that duration plus one +-- bucket period, per its haddock. The upper slack is the range of +-- possible obStart positions for the leftmost sealed bucket (whose +-- obStart is not tracked; the implementation approximates it as +-- sbFinish - bucketDur). Samples span less than the window so no +-- eviction narrows the "actual" duration. +prop_dtb_windowDurationApproximate :: Property +prop_dtb_windowDurationApproximate = + forAll (genTimedSamplesIn 30.0) $ \samples -> + not (null samples) ==> + let bucketDur = 1.0 :: NominalDiffTime + retention = 60 -- window = 60s > spanSec = 30s + w = buildDigestW bucketDur retention samples + times = map fst samples + actual = maximum times `diffUTCTime` minimum times + in case DTB.windowDuration w of + Nothing -> counterexample "unexpected Nothing for non-empty window" False + Just d -> + counterexample + (show d ++ " outside [" ++ show actual ++ + ", " ++ show (actual + bucketDur) ++ "]") + (d >= actual .&&. d <= actual + bucketDur) +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = + testGroup "window-stats" + [ testGroup "Count" + [ testProperty "insertMany ≡ foldl' insert" prop_insertMany_eq_foldl + , testProperty "size = min cap (length xs)" prop_size_bounded + , testProperty "windowSum = sum live" prop_sum_consistent + , testProperty "fromFoldable orientation" prop_fromFoldable_orientation + , testProperty "fromListN orientation" prop_fromListN_orientation + , testProperty "evictOldestN reduces size" prop_evictOldestN + ] + , testGroup "Timed" + [ testProperty "evictBefore keeps t >= cutoff" prop_evictBefore + , testProperty "windowDuration = newest - oldest" prop_windowDuration + ] + , testGroup "DigestTimeBatched" + [ testProperty "open bucket resets on seal (bug #1 regression)" + unit_dtb_openBucketResetsOnSeal + , testProperty "empty window has trivial statistics" + unit_dtb_emptySemantics + , testProperty "reset empties the window" + prop_dtb_resetEmpties + , testProperty "sampleCount conserves inserts (no eviction)" + prop_dtb_sampleCountConservation + , testProperty "median lies in [min, max] of samples" + prop_dtb_quantileInRange + , testProperty "median accuracy vs exact" + prop_dtb_quantileAccuracy + , testProperty "eviction retains only recent samples" + prop_dtb_evictionRetainsOnlyRecent + , testProperty "windowDuration is bounded [actual, actual + bucketDur]" + prop_dtb_windowDurationApproximate + ] + ] From b29bdd32d5efbb3e01e2cb9c8edf9c7a37348004 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Wed, 8 Jul 2026 13:18:01 +0200 Subject: [PATCH 07/17] window-stats: add benchmarks --- window-stats/bench/Main.hs | 147 +++++++++++++++++++++++++++++++++++++ window-stats/test/Main.hs | 67 +++++++++++++++++ 2 files changed, 214 insertions(+) create mode 100644 window-stats/bench/Main.hs diff --git a/window-stats/bench/Main.hs b/window-stats/bench/Main.hs new file mode 100644 index 0000000000..54e4fdc4e7 --- /dev/null +++ b/window-stats/bench/Main.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} + +-- | Cascade-eviction benchmark for "Data.Window.DigestTimeBatched", +-- used to compare lazy vs. strict 'bmDigest' in the finger-tree +-- measure. +-- +-- Each case streams a 'cascadeSamples' input into a window with 1-second +-- buckets and 60-bucket retention, then queries the median (forcing the +-- top-level measure through 'windowDigest'). Timings are monotonic from +-- 'GHC.Clock.getMonotonicTime'; allocation, GC count and residency +-- come from 'GHC.Stats' when the RTS is built with @-T@. +-- +-- The cases alternate dense stretches with wide idle gaps. The gap +-- puts each next sample's eviction cutoff past many sealed buckets in +-- a single 'FT.dropUntil'; a lazy 'bmDigest' can discard the cached +-- subtree measures for those buckets without forcing their digest +-- combines, while a strict variant has already paid for them at +-- insertion time. +-- +-- Measured lazy vs. strict (bmDigest strict + no manual force in +-- evictBefore), @-O2 +RTS -T@, wall / alloc: +-- +-- * 10x (6000 @ 0.01, gap 60s) — 60k samples — 1.36x / 1.30x +-- * 20x (6000 @ 0.01, gap 60s) — 120k samples — 1.25x / 1.30x +-- * 50x (3000 @ 0.01, gap 60s) — 150k samples — 1.23x / 1.22x +-- * 100x (1000 @ 0.01, gap 60s) — 100k samples — 1.21x / 1.31x +-- +module Main (main) where + +import Control.Exception (evaluate) +#if !MIN_VERSION_base(4,20,0) +import Data.Foldable +#endif +import Data.Time (UTCTime (..), addUTCTime, fromGregorian) +import Data.Word (Word64) +import GHC.Clock (getMonotonicTime) +import GHC.Stats (RTSStats (..), getRTSStats, getRTSStatsEnabled) +import System.Mem (performMajorGC) +import Text.Printf (printf) + +import Data.Window.DigestTimeBatched qualified as DTB + + +type Comp = 100 +type DigestW = DTB.TimedDigestWindow UTCTime Comp + +base :: UTCTime +base = UTCTime (fromGregorian 2024 1 1) 0 + +mkT :: Double -> UTCTime +mkT s = realToFrac s `addUTCTime` base + +-- | Alternating dense/gap stream. +-- +-- Each cycle emits @nDense@ samples spaced by @denseStep@ seconds +-- (duration @(nDense - 1) * denseStep@), then a silent @gapDur@ before +-- the next cycle. The first sample of the next cycle triggers a seal +-- AND — if @gapDur@ is a significant fraction of the retention window — +-- moves the eviction cutoff past many buckets at once, causing a +-- cascade drop that lazy 'bmDigest' can avoid combining. +cascadeSamples + :: Int -- ^ number of cycles + -> Int -- ^ samples per dense stretch + -> Double -- ^ time step within a dense stretch (s) + -> Double -- ^ gap between stretches (s) + -> [(UTCTime, Double)] +cascadeSamples cycles nDense denseStep gapDur = + [ (mkT (fromIntegral k * cycleDur + fromIntegral i * denseStep) + , fromIntegral (k * nDense + i) + ) + | k <- [0 .. cycles - 1] + , i <- [0 .. nDense - 1] + ] + where + stretchDur = fromIntegral (nDense - 1) * denseStep + cycleDur = stretchDur + gapDur + +-- Statistics captured around a measured action. All GHC.Stats counters +-- are Word64; keep them so on all architectures. +data Snapshot = Snapshot + { snapAllocated :: !Word64 + , snapMaxLive :: !Word64 + , snapGC :: !Word64 + } + +zeroSnap :: Snapshot +zeroSnap = Snapshot 0 0 0 + +takeSnap :: IO Snapshot +takeSnap = do + ok <- getRTSStatsEnabled + if ok + then do + s <- getRTSStats + pure Snapshot + { snapAllocated = allocated_bytes s + , snapMaxLive = max_live_bytes s + , snapGC = fromIntegral (gcs s) -- gcs :: Word32 + } + else pure zeroSnap + +benchCase :: String -> IO () -> IO () +benchCase label action = do + performMajorGC + s0 <- takeSnap + t0 <- getMonotonicTime + action + t1 <- getMonotonicTime + s1 <- takeSnap + let dt = t1 - t0 + alloc = fromIntegral (snapAllocated s1 - snapAllocated s0) / (1024 * 1024 :: Double) + gcs' = snapGC s1 - snapGC s0 + maxL = fromIntegral (snapMaxLive s1) / (1024 * 1024 :: Double) + printf "%-46s %8.4f s %8.2f MB alloc %6d GCs %6.2f MB max_live\n" + label dt alloc gcs' maxL + +main :: IO () +main = do + putStrLn "window-stats: DigestTimeBatched cascade-eviction benchmark" + putStrLn "(compile with -O2 and pass +RTS -T for allocation/GC stats)" + putStrLn "" + printf "%-46s %10s %19s %9s %14s\n" + "case" "wall" "alloc" "gcs" "max_live" + + -- Cases use bucketDur = 1.0 s, retention = 60 buckets. + let cascade cycles nDense denseStep gapDur = + benchCase + (printf "cascade: %d× (%d @ %.3fs dense, then %.1fs gap)" + cycles nDense denseStep gapDur) + (do + let !samples = cascadeSamples cycles nDense denseStep gapDur + !w0 = DTB.empty 1.0 60 :: DigestW + !w = foldl' (flip DTB.insert) w0 samples + _ <- evaluate (DTB.windowMedian w) + pure ()) + + -- Full-window cascade: each cycle fills the window then drops it. + cascade 10 6000 0.01 60.0 -- 60k samples, 10 cascades of 60 buckets + cascade 20 6000 0.01 60.0 -- 120k samples, 20 cascades of 60 buckets + + -- Half-window cascade: less accumulation, more cascade events. + cascade 50 3000 0.01 60.0 -- 150k samples, 50 cascades of ~30 buckets + + -- Shallow cascade: small drops per cascade, many events. + cascade 100 1000 0.01 60.0 -- 100k samples, 100 cascades of ~10 buckets diff --git a/window-stats/test/Main.hs b/window-stats/test/Main.hs index 1bb36d0060..790b1b58a5 100644 --- a/window-stats/test/Main.hs +++ b/window-stats/test/Main.hs @@ -161,6 +161,28 @@ buildDigestW bucketDur retention = foldl' (flip DTB.insert) (DTB.empty bucketDur retention) +-- | Alternating dense/gap stream. Each cycle emits @nDense@ samples +-- spaced by @denseStep@ seconds, then a silent @gapDur@ before the +-- next cycle. Same generator as the benchmark uses; kept in sync by +-- hand. +cascadeSamples + :: Int -- ^ number of cycles + -> Int -- ^ samples per dense stretch + -> Double -- ^ time step within a dense stretch (s) + -> Double -- ^ gap between stretches (s) + -> [(UTCTime, Double)] +cascadeSamples cycles nDense denseStep gapDur = + [ (mkT (fromIntegral k * cycleDur + fromIntegral i * denseStep) + , fromIntegral (k * nDense + i) + ) + | k <- [0 .. cycles - 1] + , i <- [0 .. nDense - 1] + ] + where + stretchDur = fromIntegral (nDense - 1) * denseStep + cycleDur = stretchDur + gapDur + + -- Bug #1 (direct regression): a hand-picked sequence that spans two -- bucket periods with multiple samples in the second period. Under -- correct behaviour the open bucket accumulates the last three samples; @@ -299,6 +321,47 @@ prop_dtb_windowDurationApproximate = (show d ++ " outside [" ++ show actual ++ ", " ++ show (actual + bucketDur) ++ "]") (d >= actual .&&. d <= actual + bucketDur) + + +-- The cascade generator produces at least one bucket-sized window with +-- many samples, i.e. dense stretches actually exist. +unit_cascadeGeneratorHasDenseStretches :: Property +unit_cascadeGeneratorHasDenseStretches = once $ + let bucketDur = 1.0 :: NominalDiffTime + nDense = 500 + samples = cascadeSamples 4 nDense 0.01 10.0 + times = map fst samples + limit t0 = bucketDur `addUTCTime` t0 + perBucket = + [ length (takeWhile (< limit t0) suffix) + | suffix@(t0:_) <- tails times + ] + isDense = not . null $ dropWhile (< 90) perBucket + in counterexample ("no dense buckets") $ + isDense -- ~100 expected with denseStep = 0.01s + + +-- The cascade generator drives multi-bucket evictions: some insertion +-- causes 'sampleCount' to drop by more than one bucket's worth of +-- samples in a single step. +unit_cascadeGeneratorTriggersMultiBucketEviction :: Property +unit_cascadeGeneratorTriggersMultiBucketEviction = once $ + let bucketDur = 1.0 :: NominalDiffTime + retention = 10 -- window = 10s, gap = 10s -> cascade + nDense = 500 -- 5s of dense samples, ~100/bucket + samples = cascadeSamples 4 nDense 0.01 10.0 + w0 = DTB.empty bucketDur retention :: DigestW + ws = scanl (flip DTB.insert) w0 samples + counts = map DTB.sampleCount ws + deltas = zipWith (-) (drop 1 counts) counts + minDelta = minimum deltas + in counterexample ("smallest sampleCount delta: " ++ show minDelta) $ + -- A single insert should evict several full buckets at once. + -- With ~100 samples/bucket and window = 10s, a 10s gap after a + -- 5s dense stretch drops all ~5 buckets in one dropUntil call. + minDelta <= -200 + + main :: IO () main = defaultMain tests @@ -334,5 +397,9 @@ tests = prop_dtb_evictionRetainsOnlyRecent , testProperty "windowDuration is bounded [actual, actual + bucketDur]" prop_dtb_windowDurationApproximate + , testProperty "cascade generator has dense stretches" + unit_cascadeGeneratorHasDenseStretches + , testProperty "cascade generator triggers multi-bucket eviction" + unit_cascadeGeneratorTriggersMultiBucketEviction ] ] From a45580f3ac958cca5f9b02c9b0abd56abfc27aa9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Wed, 8 Jul 2026 13:20:30 +0200 Subject: [PATCH 08/17] window-stats: meta data --- cabal.project | 1 + window-stats/CHANGELOG.md | 9 ++ window-stats/LICENSE | 202 ++++++++++++++++++++++++ window-stats/NOTICE | 14 ++ window-stats/README.md | 245 +++++++++++++++++++++++++++++ window-stats/changelog.d/scriv.ini | 15 ++ window-stats/window-stats.cabal | 134 ++++++++++++++++ 7 files changed, 620 insertions(+) create mode 100644 window-stats/CHANGELOG.md create mode 100644 window-stats/LICENSE create mode 100644 window-stats/NOTICE create mode 100644 window-stats/README.md create mode 100644 window-stats/changelog.d/scriv.ini create mode 100644 window-stats/window-stats.cabal diff --git a/cabal.project b/cabal.project index 32e5cc6667..5a0b4167d6 100644 --- a/cabal.project +++ b/cabal.project @@ -30,6 +30,7 @@ packages: ./monoidal-synchronisation ./cardano-diffusion ./ntp-client ./acts-generic + ./window-stats tests: True benchmarks: True diff --git a/window-stats/CHANGELOG.md b/window-stats/CHANGELOG.md new file mode 100644 index 0000000000..d3fecf5c6b --- /dev/null +++ b/window-stats/CHANGELOG.md @@ -0,0 +1,9 @@ +# window-stats changelog + + + + + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/window-stats/LICENSE b/window-stats/LICENSE new file mode 100644 index 0000000000..d645695673 --- /dev/null +++ b/window-stats/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/window-stats/NOTICE b/window-stats/NOTICE new file mode 100644 index 0000000000..025f8f91dc --- /dev/null +++ b/window-stats/NOTICE @@ -0,0 +1,14 @@ +Copyright 2019-2023 Input Output Global Inc (IOG), 2023-2026 Intersect + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + diff --git a/window-stats/README.md b/window-stats/README.md new file mode 100644 index 0000000000..83b324365f --- /dev/null +++ b/window-stats/README.md @@ -0,0 +1,245 @@ +# window-stats + +Efficient sliding-window statistics for Haskell, backed by a finger +tree, with a cached user-supplied measure that updates incrementally +as the window slides. + +## Scope + +The package provides two variants of sliding window: + +- **Count-based** - keeps the most recent _N_ inserted samples. +- **Time-based** - keeps samples within a configured duration of the + newest sample's timestamp. + +Both are generic in the cached measure: a finger-tree node stores the +combination of an element count (or timestamp bounds) and a +user-supplied monoid `v`. Looking the measure up is `O(1)` regardless +of window size. + +Prebuilt sample wrappers and their measures are included for the +common rolling statistics: + +| Sample wrapper | Measure | Statistic | +|-----------------|------------------|----------------------------------------| +| `SumSample` | `Sum` | running sum | +| `MinMaxSample` | `MinMaxV` | running min / max | +| `MomentSample` | `WelfordMeasure` | running mean / sample variance / stddev (Welford) | +| `DigestSample` | `TDigest comp` | approximate quantiles (with-tdigest) | + +Time-based windows abstract over the timestamp type via the +`TimeLike` class. Two stock instances are shipped: + +- `UTCTime` / `NominalDiffTime` (wall-clock, from `time`) +- `Time` / `DiffTime` (monotonic, from `io-classes:si-timers`) + +Monotonic is preferred when sliding-window correctness must not be +perturbed by NTP corrections or wall-clock jumps; wall-clock fits +data that already carries `UTCTime` timestamps. + +## Sublibraries + +The package is split so that downstream consumers only pay for the +dependencies they need. + +``` +window-stats -- core: Window, TimedWindow, prebuilt measures +window-stats:with-tdigest -- approximate-quantile backend via tdigest +window-stats:with-foldl -- Control.Foldl combinators that drive a window +``` + +Sublibraries compose at the user's call site: a project depending on +both `with-tdigest` and `with-foldl` automatically gets foldl-driven +t-digest rolling quantiles. + +## Complexity + +Per-operation costs, for a window of size _w_: + +| operation | amortised | worst-case | +|------------------------------------|-----------|------------| +| `insert` | `O(1)` | `O(log w)` | +| `insert`'s built-in eviction | `O(1)` | `O(log w)` | +| `evictOldest` | `O(1)` | `O(log w)` | +| `evictOldestN` | `O(log w)`| `O(log w)` | +| `trimByMeasure` | `O(log w)`| `O(log w)` | +| `evictBefore` (Timed) | `O(log w)`| `O(log w)` | +| `resize` (shrink) | `O(log w)`| `O(log w)` | +| `resize` (grow / no-op) | `O(1)` | `O(1)` | +| `windowMeasure` and other queries | `O(1)` | `O(1)` | +| `fromListN` / `fromFoldable` | `O(n)` | `O(n log w)` | + +t-digest-backed insertion is the one exception: each insert triggers +up to `O(log w)` TDigest `<>` merges along the finger-tree spine, and +each merge is `O(δ)` in the compression parameter - so an effective +`O(δ log w)` per insert. + +Space is `O(w)` for the window itself plus whatever the user's +measure adds (typically `O(1)` for `Sum`/`MinMaxV`/`WelfordMeasure`; +`O(δ)` for `TDigest comp`, independent of `w`). + +## When to reach for this package + +- You need rolling statistics over a continuously moving window. +- You want both count- and time-based windowing in one API. +- You want approximate quantiles in bounded memory (the t-digest + backend gives `O(δ)` regardless of window size). +- You don't want to commit to a particular streaming library - the + core types are pure values and you compose them however suits your + pipeline; `Control.Foldl` integration is optional. +- You want the cached running statistic - mean, variance, sum, a + digest - as a value, on demand, in `O(1)`. + +## Use-case examples + +- **Network monitoring**. Rolling latency / throughput / drop-rate + windows per peer, with cheap `O(1)` reads at each tick. +- **Service-level analytics**. Rolling p50/p95/p99 of request times + over the last _N_ minutes via the t-digest backend. +- **Budget enforcement**. Variable-cost windows - keep the most + recent samples whose cumulative weight (a `Sum`) stays below a + threshold - via `trimByMeasure`. +- **Cross-window comparison**. Short- vs long-period moving averages + for trend / crossover detection, via the dual-window combinators in + `Data.Window.Fold.Count`. + +## Relation to similar packages + +The cleanest split is between packages that compete at the **windowing** +layer (where `window-stats` sits) and those that compete or compose at +the **measure** layer (the `v` in `Window v a`). Packages in the +second group plug in as alternative measures rather than substituting +for the window itself. + +### `streamly-statistics` + +Provides exact rolling statistics over a streamly stream: +- Exact quantiles via a sorted structure, at `O(w)` memory. +- Tied to streamly's streaming model and types. + +`window-stats` is complementary rather than a replacement: it trades +exactness for `O(δ)` memory on quantiles via t-digest, is independent +of any streaming library, and provides a `Window` value you can hold, +query, and pass around - useful when sliding statistics are part of +some larger data structure rather than a one-shot pipeline result. + +Use `streamly-statistics` when you need exact quantiles and you're +already on streamly; use `window-stats` when you can tolerate +approximate quantiles, want fixed memory, want time-based as well as +count-based windowing, or aren't already in a streamly context. + +### `streaming`'s `slidingWindow` + +`Streaming.Prelude.slidingWindow :: Int -> Stream (Of a) m r -> Stream (Of (Seq a)) m r` +yields each window position as a `Seq a`. It does no measure caching: +to compute a statistic at each step you'd traverse the `Seq` from +scratch. + +`window-stats` carries the running measure inside the window itself +and updates it incrementally on insertion / eviction. For a stream of +length _n_ with windows of size _w_, computing a rolling sum: + +- `streaming` + `slidingWindow`: `O(n · w)` work total (sum each window). +- `window-stats`: `O(n)` work total - each insert updates the cached + measure in `O(1)` amortised; the read is `O(1)`. + +Pick `streaming`'s `slidingWindow` if you genuinely need the window +contents at each step and the windows are small. Pick `window-stats` +if you want an incrementally-maintained statistic and the window +might be large. + +### `conduit`'s `slidingVector` / `slidingWindow` + +Same shape as `streaming`'s `slidingWindow` - yields each window +position as a `Vector a` / `Seq a` over the conduit pipeline, with no +measure caching. Same complexity trade-off, same advice: reach for it +when you actually need the window contents at each step, not just a +rolling statistic. + +### `monoid-statistics` + +Complementary, not competing. Provides numerically careful statistical +monoids (`Mean`, `Variance`, `Min`, `Max`, `KBNSum` Kahan-Babuška +summation, etc.). Any of them can be plugged in as the `v` parameter +of `Window v a` to get rolling versions of those statistics. Our +prebuilt `WelfordMeasure` covers the most common case; reach for +`monoid-statistics` when you need its specific numerical guarantees +or one of its less common stats. + +### `histogram-fill` + +Also complementary. Its `Histogram bin val` is a `Monoid` (bin-wise +addition), so a user can define a `Measured (Histogram bin val) sample` +instance and use `Window (Histogram bin val) sample` directly. The +window then carries a **rolling histogram** as its cached measure, +available in `O(1)` via `windowMeasure`. Cost per insert scales with +the bin count - much like the t-digest backend scales with δ - but +the result is exact rather than approximate. + +### `tdigest` + +We sit on top of it for the `with-tdigest` sublibrary's approximate +quantiles. If you only need a one-shot quantile over a static dataset +(no sliding-window aspect), use `tdigest` directly. Reach for our +`with-tdigest` when you specifically want approximate quantiles that +*roll* with a moving window in bounded memory. + +### `Control.Foldl`-based folds + +The `with-foldl` sublibrary integrates with the `foldl` package via +combinators such as `windowFoldRolling`, which feed each step's +window measure into an arbitrary downstream `Fold`. Memory is bounded +by the inner fold's own state, so summarising rolling statistics +across a long stream stays constant-memory. + +## A small example + +```haskell +import Data.Monoid (Sum) +import Data.Window.Count + +-- A window of the last 100 sample sums: +let w0 = empty 100 :: Window (Sum Double) (SumSample Double) + w1 = insert 1.5 w0 + w2 = insert 2.5 w1 +in (windowSum w2, size w2) +-- => (Just 4.0, 2) +``` + +t-digest quantiles: + +```haskell +import Data.Window.DigestCount +import Data.TDigest qualified as TD + +let w = fromListN 1000 prices :: DigestWindow 100 + p50 = TD.quantile 0.5 (windowMeasure w) + p99 = TD.quantile 0.99 (windowMeasure w) +in (p50, p99) +``` + +Time-based, with monotonic timestamps: + +```haskell +import Control.Monad.Class.MonadTime.SI (Time, getMonotonicTime) +import Data.Window.Timed + +-- 60-second sliding window of running mean +type LatencyWin = TimedWindow Time (WelfordMeasure Double) (MomentSample Double) + +step :: Double -> LatencyWin -> IO LatencyWin +step latency w = do + now <- getMonotonicTime + return (insert (now, latency) w) +``` + +## Building and testing + +```bash +cabal build all +cabal test window-stats +``` + +## License + +Apache-2.0. See [LICENSE](LICENSE). diff --git a/window-stats/changelog.d/scriv.ini b/window-stats/changelog.d/scriv.ini new file mode 100644 index 0000000000..0d51d54748 --- /dev/null +++ b/window-stats/changelog.d/scriv.ini @@ -0,0 +1,15 @@ +[scriv] +format = md +insert_marker = Changelog entries +md_header_level = 2 +version = literal: window-stats.cabal: version +categories = Breaking, Non-Breaking, Patch +start_marker = scriv-insert-here +end_marker = scriv-end-here +fragment_directory = changelog.d +ghrel_template = {{body}} +main_branches = main +new_fragment_template = file: new_fragment.${config:format}.j2 +output_file = CHANGELOG.${config:format} +skip_fragments = README.* +entry_title_template = {%% if version %%}{{ version }} -- {%% endif %%}{{ date.strftime('%%Y-%%m-%%d') }} diff --git a/window-stats/window-stats.cabal b/window-stats/window-stats.cabal new file mode 100644 index 0000000000..90df2ac9be --- /dev/null +++ b/window-stats/window-stats.cabal @@ -0,0 +1,134 @@ +cabal-version: 3.4 +name: window-stats +version: 0.1.0.0 +synopsis: Efficient sliding window statistics with finger trees and t-digest +license: Apache-2.0 +license-files: + LICENSE + NOTICE + +copyright: Intersect +author: Marcin Wójtowicz +maintainer: marcin.wojtowicz@iohk.io +category: Data +build-type: Simple +extra-doc-files: CHANGELOG.md + +common ghc-options + default-language: Haskell2010 + default-extensions: ImportQualifiedPost + ghc-options: + -Wall + -Wno-unticked-promoted-constructors + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wredundant-constraints + -Wunused-packages + + -- In ghc-9.14 the `pattern` namespace specifier is deprecated. + if impl(ghc >=9.14) + ghc-options: + -Wno-pattern-namespace-specifier + + -- GHC-9.14 warns on constraints that it considers redundant + -- but are necessary for earlier compilers. + if impl(ghc >=9.14) + ghc-options: + -Wno-redundant-constraints + +library with-tdigest + import: ghc-options + visibility: public + exposed-modules: + -- TODO implement: + -- Data.Window.Internal.DigestCountBatched, + Data.Window.DigestTimeBatched + Data.Window.Internal.DigestTimeBatched + + build-depends: + base, + deepseq, + fingertree, + tdigest, + window-stats, + + hs-source-dirs: + tdigest + + default-extensions: + ImportQualifiedPost + + default-language: Haskell2010 + +library + import: ghc-options + exposed-modules: + Data.Window.Count + Data.Window.Internal.Count + Data.Window.Internal.Measures + Data.Window.Internal.Timed + Data.Window.TimeLike + Data.Window.Timed + + build-depends: + base >=4.14 && <4.23, + deepseq, + fingertree, + io-classes:si-timers ^>=1.8, + time, + + hs-source-dirs: + lib + +library with-foldl + import: ghc-options + visibility: public + exposed-modules: + Data.Window.Fold.Count + Data.Window.Fold.Timed + + build-depends: + base, + containers, + fingertree, + foldl, + window-stats, + + hs-source-dirs: + fold/lib + +test-suite ws-test + import: ghc-options + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + ghc-options: + -rtsopts + -fno-ignore-asserts + + build-depends: + QuickCheck, + base, + tasty, + tasty-quickcheck, + time, + window-stats, + window-stats:with-tdigest, + +benchmark ws-bench + import: ghc-options + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Main.hs + ghc-options: + -O2 + -rtsopts + -with-rtsopts=-T + + build-depends: + base, + time, + window-stats:with-tdigest, From 95b619bd45984e7d321c7a467deaf2790e9cd812 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Thu, 16 Jul 2026 14:25:59 +0200 Subject: [PATCH 09/17] mux: two-field SDU-header RTT scheme Introduces new wire format in the Mux codec and some surface types. Replace the single Word32 mhTimestamp with two Word16-sized fields mhSendCookie and mhEchoCookie. New `PeerRTT` type, threaded into `ExpandedInitiatorContext` and `ResponderContext` to expose eventually at application level. todo: tracing, deltaq, integration, tests/benchmarks rtt --- .../lib/Cardano/Network/NodeToNode.hs | 4 +- network-mux/src/Network/Mux.hs | 20 +- .../Network/Mux/Bearer/AttenuatedChannel.hs | 6 +- network-mux/src/Network/Mux/Bearer/Pipe.hs | 6 +- network-mux/src/Network/Mux/Bearer/Queues.hs | 6 +- network-mux/src/Network/Mux/Bearer/Socket.hs | 12 +- network-mux/src/Network/Mux/Codec.hs | 21 +- network-mux/src/Network/Mux/RTT.hs | 230 ++++++++++++++++++ network-mux/src/Network/Mux/Time.hs | 16 -- network-mux/src/Network/Mux/Types.hs | 82 +++++-- .../Ouroboros/Network/ConnectionHandler.hs | 4 +- .../lib/Ouroboros/Network/Context.hs | 15 +- .../lib/Ouroboros/Network/InboundGovernor.hs | 7 +- .../Network/InboundGovernor/State.hs | 4 +- .../framework/lib/Ouroboros/Network/Mux.hs | 14 +- .../lib/Ouroboros/Network/Diffusion/Types.hs | 2 +- .../Network/PeerSelection/PeerStateActions.hs | 6 +- 17 files changed, 362 insertions(+), 93 deletions(-) create mode 100644 network-mux/src/Network/Mux/RTT.hs diff --git a/cardano-diffusion/lib/Cardano/Network/NodeToNode.hs b/cardano-diffusion/lib/Cardano/Network/NodeToNode.hs index ec3a1f45ba..3c0ffd6387 100644 --- a/cardano-diffusion/lib/Cardano/Network/NodeToNode.hs +++ b/cardano-diffusion/lib/Cardano/Network/NodeToNode.hs @@ -152,9 +152,9 @@ data NodeToNodeProtocols appType initiatorCtx responderCtx bytes m a b = NodeToN } type NodeToNodeProtocolsWithExpandedCtx appType ntnAddr bytes m a b = - NodeToNodeProtocols appType (ExpandedInitiatorContext ntnAddr PeerTrustable m) (ResponderContext ntnAddr) bytes m a b + NodeToNodeProtocols appType (ExpandedInitiatorContext ntnAddr PeerTrustable m) (ResponderContext ntnAddr m) bytes m a b type NodeToNodeProtocolsWithMinimalCtx appType ntnAddr bytes m a b = - NodeToNodeProtocols appType (MinimalInitiatorContext ntnAddr) (ResponderContext ntnAddr) bytes m a b + NodeToNodeProtocols appType (MinimalInitiatorContext ntnAddr) (ResponderContext ntnAddr m) bytes m a b data MiniProtocolParameters = MiniProtocolParameters { diff --git a/network-mux/src/Network/Mux.hs b/network-mux/src/Network/Mux.hs index 80e78fb9e2..99a18d3e03 100644 --- a/network-mux/src/Network/Mux.hs +++ b/network-mux/src/Network/Mux.hs @@ -59,6 +59,10 @@ module Network.Mux , WithBearer (..) , TracersWithBearer , tracersWithBearer + -- * Peer RTT + , RTT.PeerRTT (..) + , RTT.noPeerRTT + , peerRTT ) where import Data.ByteString.Builder (lazyByteString, toLazyByteString) @@ -85,6 +89,8 @@ import Network.Mux.Bearer import Network.Mux.Channel import Network.Mux.Egress as Egress import Network.Mux.Ingress as Ingress +import Network.Mux.RTT (RTTState) +import Network.Mux.RTT qualified as RTT import Network.Mux.Timeout import Network.Mux.Trace import Network.Mux.Types @@ -101,11 +107,17 @@ data Mux (mode :: Mode) m = muxMiniProtocols :: !(Map (MiniProtocolNum, MiniProtocolDir) (MiniProtocolState mode m)), muxControlCmdQueue :: !(StrictTQueue m (ControlCmd mode m)), - muxStatus :: StrictTVar m Status, - muxTracers :: Tracers m + muxStatus :: !(StrictTVar m Status), + muxTracers :: !(Tracers m), + muxRTTState :: !(RTTState m) } +-- | Reader handle for the per-peer RTT distribution tracked by this mux. +peerRTT :: MonadSTM m => Mux mode m -> RTT.PeerRTT m +peerRTT Mux { muxRTTState } = RTT.peerRTT muxRTTState + + -- | Get information about all statically registered mini-protocols. -- miniProtocolStateMap :: MonadSTM m @@ -140,6 +152,7 @@ new muxTracers ptcls = do muxMiniProtocols <- mkMiniProtocolStateMap ptcls muxControlCmdQueue <- atomically newTQueue muxStatus <- newTVarIO Ready + muxRTTState <- RTT.newRTTState rttSeed return Mux { muxMiniProtocols, muxControlCmdQueue, @@ -240,7 +253,8 @@ run Mux { muxMiniProtocols, muxTracers = tracers@TracersI { tracer_, bearerTracer_ - } + }, + muxRTTState } bearer@Bearer{name} = do diff --git a/network-mux/src/Network/Mux/Bearer/AttenuatedChannel.hs b/network-mux/src/Network/Mux/Bearer/AttenuatedChannel.hs index d407fddf2c..4f0a4f9511 100644 --- a/network-mux/src/Network/Mux/Bearer/AttenuatedChannel.hs +++ b/network-mux/src/Network/Mux/Bearer/AttenuatedChannel.hs @@ -304,10 +304,8 @@ attenuationChannelAsBearer sduSize sduTimeout chan = writeMux :: Tracer m BearerTrace -> TimeoutFn m -> SDU -> m Time writeMux tracer _ sdu = do ts <- getMonotonicTime - let ts32 = timestampMicrosecondsLow32Bits ts - sdu' = setTimestamp sdu (RemoteClockModel ts32) - buf = encodeSDU sdu' - traceWith tracer $ TraceSendStart (msHeader sdu') + let buf = encodeSDU sdu + traceWith tracer $ TraceSendStart (msHeader sdu) acWrite chan buf traceWith tracer TraceSendEnd diff --git a/network-mux/src/Network/Mux/Bearer/Pipe.hs b/network-mux/src/Network/Mux/Bearer/Pipe.hs index 92d111a183..13d3bee64a 100644 --- a/network-mux/src/Network/Mux/Bearer/Pipe.hs +++ b/network-mux/src/Network/Mux/Bearer/Pipe.hs @@ -111,10 +111,8 @@ pipeAsBearer sduSize channel = writePipe :: Tracer IO Mx.BearerTrace -> Mx.TimeoutFn IO -> Mx.SDU -> IO Time writePipe tracer _ sdu = do ts <- getMonotonicTime - let ts32 = Mx.timestampMicrosecondsLow32Bits ts - sdu' = Mx.setTimestamp sdu (Mx.RemoteClockModel ts32) - buf = Mx.encodeSDU sdu' - traceWith tracer $ Mx.TraceSendStart (Mx.msHeader sdu') + let buf = Mx.encodeSDU sdu + traceWith tracer $ Mx.TraceSendStart (Mx.msHeader sdu) writeHandle channel buf `catch` Mx.handleIOException "writeHandle errored" traceWith tracer Mx.TraceSendEnd diff --git a/network-mux/src/Network/Mux/Bearer/Queues.hs b/network-mux/src/Network/Mux/Bearer/Queues.hs index b80916bc3a..dca804f16b 100644 --- a/network-mux/src/Network/Mux/Bearer/Queues.hs +++ b/network-mux/src/Network/Mux/Bearer/Queues.hs @@ -64,10 +64,8 @@ queueChannelAsBearer sduSize QueueChannel { writeQueue, readQueue } = do writeMux :: Tracer m Mx.BearerTrace -> Mx.TimeoutFn m -> Mx.SDU -> m Time writeMux tracer _ sdu = do ts <- getMonotonicTime - let ts32 = Mx.timestampMicrosecondsLow32Bits ts - sdu' = Mx.setTimestamp sdu (Mx.RemoteClockModel ts32) - buf = Mx.encodeSDU sdu' - traceWith tracer $ Mx.TraceSendStart (Mx.msHeader sdu') + let buf = Mx.encodeSDU sdu + traceWith tracer $ Mx.TraceSendStart (Mx.msHeader sdu) atomically $ writeTBQueue writeQueue buf traceWith tracer Mx.TraceSendEnd return ts diff --git a/network-mux/src/Network/Mux/Bearer/Socket.hs b/network-mux/src/Network/Mux/Bearer/Socket.hs index b33cc8bd7f..2ec1dcb88e 100644 --- a/network-mux/src/Network/Mux/Bearer/Socket.hs +++ b/network-mux/src/Network/Mux/Bearer/Socket.hs @@ -182,10 +182,8 @@ socketAsBearer sduSize batchSize readBuffer_m sduTimeout egressInterval sd = writeSocket :: Tracer IO BearerTrace -> Mx.TimeoutFn IO -> Mx.SDU -> IO Time writeSocket tracer timeout sdu = do ts <- getMonotonicTime - let ts32 = Mx.timestampMicrosecondsLow32Bits ts - sdu' = Mx.setTimestamp sdu (Mx.RemoteClockModel ts32) - buf = Mx.encodeSDU sdu' - traceWith tracer $ Mx.TraceSendStart (Mx.msHeader sdu') + let buf = Mx.encodeSDU sdu + traceWith tracer $ Mx.TraceSendStart (Mx.msHeader sdu) r <- timeout sduTimeout $ #if defined(mingw32_HOST_OS) Win32.Async.sendAll sd buf @@ -217,10 +215,8 @@ socketAsBearer sduSize batchSize readBuffer_m sduTimeout egressInterval sd = return ts #else writeSocketMany tracer timeout sdus = do - ts <- getMonotonicTime - let ts32 = Mx.timestampMicrosecondsLow32Bits ts - buf = map (Mx.encodeSDU . - (\sdu -> Mx.setTimestamp sdu (Mx.RemoteClockModel ts32))) sdus + ts <- getMonotonicTime + let buf = map Mx.encodeSDU sdus r <- timeout (fromIntegral (length sdus) * sduTimeout) $ Socket.sendMany sd (concatMap BL.toChunks buf) `catch` Mx.handleIOException "sendAll errored" diff --git a/network-mux/src/Network/Mux/Codec.hs b/network-mux/src/Network/Mux/Codec.hs index 7e5e0c4164..829467a312 100644 --- a/network-mux/src/Network/Mux/Codec.hs +++ b/network-mux/src/Network/Mux/Codec.hs @@ -18,14 +18,18 @@ import Network.Mux.Types -- > 0 1 2 3 -- > 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 -- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ --- > | transmission time | +-- > | send cookie | echo cookie | -- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ -- > |d| mini-protocol number | length | -- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ -- -- All fields are in big endian byte order. -- --- * transmission time: time when the SDU was sent +-- * send cookie: an opaque per-SDU 16-bit identifier drawn from a +-- PRNG by the local muxer at SDU construction. +-- * echo cookie: the freshest 'send cookie' the local muxer observed +-- from its peer; the peer uses this on receipt to look up the local +-- send time and compute an RTT sample. -- * @d@: mini-protocol direction (`MiniProtocolDir`): -- -- * 1 - initiator direction @@ -40,7 +44,8 @@ encodeSDU sdu = BL.append hdr $ msBlob sdu where enc = do - Bin.putWord32be $ unRemoteClockModel $ msTimestamp sdu + Bin.putWord16be $ unCookie $ msSendCookie sdu + Bin.putWord16be $ unCookie $ msEchoCookie sdu Bin.putWord16be $ putNumAndMode (msNum sdu) (msDir sdu) Bin.putWord16be $ fromIntegral $ BL.length $ msBlob sdu @@ -65,13 +70,15 @@ decodeSDU buf = else Left $ SDUDecodeError "short SDU" where dec = do - mhTimestamp <- RemoteClockModel <$> Bin.getWord32be + mhSendCookie <- Cookie <$> Bin.getWord16be + mhEchoCookie <- Cookie <$> Bin.getWord16be a <- Bin.getWord16be mhLength <- Bin.getWord16be - let mhDir = getDir a - mhNum = MiniProtocolNum (a .&. 0x7fff) + let mhDir = getDir a + mhNum = MiniProtocolNum (a .&. 0x7fff) return $ SDUHeader { - mhTimestamp, + mhSendCookie, + mhEchoCookie, mhNum, mhDir, mhLength diff --git a/network-mux/src/Network/Mux/RTT.hs b/network-mux/src/Network/Mux/RTT.hs new file mode 100644 index 0000000000..85df4f29b6 --- /dev/null +++ b/network-mux/src/Network/Mux/RTT.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} + +-- | Per-connection RTT tracking driven by the SDU-header cookie +-- scheme. +-- +-- Each outgoing SDU carries a random 'Cookie' in 'mhSendCookie'. +-- The peer, on receipt, remembers the freshest 'mhSendCookie' it has +-- observed and echoes it in the 'mhEchoCookie' field of its own +-- outgoing SDUs. When we see an 'mhEchoCookie' we sent earlier, we +-- look up the local send time in an outstanding-cookies map and +-- compute the RTT. +-- +-- The map is a priority-search queue keyed by 'Cookie' and +-- prioritised by send 'Time'. That gives us: +-- +-- * O(log N) lookup on echo receipt. +-- * O(1) access to the oldest outstanding entry for time-based +-- age-out. +-- * O((k+1) log N) pruning of everything at or before a given +-- time (used both for age-out and for the "prune-on-match" +-- enforcement of the monotone-echo invariant). +-- +-- Cookies are drawn from an 'StdGen' PRNG per mux; a hostile peer +-- cannot echo a cookie value we have not previously sent, so RTT +-- cannot be forged low. The peer can inflate observed RTT only by +-- delaying its own outbound SDUs — which is a real RTT signal, not +-- an attack. +-- +module Network.Mux.RTT + ( -- * Peer-facing reader + PeerRTT (..) + , noPeerRTT + -- * Internal sampling state + , RTTState + , newRTTState + , newSendCookie + , peerRTT + -- * Configuration + , defaultBucketDur + , defaultRetention + , defaultHoldDuration + , defaultMaxOutstanding + , defaultMintInterval + , RTTComp + ) where + +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad.Class.MonadTime.SI +import Data.OrdPSQ (OrdPSQ) +import Data.OrdPSQ qualified as PSQ +import Data.Window.DigestTimeBatched qualified as DTB +import System.Random (StdGen, uniformR) + +import Network.Mux.Types (Cookie (..), SDUHeader (..), noCookie) + + +-- | STM accessor for the local muxer's rolling RTT distribution to +-- this peer. +-- +-- Callers supply a quantile at read time (@0.5@ for median, @0.99@ +-- for a tail-guard, etc.). 'Nothing' is returned when no RTT samples +-- have been observed yet. +newtype PeerRTT m = PeerRTT { + readPeerRTTQuantile :: Double -> STM m (Maybe DiffTime) + } + +-- | A 'PeerRTT' handle that always yields 'Nothing'. Placeholder for +-- test/demo sites that don't run over a real mux. +noPeerRTT :: MonadSTM m => PeerRTT m +noPeerRTT = PeerRTT (\_ -> pure Nothing) + + +-- | t-digest compression parameter for the RTT window. +type RTTComp = 100 + +-- | Default per-bucket duration. +defaultBucketDur :: DiffTime +defaultBucketDur = 1 + +-- | Default retention in buckets. +defaultRetention :: Int +defaultRetention = 60 + +-- | Default outstanding-cookie hold: comfortably above worst-case +-- peer dwell (KeepAlive interval + reply timeout + a multi-second +-- peer GC pause). +defaultHoldDuration :: DiffTime +defaultHoldDuration = 30 + +-- | Cap on the outstanding-cookie map size. At Word16, the birthday +-- collision rate is ~N/2¹⁶, so 4096 gives ~6% per-insert re-roll — +-- comfortable. +defaultMaxOutstanding :: Int +defaultMaxOutstanding = 4096 + +-- | Minimum interval between minting fresh cookies. Outgoing SDUs +-- within this window of the previous mint reuse the same cookie — +-- avoids per-SDU PRNG work and OrdPSQ inserts on high-throughput +-- connections. RTT samples for reused cookies are computed against +-- the mint time, so the observed RTT can over-estimate by up to +-- 'defaultMintInterval' for the later SDUs in a batch. 1 ms is fine +-- for RTTs of a few ms upward. +defaultMintInterval :: DiffTime +defaultMintInterval = 1e-3 + + +-- | Internal per-mux RTT state. +data RTTState m = RTTState { + -- | Freshest peer send-cookie observed (goes into next echo field). + rttLastPeerCookie :: !(StrictTVar m Cookie) + -- | Outstanding cookies we've sent, keyed by cookie and + -- prioritised by send 'Time'. + -- + -- On a successful echo match, prune-on-match deletes the matched + -- entry and every older one; that implicitly enforces the + -- monotone-echo invariant (later echoes cannot re-match a + -- send time earlier than the last one we accepted), so no + -- separate 'lastAccepted' guard is needed. + , rttOutstanding :: !(StrictTVar m (OrdPSQ Cookie Time ())) + -- | Most recently minted (cookie, mint-time) — reused by + -- 'newSendCookie' for SDUs sent within 'rttMintInterval' of the + -- previous mint. 'Nothing' before the first mint. + , rttLastMinted :: !(StrictTVar m (Maybe (Cookie, Time))) + -- | PRNG for cookie generation. + , rttPRNG :: !(StrictTVar m StdGen) + -- | Rolling t-digest window of RTT samples. + , rttWindow :: !(StrictTVar m (DTB.TimedDigestWindow Time RTTComp)) + -- | How long we retain an unmatched cookie before evicting. + , rttHoldDuration :: !DiffTime + -- | Cap on outstanding cookies (drop-oldest on overflow). + , rttMaxOutstanding :: !Int + -- | Cookie-reuse window; see 'defaultMintInterval'. + , rttMintInterval :: !DiffTime + } + + +-- | Construct fresh RTT state. Caller supplies the 'StdGen' — pass +-- an entropy-seeded 'newStdGen' from IO in production, or a fixed +-- 'mkStdGen' from a test. +newRTTState + :: MonadLabelledSTM m + => StdGen + -> m (RTTState m) +newRTTState g = do + rttLastPeerCookie <- newTVarIO noCookie + rttOutstanding <- newTVarIO PSQ.empty + rttLastMinted <- newTVarIO Nothing + rttPRNG <- newTVarIO g + rttWindow <- newTVarIO (DTB.empty defaultBucketDur defaultRetention) + labelTVarIO rttLastPeerCookie "RTT.lastPeerCookie" + labelTVarIO rttOutstanding "RTT.outstanding" + labelTVarIO rttLastMinted "RTT.lastMinted" + labelTVarIO rttLastEcho "RTT.lastEcho" + labelTVarIO rttPRNG "RTT.prng" + labelTVarIO rttWindow "RTT.window" + return RTTState { + rttLastPeerCookie, + rttOutstanding, + rttLastMinted, + rttLastEcho, + rttPRNG, + rttWindow, + rttHoldDuration = defaultHoldDuration, + rttMaxOutstanding = defaultMaxOutstanding, + rttMintInterval = defaultMintInterval, + } + + +-- | Return a (sendCookie, echoCookie) pair for an outgoing SDU. +-- +-- If the previous mint is within 'rttMintInterval' of @now@, the +-- previous cookie is reused — no PRNG draw, no 'OrdPSQ' insert. RTT +-- samples for reused cookies are computed against the *mint* time, +-- so late SDUs in a batch will see an RTT over-estimated by up to +-- 'rttMintInterval'. +-- +-- Otherwise we draw a fresh non-collision cookie, insert it against +-- the given send time, and record it as the new last-mint. Overflow +-- behaviour: if outstanding is at capacity we drop the oldest entry. +-- Collision behaviour: re-roll if the drawn cookie already appears +-- in outstanding (bounded to a small constant number of re-rolls at +-- reasonable N). +newSendCookie + :: MonadSTM m + => RTTState m + -> Time + -> STM m (Cookie, Cookie) +newSendCookie RTTState { rttLastPeerCookie + , rttOutstanding + , rttLastMinted + , rttPRNG + , rttMaxOutstanding + , rttMintInterval + } !now = do + mLast <- readTVar rttLastMinted + echo <- readTVar rttLastPeerCookie + case mLast of + Just (c, t) | now `diffTime` t < rttMintInterval -> + pure (c, echo) + _otherwise -> do + outs <- readTVar rttOutstanding + g0 <- readTVar rttPRNG + let (!cookie, g1) = drawCookie outs g0 + outs' = trimToCap rttMaxOutstanding + (PSQ.insert cookie now () outs) + writeTVar rttOutstanding outs' + writeTVar rttPRNG g1 + writeTVar rttLastMinted (Just (cookie, now)) + pure (cookie, echo) + where + -- Draw a non-'noCookie' value that doesn't collide with outstanding. + drawCookie outs g = + let (w, g') = uniformR (1, maxBound) g + c = Cookie w + in maybe (c, g') (const $ drawCookie outs g') $ PSQ.lookup c outs + + trimToCap cap psq + | PSQ.size psq <= cap = psq + | otherwise = case PSQ.minView psq of + Just (_k, _p, _v, rest) -> trimToCap cap rest + Nothing -> psq + + +-- | Reader handle for consumers. +peerRTT :: MonadSTM m => RTTState m -> PeerRTT m +peerRTT RTTState { rttWindow } = PeerRTT $ \q -> do + w <- readTVar rttWindow + return $! realToFrac <$> DTB.windowQuantile q w diff --git a/network-mux/src/Network/Mux/Time.hs b/network-mux/src/Network/Mux/Time.hs index a743b813af..8b004fdb04 100644 --- a/network-mux/src/Network/Mux/Time.hs +++ b/network-mux/src/Network/Mux/Time.hs @@ -4,28 +4,12 @@ module Network.Mux.Time DiffTime , diffTimeToMicroseconds , microsecondsToDiffTime - -- * Compact timestamp - , timestampMicrosecondsLow32Bits ) where -import Control.Monad.Class.MonadTime.SI (Time (..)) import Data.Time.Clock (DiffTime, diffTimeToPicoseconds, picosecondsToDiffTime) -import Data.Word (Word32) diffTimeToMicroseconds :: DiffTime -> Integer diffTimeToMicroseconds = (`div` 1000000) . diffTimeToPicoseconds microsecondsToDiffTime :: Integer -> DiffTime microsecondsToDiffTime = picosecondsToDiffTime . (* 1000000) - --- | This is a slightly peculiar operation: it returns the number of --- microseconds since an arbitrary epoch, modulo 2^32. This number of --- microseconds wraps every ~35 minutes. --- --- The purpose is to give a compact timestamp (compact to send over the wire) --- for measuring time differences on the order of seconds or less. --- -timestampMicrosecondsLow32Bits :: Time -> Word32 -timestampMicrosecondsLow32Bits (Time ts) = - fromIntegral (diffTimeToMicroseconds ts) - diff --git a/network-mux/src/Network/Mux/Types.hs b/network-mux/src/Network/Mux/Types.hs index 00fd1e47dc..964ba67997 100644 --- a/network-mux/src/Network/Mux/Types.hs +++ b/network-mux/src/Network/Mux/Types.hs @@ -33,14 +33,16 @@ module Network.Mux.Types , SDU (..) , SDUHeader (..) , SDUSize (..) - , msTimestamp - , setTimestamp + , msSendCookie + , msEchoCookie + , setSendCookie + , setEchoCookie , msNum , msDir , msLength , msHeaderLength - , RemoteClockModel (..) - , remoteClockPrecision + , Cookie (..) + , noCookie , RuntimeError (..) , ReadBuffer (..) , BearerTrace (..) @@ -71,13 +73,30 @@ import Network.Mux.TCPInfo import Network.Mux.Timeout (TimeoutFn) -newtype RemoteClockModel - = RemoteClockModel { unRemoteClockModel :: Word32 } - deriving (Eq, Bounded) - --- | The `DiffTime` represented by a tick in the `RemoteClockModel` -remoteClockPrecision :: DiffTime -remoteClockPrecision = 1e-6 +-- | An opaque cookie carried in the SDU header. +-- +-- The SDU header carries two of these: a fresh cookie +-- ('mhSendCookie') minted by the local muxer per outgoing SDU, and +-- an echo ('mhEchoCookie') of the freshest 'mhSendCookie' the local +-- muxer received from its peer. The receiver, matching an incoming +-- echo against its own outstanding-cookie map, recovers the local +-- time at which that cookie was sent — hence a per-SDU RTT sample. +-- +-- Cookies are drawn from a PRNG so a peer cannot forge low RTTs by +-- echoing a cookie value we have not actually sent. The 'noCookie' +-- ('Cookie' 0) value is reserved as the "no echo available" sentinel. +newtype Cookie + = Cookie { unCookie :: Word16 } + deriving (Eq, Ord, Bounded) + +instance Show Cookie where + show (Cookie w) = printf "0x%04x" w + +-- | Sentinel echo-cookie meaning "the local muxer has not observed a +-- peer cookie yet". Peers echoing this back must be dropped rather +-- than matched. +noCookie :: Cookie +noCookie = Cookie 0 -- -- Mini-protocol numbers @@ -227,10 +246,15 @@ data MiniProtocolStatus = StatusIdle deriving (Eq, Show) data SDUHeader = SDUHeader { - mhTimestamp :: !RemoteClockModel - , mhNum :: !MiniProtocolNum - , mhDir :: !MiniProtocolDir - , mhLength :: !Word16 + mhSendCookie :: !Cookie + -- ^ Fresh cookie drawn per outgoing SDU by the local muxer. + , mhEchoCookie :: !Cookie + -- ^ Echo of the freshest 'mhSendCookie' the local muxer has + -- received from its peer. On receipt, this is the identifier + -- against which we look up our own send time. + , mhNum :: !MiniProtocolNum + , mhDir :: !MiniProtocolDir + , mhLength :: !Word16 } @@ -239,12 +263,19 @@ data SDU = SDU { , msBlob :: !BL.ByteString } -msTimestamp :: SDU -> RemoteClockModel -msTimestamp = mhTimestamp . msHeader +msSendCookie :: SDU -> Cookie +msSendCookie = mhSendCookie . msHeader + +msEchoCookie :: SDU -> Cookie +msEchoCookie = mhEchoCookie . msHeader + +setSendCookie :: SDU -> Cookie -> SDU +setSendCookie sdu@SDU { msHeader } mhSendCookie = + sdu { msHeader = msHeader { mhSendCookie } } -setTimestamp :: SDU -> RemoteClockModel -> SDU -setTimestamp sdu@SDU { msHeader } mhTimestamp = - sdu { msHeader = msHeader { mhTimestamp } } +setEchoCookie :: SDU -> Cookie -> SDU +setEchoCookie sdu@SDU { msHeader } mhEchoCookie = + sdu { msHeader = msHeader { mhEchoCookie } } msNum :: SDU -> MiniProtocolNum msNum = mhNum . msHeader @@ -308,12 +339,13 @@ bearerAsChannel tracer bearer ptclNum ptclDir = -- wrap a 'ByteString' as 'SDU' wrap :: BL.ByteString -> SDU wrap blob = SDU { - -- it will be filled when the 'SDU' is send by the 'bearer' + -- Cookies are filled in by the muxer at SDU construction. msHeader = SDUHeader { - mhTimestamp = RemoteClockModel 0, - mhNum = ptclNum, - mhDir = ptclDir, - mhLength = fromIntegral $ BL.length blob + mhSendCookie = noCookie, + mhEchoCookie = noCookie, + mhNum = ptclNum, + mhDir = ptclDir, + mhLength = fromIntegral $ BL.length blob }, msBlob = blob } diff --git a/ouroboros-network/framework/lib/Ouroboros/Network/ConnectionHandler.hs b/ouroboros-network/framework/lib/Ouroboros/Network/ConnectionHandler.hs index b4b9354411..1adc70161e 100644 --- a/ouroboros-network/framework/lib/Ouroboros/Network/ConnectionHandler.hs +++ b/ouroboros-network/framework/lib/Ouroboros/Network/ConnectionHandler.hs @@ -144,7 +144,7 @@ data MkMuxConnectionHandler (muxMode :: Mx.Mode) socket initiatorCtx responderCt -- type HandleWithExpandedCtx muxMode peerAddr extraFlags versionData bytes m a b = Handle muxMode (ExpandedInitiatorContext peerAddr extraFlags m) - (ResponderContext peerAddr) + (ResponderContext peerAddr m) versionData bytes m a b -- | 'Handle' used by: @@ -154,7 +154,7 @@ type HandleWithExpandedCtx muxMode peerAddr extraFlags versionData bytes m a b = -- type HandleWithMinimalCtx muxMode peerAddr versionData bytes m a b = Handle muxMode (MinimalInitiatorContext peerAddr) - (ResponderContext peerAddr) + (ResponderContext peerAddr m) versionData bytes m a b -- | A connection handler error. diff --git a/ouroboros-network/framework/lib/Ouroboros/Network/Context.hs b/ouroboros-network/framework/lib/Ouroboros/Network/Context.hs index 49d4da94db..dc33533cf4 100644 --- a/ouroboros-network/framework/lib/Ouroboros/Network/Context.hs +++ b/ouroboros-network/framework/lib/Ouroboros/Network/Context.hs @@ -7,11 +7,15 @@ module Ouroboros.Network.Context , MinimalInitiatorContext (..) , ResponderContext (..) -- * Re-exports + , PeerRTT (..) + , noPeerRTT , ConnectionId (..) , ControlMessageSTM , IsBigLedgerPeer (..) ) where +import Network.Mux (PeerRTT (..), noPeerRTT) + import Ouroboros.Network.ConnectionId import Ouroboros.Network.ControlMessage import Ouroboros.Network.PeerSelection.LedgerPeers.Type @@ -23,8 +27,10 @@ data ExpandedInitiatorContext addr extraFlags m = ExpandedInitiatorContext { eicConnectionId :: !(ConnectionId addr), eicControlMessage :: !(ControlMessageSTM m), eicIsBigLedgerPeer :: !IsBigLedgerPeer, - eicExtraFlags :: !extraFlags + eicExtraFlags :: !extraFlags, -- ^ in `cardano-diffusion` it's instantiated to `PeerTrustable`, in `dmq-node` to `NoExtraFlags` + eicPeerRTT :: !(PeerRTT m) + -- ^ read handle for the per-peer RTT distribution } -- | A context passed to initiator mini-protocol execution for non-p2p @@ -37,7 +43,8 @@ newtype MinimalInitiatorContext addr = MinimalInitiatorContext { -- | Context passed to each responder mini-protocol execution. -- -newtype ResponderContext addr = ResponderContext { - rcConnectionId :: ConnectionId addr +data ResponderContext addr m = ResponderContext { + rcConnectionId :: !(ConnectionId addr), + rcPeerRTT :: !(PeerRTT m) + -- ^ read handle for the per-peer RTT distribution } - deriving Functor diff --git a/ouroboros-network/framework/lib/Ouroboros/Network/InboundGovernor.hs b/ouroboros-network/framework/lib/Ouroboros/Network/InboundGovernor.hs index 7e515d9fe9..08f43284e7 100644 --- a/ouroboros-network/framework/lib/Ouroboros/Network/InboundGovernor.hs +++ b/ouroboros-network/framework/lib/Ouroboros/Network/InboundGovernor.hs @@ -290,7 +290,10 @@ with }) -> do traceWith tracer (TrNewConnection provenance connId) - let responderContext = ResponderContext { rcConnectionId = connId } + let responderContext = ResponderContext { + rcConnectionId = connId, + rcPeerRTT = Mux.peerRTT csMux + } connections <- Map.alterF (\case @@ -809,7 +812,7 @@ mkRemoteTransitionTrace connId fromState toState = -- * /Consumer:/ inbound governor. -- type InboundGovernorInfoChannel (muxMode :: Mux.Mode) initiatorCtx peerAddr versionData bytes m a b = - InformationChannel (Event (muxMode :: Mux.Mode) (Handle muxMode initiatorCtx (ResponderContext peerAddr) versionData bytes m a b) initiatorCtx peerAddr versionData m a b) m + InformationChannel (Event (muxMode :: Mux.Mode) (Handle muxMode initiatorCtx (ResponderContext peerAddr m) versionData bytes m a b) initiatorCtx peerAddr versionData m a b) m -- | Announcement message for a new connection. diff --git a/ouroboros-network/framework/lib/Ouroboros/Network/InboundGovernor/State.hs b/ouroboros-network/framework/lib/Ouroboros/Network/InboundGovernor/State.hs index 3ec04788d5..b86219a617 100644 --- a/ouroboros-network/framework/lib/Ouroboros/Network/InboundGovernor/State.hs +++ b/ouroboros-network/framework/lib/Ouroboros/Network/InboundGovernor/State.hs @@ -152,9 +152,9 @@ counters State { connections } = data MiniProtocolData muxMode initiatorCtx peerAddr m a b = MiniProtocolData { -- | Static 'MiniProtocol' description. -- - mpdMiniProtocol :: !(MiniProtocol muxMode initiatorCtx (ResponderContext peerAddr) ByteString m a b), + mpdMiniProtocol :: !(MiniProtocol muxMode initiatorCtx (ResponderContext peerAddr m) ByteString m a b), - mpdResponderContext :: !(ResponderContext peerAddr), + mpdResponderContext :: !(ResponderContext peerAddr m), -- | Static mini-protocol temperature. -- diff --git a/ouroboros-network/framework/lib/Ouroboros/Network/Mux.hs b/ouroboros-network/framework/lib/Ouroboros/Network/Mux.hs index 0904451bc2..d85a699036 100644 --- a/ouroboros-network/framework/lib/Ouroboros/Network/Mux.hs +++ b/ouroboros-network/framework/lib/Ouroboros/Network/Mux.hs @@ -222,13 +222,13 @@ type OuroborosBundle (mode :: Mux.Mode) initiatorCtx responderCtx bytes m a b type OuroborosBundleWithExpandedCtx (mode :: Mux.Mode) peerAddr extraFlags bytes m a b = OuroborosBundle mode (ExpandedInitiatorContext peerAddr extraFlags m) - (ResponderContext peerAddr) + (ResponderContext peerAddr m) bytes m a b type OuroborosBundleWithMinimalCtx (mode :: Mux.Mode) peerAddr bytes m a b = OuroborosBundle mode (MinimalInitiatorContext peerAddr) - (ResponderContext peerAddr) + (ResponderContext peerAddr m) bytes m a b @@ -280,14 +280,14 @@ mkMiniProtocolInfo forkPolicy MiniProtocol { -- type MiniProtocolWithExpandedCtx mode peerAddr extraFlags bytes m a b = MiniProtocol mode (ExpandedInitiatorContext peerAddr extraFlags m) - (ResponderContext peerAddr) + (ResponderContext peerAddr m) bytes m a b -- | 'MiniProtocol' type used in non-P2P. -- type MiniProtocolWithMinimalCtx mode peerAddr bytes m a b = MiniProtocol mode (MinimalInitiatorContext peerAddr) - (ResponderContext peerAddr) + (ResponderContext peerAddr m) bytes m a b @@ -316,7 +316,7 @@ data RunMiniProtocol (mode :: Mux.Mode) initiatorCtx responderCtx bytes m a b wh type RunMiniProtocolWithExpandedCtx mode peerAddr extraFlags bytes m a b = RunMiniProtocol mode (ExpandedInitiatorContext peerAddr extraFlags m) - (ResponderContext peerAddr) + (ResponderContext peerAddr m) bytes m a b @@ -327,7 +327,7 @@ type RunMiniProtocolWithExpandedCtx mode peerAddr extraFlags bytes m a b = type RunMiniProtocolWithMinimalCtx mode peerAddr bytes m a b = RunMiniProtocol mode (MinimalInitiatorContext peerAddr) - (ResponderContext peerAddr) + (ResponderContext peerAddr m) bytes m a b @@ -451,7 +451,7 @@ newtype OuroborosApplication (mode :: Mux.Mode) initiatorCtx responderCtx bytes type OuroborosApplicationWithMinimalCtx mode peerAddr bytes m a b = OuroborosApplication mode (MinimalInitiatorContext peerAddr) - (ResponderContext peerAddr) + (ResponderContext peerAddr m) bytes m a b fromOuroborosBundle :: OuroborosBundle mode initiatorCtx responderCtx bytes m a b diff --git a/ouroboros-network/lib/Ouroboros/Network/Diffusion/Types.hs b/ouroboros-network/lib/Ouroboros/Network/Diffusion/Types.hs index 3089351cd6..a7467aa501 100644 --- a/ouroboros-network/lib/Ouroboros/Network/Diffusion/Types.hs +++ b/ouroboros-network/lib/Ouroboros/Network/Diffusion/Types.hs @@ -717,7 +717,7 @@ type NodeToNodeConnectionManager type NodeToNodePeerConnectionHandle (mode :: Mx.Mode) ntnAddr extraFlags ntnVersionData m a b = PeerConnectionHandle mode - (ResponderContext ntnAddr) + (ResponderContext ntnAddr m) ntnAddr extraFlags ntnVersionData diff --git a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/PeerStateActions.hs b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/PeerStateActions.hs index 3d037275c3..7ceda3f31c 100644 --- a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/PeerStateActions.hs +++ b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/PeerStateActions.hs @@ -459,14 +459,16 @@ mkInitiatorContext :: MonadSTM m mkInitiatorContext tok isBigLedgerPeer extraFlags PeerConnectionHandle { pchConnectionId = connectionId, - pchAppHandles = appHandles + pchAppHandles = appHandles, + pchMux = mux } = ExpandedInitiatorContext { eicConnectionId = connectionId, eicControlMessage = readTVar (getControlVar tok appHandles), eicIsBigLedgerPeer = isBigLedgerPeer, - eicExtraFlags = extraFlags + eicExtraFlags = extraFlags, + eicPeerRTT = Mux.peerRTT mux } From 4b465a2be3a508ee7905b32176e2d6bb3a877e6a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Thu, 16 Jul 2026 15:18:02 +0200 Subject: [PATCH 10/17] mux: wire ingress/egress RTT sampling - muxer and demuxer accept RTTState - the muxer mints a new cookie (or re-uses one) per the policy, and processSingleWanton echoes the last send cookie we received from our peer (provided by the demuxer). - the demuxer in addition to the previous activity also prunes our cookie jar so it stays within bounded space. --- network-mux/src/Network/Mux.hs | 7 +- .../Network/Mux/Bearer/AttenuatedChannel.hs | 1 - .../src/Network/Mux/Bearer/NamedPipe.hs | 1 - network-mux/src/Network/Mux/Bearer/Pipe.hs | 1 - network-mux/src/Network/Mux/Bearer/Queues.hs | 1 - network-mux/src/Network/Mux/Bearer/Socket.hs | 1 - network-mux/src/Network/Mux/Egress.hs | 75 ++++++----- network-mux/src/Network/Mux/Ingress.hs | 29 ++++- network-mux/src/Network/Mux/RTT.hs | 119 ++++++++++++++++++ 9 files changed, 190 insertions(+), 45 deletions(-) diff --git a/network-mux/src/Network/Mux.hs b/network-mux/src/Network/Mux.hs index 99a18d3e03..992a13d833 100644 --- a/network-mux/src/Network/Mux.hs +++ b/network-mux/src/Network/Mux.hs @@ -157,7 +157,8 @@ new muxTracers ptcls = do muxMiniProtocols, muxControlCmdQueue, muxStatus, - muxTracers + muxTracers, + muxRTTState } mkMiniProtocolStateMap :: MonadSTM m @@ -292,13 +293,13 @@ run Mux { muxMiniProtocols, where muxerJob egressQueue = - JobPool.Job (muxer egressQueue bearerTracer_ bearer) + JobPool.Job (muxer egressQueue muxRTTState bearerTracer_ bearer) (return . MuxerException) MuxJob (name ++ "-muxer") demuxerJob = - JobPool.Job (demuxer (Map.elems muxMiniProtocols) bearerTracer_ bearer) + JobPool.Job (demuxer (Map.elems muxMiniProtocols) muxRTTState bearerTracer_ bearer) (return . DemuxerException) MuxJob (name ++ "-demuxer") diff --git a/network-mux/src/Network/Mux/Bearer/AttenuatedChannel.hs b/network-mux/src/Network/Mux/Bearer/AttenuatedChannel.hs index 4f0a4f9511..176b997ed6 100644 --- a/network-mux/src/Network/Mux/Bearer/AttenuatedChannel.hs +++ b/network-mux/src/Network/Mux/Bearer/AttenuatedChannel.hs @@ -298,7 +298,6 @@ attenuationChannelAsBearer sduSize sduTimeout chan = let header = msHeader muxsdu traceWith tracer $ TraceRecvHeaderEnd header ts <- getMonotonicTime - traceWith tracer $ TraceRecvDeltaQObservation header ts return (muxsdu {msBlob = payload}, ts) writeMux :: Tracer m BearerTrace -> TimeoutFn m -> SDU -> m Time diff --git a/network-mux/src/Network/Mux/Bearer/NamedPipe.hs b/network-mux/src/Network/Mux/Bearer/NamedPipe.hs index 74b4c79317..8bea38d949 100644 --- a/network-mux/src/Network/Mux/Bearer/NamedPipe.hs +++ b/network-mux/src/Network/Mux/Bearer/NamedPipe.hs @@ -51,7 +51,6 @@ namedPipeAsBearer sduSize h = traceWith tracer $ Mx.TraceRecvHeaderEnd msHeader blob <- recvLen' tracer False (fromIntegral $ Mx.mhLength msHeader) [] ts <- getMonotonicTime - traceWith tracer (Mx.TraceRecvDeltaQObservation msHeader ts) return (header {Mx.msBlob = blob}, ts) recvLen' :: Tracer IO Mx.BearerTrace -> Bool -> Int64 -> [BL.ByteString] -> IO BL.ByteString diff --git a/network-mux/src/Network/Mux/Bearer/Pipe.hs b/network-mux/src/Network/Mux/Bearer/Pipe.hs index 13d3bee64a..de78f13629 100644 --- a/network-mux/src/Network/Mux/Bearer/Pipe.hs +++ b/network-mux/src/Network/Mux/Bearer/Pipe.hs @@ -93,7 +93,6 @@ pipeAsBearer sduSize channel = traceWith tracer $ Mx.TraceRecvHeaderEnd msHeader blob <- recvLen' (fromIntegral $ Mx.mhLength msHeader) [] ts <- getMonotonicTime - traceWith tracer (Mx.TraceRecvDeltaQObservation msHeader ts) return (header {Mx.msBlob = blob}, ts) where recvLen' :: Int -> [BL.ByteString] -> IO BL.ByteString diff --git a/network-mux/src/Network/Mux/Bearer/Queues.hs b/network-mux/src/Network/Mux/Bearer/Queues.hs index dca804f16b..aae70f473c 100644 --- a/network-mux/src/Network/Mux/Bearer/Queues.hs +++ b/network-mux/src/Network/Mux/Bearer/Queues.hs @@ -58,7 +58,6 @@ queueChannelAsBearer sduSize QueueChannel { writeQueue, readQueue } = do Right header -> do traceWith tracer $ Mx.TraceRecvHeaderEnd (Mx.msHeader header) ts <- getMonotonicTime - traceWith tracer $ Mx.TraceRecvDeltaQObservation (Mx.msHeader header) ts return (header {Mx.msBlob = payload}, ts) writeMux :: Tracer m Mx.BearerTrace -> Mx.TimeoutFn m -> Mx.SDU -> m Time diff --git a/network-mux/src/Network/Mux/Bearer/Socket.hs b/network-mux/src/Network/Mux/Bearer/Socket.hs index 2ec1dcb88e..a166185193 100644 --- a/network-mux/src/Network/Mux/Bearer/Socket.hs +++ b/network-mux/src/Network/Mux/Bearer/Socket.hs @@ -92,7 +92,6 @@ socketAsBearer sduSize batchSize readBuffer_m sduTimeout egressInterval sd = !ts <- getMonotonicTime let !header' = header {Mx.msBlob = blob} - traceWith tracer (Mx.TraceRecvDeltaQObservation msHeader ts) return (header', ts) recvLen' :: Int64 -> [BL.ByteString] -> IO BL.ByteString diff --git a/network-mux/src/Network/Mux/Egress.hs b/network-mux/src/Network/Mux/Egress.hs index ef8fcd5b76..940e6a2516 100644 --- a/network-mux/src/Network/Mux/Egress.hs +++ b/network-mux/src/Network/Mux/Egress.hs @@ -24,6 +24,7 @@ import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI hiding (timeout) import Control.Tracer (Tracer) +import Network.Mux.RTT (RTTState, newSendCookie) import Network.Mux.Timeout import Network.Mux.Types @@ -143,16 +144,26 @@ muxer , MonadTimer m ) => EgressQueue m + -> RTTState m -> Tracer m BearerTrace -> Bearer m -> m void -muxer egressQueue tracer Bearer { writeMany, sduSize, batchSize, egressInterval } = +muxer egressQueue rttState tracer Bearer { writeMany, sduSize, batchSize, egressInterval } = withTimeoutSerial $ \timeout -> forever $ do start <- getMonotonicTime TLSRDemand mpc md d <- atomically $ readTBQueue egressQueue - sdu <- processSingleWanton egressQueue sduSize mpc md d - sdus <- buildBatch [sdu] (sduLength sdu) + -- Capture the send-time *after* the queue read, not before. If + -- 'readTBQueue' blocked waiting for a demand, using 'start' + -- would attribute the queue-block interval to the cookie's + -- send time and inflate the RTT samples this batch produces. + -- 'start' stays for the loop-throttle math below. + mintTime <- getMonotonicTime + -- Mint a fresh (send, echo) cookie pair once per iteration and + -- reuse it across every SDU in this batch. + cookies <- atomically $ newSendCookie rttState mintTime + sdu <- atomically $ processSingleWanton egressQueue cookies sduSize mpc md d + sdus <- buildBatch cookies [sdu] (sduLength sdu) void $ writeMany tracer timeout sdus end <- getMonotonicTime empty <- atomically $ isEmptyTBQueue egressQueue @@ -173,7 +184,7 @@ muxer egressQueue tracer Bearer { writeMany, sduSize, batchSize, egressInterval -- The batch size is either limited by the bearer -- (e.g the SO_SNDBUF for Socket) or number of SDUs. -- - buildBatch s sl = reverse <$> go s sl + buildBatch cookies s sl = reverse <$> go s sl where go sdus _ | length sdus >= maxSDUsPerBatch = return sdus go sdus sdusLength | sdusLength >= batchSize = return sdus @@ -181,7 +192,7 @@ muxer egressQueue tracer Bearer { writeMany, sduSize, batchSize, egressInterval demand_m <- atomically $ tryReadTBQueue egressQueue case demand_m of Just (TLSRDemand mpc md d) -> do - sdu <- processSingleWanton egressQueue sduSize mpc md d + sdu <- atomically $ processSingleWanton egressQueue cookies sduSize mpc md d go (sdu:sdus) (sdusLength + sduLength sdu) Nothing -> return sdus @@ -191,36 +202,36 @@ muxer egressQueue tracer Bearer { writeMany, sduSize, batchSize, egressInterval -- first. processSingleWanton :: MonadSTM m => EgressQueue m + -> (Cookie, Cookie) + -- ^ (send, echo) cookie pair, minted once per + -- muxer iteration and reused across the batch. -> SDUSize -> MiniProtocolNum -> MiniProtocolDir -> Wanton m - -> m SDU -processSingleWanton egressQueue (SDUSize sduSize) + -> STM m SDU +processSingleWanton egressQueue (sendCookie, echoCookie) (SDUSize sduSize) mpc md wanton = do - blob <- atomically $ do - -- extract next SDU - d <- readTVar (want wanton) - let (frag, rest) = BL.splitAt (fromIntegral sduSize) d - -- if more to process then enqueue remaining work - if BL.null rest - then writeTVar (want wanton) BL.empty - else do - -- Note that to preserve bytestream ordering within a given - -- miniprotocol the readTVar and writeTVar operations - -- must be inside the same STM transaction. - writeTVar (want wanton) rest - writeTBQueue egressQueue (TLSRDemand mpc md wanton) - -- return data to send - pure frag - let sdu = SDU { - msHeader = SDUHeader { - mhTimestamp = RemoteClockModel 0, - mhNum = mpc, - mhDir = md, - mhLength = fromIntegral $ BL.length blob - }, - msBlob = blob - } - return sdu + -- extract next SDU + d <- readTVar (want wanton) + let (frag, rest) = BL.splitAt (fromIntegral sduSize) d + -- if more to process then enqueue remaining work + if BL.null rest + then writeTVar (want wanton) BL.empty + else do + -- Note that to preserve bytestream ordering within a given + -- miniprotocol the readTVar and writeTVar operations + -- must be inside the same STM transaction. + writeTVar (want wanton) rest + writeTBQueue egressQueue (TLSRDemand mpc md wanton) + pure SDU { + msHeader = SDUHeader { + mhSendCookie = sendCookie, + mhEchoCookie = echoCookie, + mhNum = mpc, + mhDir = md, + mhLength = fromIntegral $ BL.length frag + }, + msBlob = frag + } --paceTransmission tNow diff --git a/network-mux/src/Network/Mux/Ingress.hs b/network-mux/src/Network/Mux/Ingress.hs index 263d31517c..ec5af41399 100644 --- a/network-mux/src/Network/Mux/Ingress.hs +++ b/network-mux/src/Network/Mux/Ingress.hs @@ -24,8 +24,9 @@ import Control.Monad import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTimer.SI hiding (timeout) -import Control.Tracer (Tracer) +import Control.Tracer (Tracer, traceWith) +import Network.Mux.RTT (IngressEcho (..), RTTState, processIngress) import Network.Mux.Timeout import Network.Mux.Trace import Network.Mux.Types as Mx @@ -102,16 +103,34 @@ data MiniProtocolDispatchInfo m = demuxer :: (MonadAsync m, MonadFork m, MonadMask m, MonadThrow (STM m), MonadTimer m) => [MiniProtocolState mode m] + -> RTTState m -> Tracer m BearerTrace -> Bearer m -> m void -demuxer ptcls tracer bearer = +demuxer ptcls rttState tracer bearer = let !dispatchTable = setupDispatchTable ptcls in withTimeoutSerial $ \timeout -> forever $ do - (sdu, _) <- Mx.read bearer tracer timeout - -- say $ printf "demuxing sdu on mid %s mode %s lenght %d " (show $ msId sdu) (show $ msDir sdu) - -- (BL.length $ msBlob sdu) + (sdu, recvTime) <- Mx.read bearer tracer timeout + -- Update the last-peer-cookie TVar; sample RTT or burst-gap + -- when the peer echoed one of our outstanding cookies. Both + -- flavours of observation are surfaced as bearer traces; a + -- downstream transformer can filter/bucket per protocol and + -- decide which measurements to feed to which regression (see + -- track.md's DeltaQ appendix for the semantics). + echoResult <- processIngress rttState (msHeader sdu) recvTime + case echoResult of + EchoMatched rtt -> traceWith tracer $ + TraceRecvDeltaQObservation + (Mx.msNum sdu) + (Mx.mhLength (msHeader sdu)) + rtt + EchoBurstSDU gap -> traceWith tracer $ + TraceRecvBurstSDU + (Mx.msNum sdu) + (Mx.mhLength (msHeader sdu)) + gap + EchoNoSignal -> return () case lookupMiniProtocol dispatchTable (msNum sdu) -- Notice the mode reversal, ResponderDir is -- delivered to InitiatorDir and vice versa: diff --git a/network-mux/src/Network/Mux/RTT.hs b/network-mux/src/Network/Mux/RTT.hs index 85df4f29b6..3d31e0e3c8 100644 --- a/network-mux/src/Network/Mux/RTT.hs +++ b/network-mux/src/Network/Mux/RTT.hs @@ -36,6 +36,8 @@ module Network.Mux.RTT , RTTState , newRTTState , newSendCookie + , processIngress + , IngressEcho (..) , peerRTT -- * Configuration , defaultBucketDur @@ -43,6 +45,7 @@ module Network.Mux.RTT , defaultHoldDuration , defaultMaxOutstanding , defaultMintInterval + , defaultBurstMaxAge , RTTComp ) where @@ -105,6 +108,49 @@ defaultMaxOutstanding = 4096 defaultMintInterval :: DiffTime defaultMintInterval = 1e-3 +-- | Maximum lifetime of the "burst tracker" cache — once a matched +-- cookie has been sitting in the cache for longer than this, we +-- refuse to count further echoes of it as burst continuations. Bounds +-- the amount of extra observation an adversarial peer can synthesise +-- by echoing an old cookie in a loop. 1 s is generous for a +-- legitimate response burst (thousands of back-to-back SDUs at wire +-- speed) while cutting off replay abuse. +defaultBurstMaxAge :: DiffTime +defaultBurstMaxAge = 1 + + +-- | Bookkeeping for the last cookie we successfully matched — used +-- to recognise burst-continuation SDUs (subsequent responses from +-- the peer that echo the same cookie because they were emitted +-- before the peer had received a newer one from us). +data BurstTracker = BurstTracker + { btCookie :: !Cookie + -- ^ The most recently matched cookie. + , btFirstMatchTime :: !Time + -- ^ Local time at which we accepted the first echo of this + -- cookie; used against 'rttBurstMaxAge' to bound how long we + -- keep counting continuations. + , btLastEchoTime :: !Time + -- ^ Local time of the most recent echo (initial or + -- continuation); the next burst continuation's inter-SDU gap + -- is @now − btLastEchoTime@. + } + + +-- | Result of a single ingress-echo evaluation. +data IngressEcho + = -- | First echo of a cookie we sent — a round-trip sample. + EchoMatched !DiffTime + -- | A follow-up SDU from the peer echoing the same cookie whose + -- initial echo we already matched. The 'DiffTime' is the gap + -- between this SDU and the previous echo of the same cookie + -- (a peer-side inter-SDU serialisation interval), not a + -- round-trip. + | EchoBurstSDU !DiffTime + -- | Nothing useful: no match, and no active burst tracker. + | EchoNoSignal + deriving Show + -- | Internal per-mux RTT state. data RTTState m = RTTState { @@ -123,6 +169,10 @@ data RTTState m = RTTState { -- 'newSendCookie' for SDUs sent within 'rttMintInterval' of the -- previous mint. 'Nothing' before the first mint. , rttLastMinted :: !(StrictTVar m (Maybe (Cookie, Time))) + -- | Most recently matched cookie + timing (see 'BurstTracker'), + -- or 'Nothing' if none is being tracked. Cleared on age-out, on + -- a fresh match to a different cookie, and on unrelated misses. + , rttLastEcho :: !(StrictTVar m (Maybe BurstTracker)) -- | PRNG for cookie generation. , rttPRNG :: !(StrictTVar m StdGen) -- | Rolling t-digest window of RTT samples. @@ -133,6 +183,8 @@ data RTTState m = RTTState { , rttMaxOutstanding :: !Int -- | Cookie-reuse window; see 'defaultMintInterval'. , rttMintInterval :: !DiffTime + -- | Maximum age of the burst tracker; see 'defaultBurstMaxAge'. + , rttBurstMaxAge :: !DiffTime } @@ -147,6 +199,7 @@ newRTTState g = do rttLastPeerCookie <- newTVarIO noCookie rttOutstanding <- newTVarIO PSQ.empty rttLastMinted <- newTVarIO Nothing + rttLastEcho <- newTVarIO Nothing rttPRNG <- newTVarIO g rttWindow <- newTVarIO (DTB.empty defaultBucketDur defaultRetention) labelTVarIO rttLastPeerCookie "RTT.lastPeerCookie" @@ -165,6 +218,7 @@ newRTTState g = do rttHoldDuration = defaultHoldDuration, rttMaxOutstanding = defaultMaxOutstanding, rttMintInterval = defaultMintInterval, + rttBurstMaxAge = defaultBurstMaxAge } @@ -223,6 +277,71 @@ newSendCookie RTTState { rttLastPeerCookie Nothing -> psq +-- | Ingress processing: +-- +-- * Update 'rttLastPeerCookie' with 'mhSendCookie'. +-- * If mhEchoCookie appears in the outstanding set, compute RTT +-- (@now − sendTime@), sample the window, and age out outstanding +-- entries (delete-on-match + monotone-echo enforcement). Result +-- is 'EchoMatched'. +-- * If it doesn't, but the burst tracker still holds the same +-- cookie and hasn't aged out, emit an 'EchoBurstSDU' with the +-- inter-SDU gap. +-- * Otherwise 'EchoNoSignal'; age-out still runs on the +-- outstanding-store. +processIngress + :: MonadSTM m + => RTTState m + -> SDUHeader + -> Time + -> m IngressEcho +processIngress RTTState { rttLastPeerCookie + , rttOutstanding + , rttLastEcho + , rttWindow + , rttHoldDuration + , rttBurstMaxAge + } + SDUHeader { mhSendCookie, mhEchoCookie } + now + = atomically $ do + writeTVar rttLastPeerCookie mhSendCookie + outs0 <- readTVar rttOutstanding + mBurst <- readTVar rttLastEcho + -- TODO: be more clever about ageCutoff in an efficient way, + -- perhaps by taking into account rttOutstanding growth + let ageCutoff = negate rttHoldDuration `addTime` now + case PSQ.lookup mhEchoCookie outs0 of + Just (sendTime, ()) -> do + -- Fresh match: RTT sample, prune outstanding, reset burst tracker. + let cutoff = max sendTime ageCutoff + rtt = now `diffTime` sendTime + writeTVar rttOutstanding (snd (PSQ.atMostView cutoff outs0)) + writeTVar rttLastEcho $ Just BurstTracker + { btCookie = mhEchoCookie + , btFirstMatchTime = now + , btLastEchoTime = now + } + modifyTVar rttWindow (DTB.insert (now, realToFrac rtt)) + return (EchoMatched rtt) + Nothing -> do + -- Age-out runs regardless of whether the echo matched. + writeTVar rttOutstanding (snd (PSQ.atMostView ageCutoff outs0)) + case mBurst of + Just bt + | btCookie bt == mhEchoCookie + , now `diffTime` btFirstMatchTime bt <= rttBurstMaxAge -> do + let gap = now `diffTime` btLastEchoTime bt + writeTVar rttLastEcho $ Just bt { btLastEchoTime = now } + return (EchoBurstSDU gap) + _otherwise -> do + -- No live burst tracker for this cookie: clear the cache + -- (whether it held a stale different cookie or an expired + -- entry, we don't want it hanging around). + writeTVar rttLastEcho Nothing + return EchoNoSignal + + -- | Reader handle for consumers. peerRTT :: MonadSTM m => RTTState m -> PeerRTT m peerRTT RTTState { rttWindow } = PeerRTT $ \q -> do From ff95a280822d826c8e6c6f671290421a83efdddf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Thu, 16 Jul 2026 15:28:06 +0200 Subject: [PATCH 11/17] diffusion: entropy-seed the RTT-cookie PRNG through connection handlers To generate our cookies and prevent forgery attacks, we thread a PRNG from the top level, through connection handler, and into our mux. --- .../lib/Cardano/Network/NodeToClient.hs | 39 +++++++++++-------- .../lib/Cardano/Network/NodeToNode.hs | 9 +++-- network-mux/src/Network/Mux.hs | 8 ++-- .../Ouroboros/Network/ConnectionHandler.hs | 14 ++++++- .../lib/Ouroboros/Network/Server/Simple.hs | 3 ++ .../framework/lib/Ouroboros/Network/Socket.hs | 15 +++++-- .../lib/Ouroboros/Network/Diffusion.hs | 11 +++++- 7 files changed, 69 insertions(+), 30 deletions(-) diff --git a/cardano-diffusion/lib/Cardano/Network/NodeToClient.hs b/cardano-diffusion/lib/Cardano/Network/NodeToClient.hs index 5864d76eac..797fb48469 100644 --- a/cardano-diffusion/lib/Cardano/Network/NodeToClient.hs +++ b/cardano-diffusion/lib/Cardano/Network/NodeToClient.hs @@ -68,6 +68,7 @@ import Control.Monad.Class.MonadTimer.SI import Data.ByteString.Lazy qualified as BL import Data.Kind (Type) import Data.Void (Void, absurd) +import System.Random import Network.Mux qualified as Mx import Network.TypedProtocol.Peer.Client @@ -234,22 +235,24 @@ connectTo -> FilePath -- ^ path of the unix socket or named pipe -> IO (Either SomeException a) -connectTo snocket tracers versions path = +connectTo snocket tracers versions path = do + rttCookieSeed <- newStdGen fmap fn <$> - connectToNode - snocket - makeLocalBearer - ConnectToArgs { - ctaHandshakeCodec = nodeToClientHandshakeCodec, - ctaHandshakeTimeLimits = noTimeLimitsHandshake, - ctaVersionDataCodec = nodeToClientVersionDataCodec, - ctaConnectTracers = tracers, - ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion - } - mempty - versions - Nothing - (localAddressFromPath path) + connectToNode + snocket + makeLocalBearer + ConnectToArgs { + ctaHandshakeCodec = nodeToClientHandshakeCodec, + ctaHandshakeTimeLimits = noTimeLimitsHandshake, + ctaVersionDataCodec = nodeToClientVersionDataCodec, + ctaConnectTracers = tracers, + ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion, + ctaRTTCookieSeed = rttCookieSeed + } + mempty + versions + Nothing + (localAddressFromPath path) where fn :: forall x. Either x Void -> x fn = either id absurd @@ -284,7 +287,8 @@ connectToWithMux -- -- NOTE: when the callback returns or errors, the mux thread will be killed. -> IO x -connectToWithMux snocket tracers versions path k = +connectToWithMux snocket tracers versions path k = do + rttCookieSeed <- newStdGen connectToNodeWithMux snocket makeLocalBearer @@ -293,7 +297,8 @@ connectToWithMux snocket tracers versions path k = ctaHandshakeTimeLimits = noTimeLimitsHandshake, ctaVersionDataCodec = nodeToClientVersionDataCodec, ctaConnectTracers = tracers, - ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion + ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion, + ctaRTTCookieSeed = rttCookieSeed } mempty versions diff --git a/cardano-diffusion/lib/Cardano/Network/NodeToNode.hs b/cardano-diffusion/lib/Cardano/Network/NodeToNode.hs index 3c0ffd6387..181629dcdd 100644 --- a/cardano-diffusion/lib/Cardano/Network/NodeToNode.hs +++ b/cardano-diffusion/lib/Cardano/Network/NodeToNode.hs @@ -82,6 +82,7 @@ import Control.Exception (SomeException) import Data.ByteString.Lazy qualified as BL import Data.Set (Set) import Data.Word +import System.Random import Network.Mux qualified as Mx #if !defined(wasm32_HOST_ARCH) @@ -509,16 +510,18 @@ connectTo -> Socket.SockAddr -> IO (Either SomeException (Either a b)) #if !defined(wasm32_HOST_ARCH) -connectTo sn tr = +connectTo sn tr versions localAddr remoteAddr = do + rttCookieSeed <- newStdGen connectToNode sn makeSocketBearer ConnectToArgs { ctaHandshakeCodec = nodeToNodeHandshakeCodec, ctaHandshakeTimeLimits = timeLimitsHandshake, ctaVersionDataCodec = nodeToNodeVersionDataCodec, ctaConnectTracers = tr, - ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion + ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion, + ctaRTTCookieSeed = rttCookieSeed } - configureOutboundSocket + configureOutboundSocket versions localAddr remoteAddr where configureOutboundSocket :: Socket -> IO () configureOutboundSocket sock = do diff --git a/network-mux/src/Network/Mux.hs b/network-mux/src/Network/Mux.hs index 992a13d833..a2a2e5bfa0 100644 --- a/network-mux/src/Network/Mux.hs +++ b/network-mux/src/Network/Mux.hs @@ -10,8 +10,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} --- TODO: GHC-8.10 on Windows -{-# OPTIONS_GHC -Wno-name-shadowing #-} -- | Network multiplexer API. -- -- The module should be imported qualified. @@ -85,6 +83,8 @@ import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTimer.SI hiding (timeout) import Control.Tracer +import System.Random (StdGen) + import Network.Mux.Bearer import Network.Mux.Channel import Network.Mux.Egress as Egress @@ -143,11 +143,13 @@ stopped Mux { muxStatus } = new :: forall (mode :: Mode) m. MonadLabelledSTM m => Tracers m + -> StdGen + -- ^ seed for RTT-cookie generation -> [MiniProtocolInfo mode] -- ^ description of protocols run by the mux layer. Only these protocols -- one will be able to execute. -> m (Mux mode m) -new muxTracers ptcls = do +new muxTracers rttSeed ptcls = do traceWith (tracer_ muxTracers) (TraceNewMux ptcls) muxMiniProtocols <- mkMiniProtocolStateMap ptcls muxControlCmdQueue <- atomically newTQueue diff --git a/ouroboros-network/framework/lib/Ouroboros/Network/ConnectionHandler.hs b/ouroboros-network/framework/lib/Ouroboros/Network/ConnectionHandler.hs index 1adc70161e..d47e011839 100644 --- a/ouroboros-network/framework/lib/Ouroboros/Network/ConnectionHandler.hs +++ b/ouroboros-network/framework/lib/Ouroboros/Network/ConnectionHandler.hs @@ -58,6 +58,7 @@ import Data.Map (Map) import Data.Maybe.Strict import Data.Text (Text) import Data.Typeable (Typeable) +import System.Random (StdGen, splitGen) import Network.Mux (Mux) import Network.Mux qualified as Mx @@ -265,13 +266,18 @@ makeConnectionHandler -> (ThreadId m, RethrowPolicy) -- ^ 'ThreadId' and rethrow policy. Rethrow policy might throw an async -- exception to that thread, when trying to terminate the process. + -> StrictTVar m StdGen + -- ^ PRNG source for per-mux RTT-cookie seeds. Each invocation of + -- the returned handler atomically splits a fresh 'StdGen' out of + -- this TVar and passes it to 'Mx.new'. -> MkMuxConnectionHandler muxMode socket initiatorCtx responderCtx peerAddr versionNumber versionData ByteString m a b -> MuxConnectionHandler muxMode socket initiatorCtx responderCtx peerAddr versionNumber versionData ByteString m a b makeConnectionHandler muxTracers forkPolicy handshakeArguments versionedApplication - (mainThreadId, rethrowPolicy) = + (mainThreadId, rethrowPolicy) + rttCookieRngVar = \case MuxInitiatorConnectionHandler -> ConnectionHandler . WithInitiatorMode @@ -367,7 +373,9 @@ makeConnectionHandler muxTracers forkPolicy -- If this is InitiatorOnly, or a server where unidirectional flow was negotiated -- the IG will never be informed of this remote for obvious reasons. pure $ Mx.tracersWithBearer connectionId muxTracers - mux <- Mx.new muxTracers' (mkMiniProtocolInfos (runForkPolicy forkPolicy remoteAddress) app) + rttSeed <- atomically $ stateTVar rttCookieRngVar splitGen + mux <- Mx.new muxTracers' rttSeed + (mkMiniProtocolInfos (runForkPolicy forkPolicy remoteAddress) app) let !handle = Handle { hMux = mux, hMuxBundle = app, @@ -435,9 +443,11 @@ makeConnectionHandler muxTracers forkPolicy <*> newTVarIO Continue countersVar <- newTVarIO . SJust $ ResponderCounters 0 0 + rttSeed <- atomically $ stateTVar rttCookieRngVar splitGen mux <- Mx.new (Mx.tracersWithBearer connectionId muxTracers { Mx.tracer = Mx.tracer muxTracers <> inboundGovernorMuxTracer countersVar }) + rttSeed (mkMiniProtocolInfos (runForkPolicy forkPolicy remoteAddress) app) let !handle = Handle { diff --git a/ouroboros-network/framework/lib/Ouroboros/Network/Server/Simple.hs b/ouroboros-network/framework/lib/Ouroboros/Network/Server/Simple.hs index 44e426e423..65b658862d 100644 --- a/ouroboros-network/framework/lib/Ouroboros/Network/Server/Simple.hs +++ b/ouroboros-network/framework/lib/Ouroboros/Network/Server/Simple.hs @@ -26,6 +26,7 @@ import Data.ByteString.Lazy qualified as BL import Data.Functor (void) import Data.Typeable (Typeable) import Data.Void (Void) +import System.Random (mkStdGen) import Network.Mux qualified as Mx @@ -133,7 +134,9 @@ with sn tracer muxTracers makeBearer configureSock addr handshakeArgs versions k Left (HandshakeProtocolError e) -> throwIO e Right HandshakeQueryResult {} -> error "handshake query is not supported" Right (HandshakeNegotiationResult (SomeResponderApplication app) vNumber vData) -> do + -- TODO: entropy-seed the RTT PRNG. mux <- Mx.new (connId `Mx.tracersWithBearer` muxTracers) + (mkStdGen 0) (toMiniProtocolInfos (runForkPolicy noBindForkPolicy remoteAddress) app) diff --git a/ouroboros-network/framework/lib/Ouroboros/Network/Socket.hs b/ouroboros-network/framework/lib/Ouroboros/Network/Socket.hs index 246c48b97a..0d192858cf 100644 --- a/ouroboros-network/framework/lib/Ouroboros/Network/Socket.hs +++ b/ouroboros-network/framework/lib/Ouroboros/Network/Socket.hs @@ -77,6 +77,7 @@ import Data.Hashable import Data.Monoid.Synchronisation (FirstToFinish (..)) import Data.Typeable (Typeable) import Data.Word (Word16) +import System.Random (StdGen) #if !defined(wasm32_HOST_ARCH) import Network.Socket (SockAddr, Socket, StructLinger (..)) #else @@ -249,7 +250,11 @@ data ConnectToArgs m fd addr vNumber vData = ConnectToArgs { ctaHandshakeTimeLimits :: ProtocolTimeLimits (Handshake vNumber CBOR.Term), ctaVersionDataCodec :: VersionDataCodec vNumber vData, ctaConnectTracers :: NetworkConnectTracers m addr vNumber, - ctaHandshakeCallbacks :: HandshakeCallbacks vData + ctaHandshakeCallbacks :: HandshakeCallbacks vData, + ctaRTTCookieSeed :: StdGen + -- ^ PRNG seed for the connection's RTT-cookie generation. Callers + -- running in 'IO' can supply 'System.Random.newStdGen'; simulation + -- callers can pass a fixed 'mkStdGen'. } @@ -450,7 +455,8 @@ connectToNodeWithMux' nctMuxTracers, nctHandshakeTracer }, - ctaHandshakeCallbacks = handshakeCallbacks + ctaHandshakeCallbacks = handshakeCallbacks, + ctaRTTCookieSeed = rttCookieSeed } versions sd k = do connectionId <- (\localAddress remoteAddress -> ConnectionId { localAddress, remoteAddress }) @@ -483,7 +489,8 @@ connectToNodeWithMux' Right (HandshakeNegotiationResult app versionNumber agreedOptions) -> Mx.withReadBufferIO $ \buffer -> do bearer <- Mx.getBearer makeBearer sduTimeout sd buffer - mux <- Mx.new muxTracers (toMiniProtocolInfos (runForkPolicy noBindForkPolicy remoteAddress) app) + mux <- Mx.new muxTracers rttCookieSeed + (toMiniProtocolInfos (runForkPolicy noBindForkPolicy remoteAddress) app) withAsync (Mx.run mux bearer) $ \aid -> k connectionId versionNumber agreedOptions app mux aid @@ -514,7 +521,7 @@ simpleMuxCallback -> m (Either SomeException (Either a b)) simpleMuxCallback connectionId _ _ app mux aid = do let initCtx = MinimalInitiatorContext connectionId - respCtx = ResponderContext connectionId + respCtx = ResponderContext connectionId (Mx.peerRTT mux) resOps <- sequence [ Mx.runMiniProtocol diff --git a/ouroboros-network/lib/Ouroboros/Network/Diffusion.hs b/ouroboros-network/lib/Ouroboros/Network/Diffusion.hs index 4ed434a287..cd517d236d 100644 --- a/ouroboros-network/lib/Ouroboros/Network/Diffusion.hs +++ b/ouroboros-network/lib/Ouroboros/Network/Diffusion.hs @@ -272,7 +272,12 @@ runM Interfaces (fuzzRng, rng3) = splitGen rng2 (cmLocalStdGen, rng4) = splitGen rng3 (cmStdGen1, rng5) = splitGen rng4 - (cmStdGen2, peerSelectionActionsRng) = splitGen rng5 + (cmStdGen2, rng6) = splitGen rng5 + -- Per-connection RTT-cookie PRNG seeds: one shared TVar per CM. + -- Each mux instance atomically splits a fresh 'StdGen' out of the + -- appropriate TVar in 'makeConnectionHandler'. + (rttNtcSeed, rng7) = splitGen rng6 + (rttNtnSeed, peerSelectionActionsRng) = splitGen rng7 mkInboundPeersMap :: IG.PublicState ntnAddr ntnVersionData -> Map ntnAddr PeerSharing @@ -327,6 +332,7 @@ runM Interfaces mkLocalThread :: ThreadId m -> Either ntcFd ntcAddr -> m Void mkLocalThread mainThreadId localAddr = do labelThisThread "diffusion-local" + rttNtcCookieRngVar <- newTVarIO rttNtcSeed withLocalSocket tracer diNtcGetFileDescriptor diNtcConfigureSocketFile diNtcSnocket localAddr @@ -353,6 +359,7 @@ runM Interfaces (WithEstablished []) ) <$> daLocalResponderApplication ) (mainThreadId, rethrowPolicy <> daLocalRethrowPolicy) + rttNtcCookieRngVar (MuxResponderConnectionHandler responderMuxChannelTracer) localWithConnectionManager @@ -417,6 +424,7 @@ runM Interfaces mkRemoteThread :: ThreadId m -> m Void mkRemoteThread mainThreadId = do labelThisThread "diffusion-remote" + rttNtnCookieRngVar <- newTVarIO rttNtnSeed let exitPolicy :: ExitPolicy a exitPolicy = ExitPolicy { @@ -531,6 +539,7 @@ runM Interfaces daNtnHandshakeArguments versions (mainThreadId, rethrowPolicy <> daRethrowPolicy) + rttNtnCookieRngVar -- | Capture the two variations (InitiatorMode,InitiatorResponderMode) of -- withConnectionManager: From 2a7357d2f36344ad7c711eca25ce1d6ee5aa7301 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Thu, 16 Jul 2026 15:34:51 +0200 Subject: [PATCH 12/17] mux: enrich TraceRecvDeltaQObservation Adds MiniProtocolNum field so downstream trace consumers can bucket or filter per mini-protocol. This is the prerequisite for either for filtering out some protocols contributions, or bucketing them and pooling the aggregate. Add TraceRecvBurstSDU MiniProtocolNum Word16 DiffTime which allows us to recover burst-SDU per-byte cost via a separate through-origin estimator. --- .../src/Network/Mux/DeltaQ/TraceStats.hs | 260 +++++++++--------- .../Network/Mux/DeltaQ/TraceTransformer.hs | 49 +++- network-mux/src/Network/Mux/Types.hs | 37 ++- 3 files changed, 202 insertions(+), 144 deletions(-) diff --git a/network-mux/src/Network/Mux/DeltaQ/TraceStats.hs b/network-mux/src/Network/Mux/DeltaQ/TraceStats.hs index f6ddb7cbd8..cf1c721776 100644 --- a/network-mux/src/Network/Mux/DeltaQ/TraceStats.hs +++ b/network-mux/src/Network/Mux/DeltaQ/TraceStats.hs @@ -1,5 +1,8 @@ +{-# LANGUAGE BangPatterns #-} + module Network.Mux.DeltaQ.TraceStats ( step + , stepBurst , OneWayDeltaQSample (..) , constructSample , StatsA @@ -8,92 +11,118 @@ module Network.Mux.DeltaQ.TraceStats import Data.IntMap.Strict (IntMap) import Data.IntMap.Strict qualified as IM -import Data.Word (Word32) import Control.Monad.Class.MonadTime.SI import Network.Mux.DeltaQ.TraceStatsSupport import Network.Mux.DeltaQ.TraceTypes -import Network.Mux.Types - --- the per observation processing step -step :: RemoteClockModel -- ^ Remote clock timestamp - -> Time -- ^ Local clock timestamp - -> Int -- ^ the number of octets in the - -- observed outcome - -> StatsA -- ^ accumulation state + + +-- | Per-observation processing step for round-trip observations. +-- +-- Historically (pre-cookie-scheme) the first argument was the peer's +-- send timestamp; this module then translated it into the local +-- clock frame via a reference point to compute a one-way transit +-- time. That path was closed off when 'Network.Mux.RTT' replaced the +-- clock-domain timestamp with an opaque cookie. +-- +-- The step now accepts the *round-trip* delay directly — computed +-- from the local send/receive times of a cookie/echo pair — and +-- feeds the same 'estimateGS'-style accumulator. The resulting +-- 'OneWayDeltaQSample' remains meaningful, but its fields now +-- characterise round-trip behaviour rather than one-way transit; +-- consumers should re-interpret 'estDeltaQS' etc. as G/S estimates +-- of the round-trip signal. +step :: DiffTime -- ^ round-trip delay for this observation + -> Time -- ^ local clock time + -> Int -- ^ observed SDU size in octets + -> StatsA -- ^ accumulation state -> (Maybe OneWayDeltaQSample, StatsA) -step remoteTS localTS obsSize s = +step delay = withSamplePeriod update + where + !rtt = S $ realToFrac delay + update _localTS obsSize s = recordObservation s obsSize rtt + + +-- | Per-observation processing step for burst-continuation SDUs +-- (see 'IngressEcho'/'EchoBurstSDU' in "Network.Mux.RTT"). The +-- 'DiffTime' argument is the inter-SDU gap — the interval between +-- this SDU and the previous echo of the same cookie — which +-- approximates @S · size@ for the peer's outbound serialisation +-- with essentially no intercept G. +-- +-- Feeds a separate through-origin estimator ('estBurstS' on the +-- emitted sample) that shares the sample-period cadence with the +-- RTT-driven G/S regression but doesn't touch its accumulator. +stepBurst + :: DiffTime -- ^ inter-SDU gap + -> Time -- ^ local clock time + -> Int -- ^ observed SDU size in octets + -> StatsA + -> (Maybe OneWayDeltaQSample, StatsA) +stepBurst gap = withSamplePeriod update + where + !gapS = S $ realToFrac gap + update _localTS obsSize s = + s { burstSumSize = burstSumSize s + obsSize + , burstSumGap = burstSumGap s + gapS + , burstCount = succ (burstCount s) + } + + +-- | Common sample-period plumbing shared by 'step' and 'stepBurst'. +-- +-- Handles the "first observation of a period", "within period" and +-- "just past the period boundary" cases; delegates the +-- observation-kind-specific bookkeeping to the caller-supplied +-- 'update' function. +withSamplePeriod + :: (Time -> Int -> StatsA -> StatsA) -- ^ observation-specific update + -> Time -- ^ observation time + -> Int -- ^ observation size + -> StatsA + -> (Maybe OneWayDeltaQSample, StatsA) +withSamplePeriod update localTS obsSize s = case referenceTimePoint s of - Nothing -> -- first observation this sample period - step remoteTS localTS obsSize - (s { referenceTimePoint = Just $! (unRemoteClockModel remoteTS, localTS) - , nextSampleAt = sampleInterval `addTime` localTS - , timeLastObs = localTS -- for single observation in sample case - }) - Just refTimePoint | localTS <= nextSampleAt s -> -- still in a sample period - let transitTime = calcTransitTime refTimePoint remoteTS localTS - in (Nothing, recordObservation s localTS obsSize transitTime) - _ -> -- need to start next sample period - let sample = constructSample s - (_, s') = step remoteTS localTS obsSize initialStatsA - in (Just sample, s') - --- Calculate the transit time by transforming the remotely reported --- emit time into local clock domain then calculating differences. -calcTransitTime :: (Word32, Time) - -> RemoteClockModel - -> Time - -> SISec -calcTransitTime (remoteRefTS, localRefTS) remoteTS' localTS - = let remoteTS - = unRemoteClockModel remoteTS' - - remoteClockDiffAsTimeDiff :: Word32 -> DiffTime - remoteClockDiffAsTimeDiff - = (remoteClockPrecision *) . fromRational . fromIntegral - - correctedEmitTime :: Time - correctedEmitTime - | remoteTS >= remoteRefTS - = remoteClockDiffAsTimeDiff (remoteTS - remoteRefTS) - `addTime` localRefTS - | otherwise -- wrap has occurred - = remoteClockDiffAsTimeDiff (maxBound - (remoteRefTS - remoteTS)) - `addTime` localRefTS - in S $! fromRational (toRational (localTS `diffTime` correctedEmitTime)) - -recordObservation :: StatsA -> Time -> Int -> SISec -> StatsA -recordObservation s obsTime obsSize transitTime - = let f Nothing = Just $! makePerSizeRecord transitTime - f (Just a) = Just $! makePerSizeRecord transitTime <> a - in s { timeLastObs = obsTime - , numObservations = succ (numObservations s) + Nothing -> + -- first observation of a sample period + ( Nothing + , update localTS obsSize $ + s { referenceTimePoint = Just $! localTS + , nextSampleAt = sampleInterval `addTime` localTS + , timeLastObs = localTS + } + ) + Just _ | localTS <= nextSampleAt s -> + -- within the current period + (Nothing, update localTS obsSize s { timeLastObs = localTS }) + _ -> + -- past the current period: emit the built-up sample, restart. + let !sample = constructSample s + !fresh = initialStatsA { referenceTimePoint = Just $! localTS + , nextSampleAt = sampleInterval `addTime` localTS + , timeLastObs = localTS + } + in (Just sample, update localTS obsSize fresh) + + +recordObservation :: StatsA -> Int -> SISec -> StatsA +recordObservation s obsSize rtt + = let f Nothing = Just $! makePerSizeRecord rtt + f (Just a) = Just $! makePerSizeRecord rtt <> a + in s { numObservations = succ (numObservations s) , observables = IM.alter f obsSize (observables s) } --- This might benefit from some strictness analysis, what are the --- likely usage patterns?, do we want a single use collapse the --- collective set of thunks or not? --- --- There is the issue of "bias" (in its statistical meaning) here. The --- approach here is pragmatic, we are going to use the uncorrected --- sample standard deviation here as it has a defined solution for a --- single sample. --- --- Given that the consumer of this statistic also has access to the --- population size, they could reconstruct the underlying measures and --- take it from there. --- --- We return `NaN` for the appropriate statistics when the population --- is empty. + +-- | Consume the accumulator and produce a 'OneWayDeltaQSample'. constructSample :: StatsA -> OneWayDeltaQSample constructSample sa = OneWaySample - { duration = fromRational . toRational $ - maybe 0 (\(_,a) -> timeLastObs sa `diffTime` a) - (referenceTimePoint sa) + { duration = realToFrac $ + maybe 0 (timeLastObs sa `diffTime`) (referenceTimePoint sa) , sumPackets = population , sumTotalSDU = totalSDUOctets , estDeltaQS = normCheck dQSEst + , estBurstS = burstS , estDeltaQVMean = normCheck $ vSum / pop , estDeltaQVVar = normCheck $ (vSum2 - vSum * vSum / pop) / pop , estR = normCheck rEst @@ -150,63 +179,54 @@ constructSample sa = OneWaySample vCalc psr (x, x2) = (x + sumTransitTime psr, x2 + sumTransitTimeSq psr) --- | One way measurement for interval. Note that the fields are lazy --- here so that only calculation necessary to satisfy strictness of --- use occurs. + -- Burst-derived per-byte serialisation slope: Σ gap / Σ size. + -- Through-origin (no G intercept): burst-SDU gaps model the + -- peer's inter-SDU serialisation cost, not RTT. NaN when no + -- burst observations landed in this period. + burstS + | burstCount sa == 0 || burstSumSize sa == 0 = nan + | otherwise = + let S g = burstSumGap sa + in fromRational (toRational g) + / fromIntegral (burstSumSize sa) + + +-- | Round-trip characterisation over a sample interval. Field names +-- other than 'estBurstS' are preserved for downstream compatibility; +-- their semantics shifted from "one-way transit" to "round-trip" +-- with the cookie migration (see track.md). data OneWayDeltaQSample = OneWaySample { duration :: Double -- SI Seconds of activity captured , sumPackets :: Int , sumTotalSDU :: Int - , estDeltaQS :: Double -- octets per second + , estDeltaQS :: Double -- SI Seconds per byte of the peer's response, + -- derived from the (roundTrip ~ size) regression. + , estBurstS :: Double -- SI Seconds per byte, derived from burst-SDU + -- inter-SDU gaps only — a through-origin + -- estimator of peer-side serialisation cost + -- with no G intercept. NaN when the period saw + -- no burst continuations. , estDeltaQVMean :: Double -- SI Seconds , estDeltaQVVar :: Double , estR :: Double -- R estimate , sizeDist :: String -- temporary to show size distribution } --- | Statistics accumulator. Strict evaluation used to keep the memory --- footprint strictly bounded. + data StatsA = StatsA { -- per sample - referenceTimePoint :: !(Maybe (Word32, Time)) + referenceTimePoint :: !(Maybe Time) , nextSampleAt :: !Time -- per observation , numObservations :: !Int , timeLastObs :: !Time , observables :: !(IntMap PerSizeRecord) + -- burst-SDU accumulators (see 'stepBurst') + , burstSumSize :: !Int + , burstSumGap :: !SISec + , burstCount :: !Int } --- This _may_ not be the best representation, but it does appear to be --- an adequate one. There are known issues with numerical stability for --- this representation approach in floating point arithmetic where the --- values being measured are "large" and the variability in the sampled --- population is "small" (i.e the inherent rounding effect of floating --- point arithmetic has an effect). --- --- This is very unlikely to cause an issue here as: --- --- a) the modulo model of the RemoteClockModel (and hence the --- establishment of a clock reference offset for a given sample) --- means that we are only ever recording differences - thus any --- absolute clock differences get factored out. --- --- b) the transit delay for a measurement will be small, (probably --- not even credible) worst case ~10^3 / 10^4 seconds, the finite --- mantissa of IEEE754 --- (https://en.wikipedia.org/wiki/IEEE_754#Representation_and_encoding_in_memory) --- even for 32 bit representation (24bits / 7.22 decimal digits) --- represents an bound on the inherent measured population --- variability. --- --- c) longer term clock drift is covered here by the re-establishing --- of the clock reference offsets every sampling period. Given a --- reasonable sampling period (say 10 seconds) clock drift ( < --- 100ppm) can't amount to a significant error over such a period. --- --- To conclude, reasonable model of delay is < 1second, the precision --- of delay measurement is 10^-6 - this all fits nicely within a --- IEEE754 32bit representation with its 7.22 decimal digit --- mantissa. Haskell `Float`s are adequate for this purpose. data PerSizeRecord = PSR { minTransitTime :: !SISec @@ -236,7 +256,6 @@ normalisePSR norm psr } --- | Initial StatsA initialStatsA :: StatsA initialStatsA = StatsA { referenceTimePoint = Nothing @@ -244,6 +263,9 @@ initialStatsA = StatsA , numObservations = 0 , timeLastObs = noTime , observables = IM.empty + , burstSumSize = 0 + , burstSumGap = 0 + , burstCount = 0 } where noTime = Time 0 @@ -256,21 +278,11 @@ makePerSizeRecord tt = PSR , sumTransitTimeSq = squareSISec tt } --- May want to make this a configuration variable --- NOTE this interval must be less than the wrap around time of the --- `RemoteClockModel`. The remote clock model has a precision of --- `remoteClockPrecision`. +-- | Sample interval; a 'OneWayDeltaQSample' fires no more often than +-- this. Matches the pre-migration cadence. sampleInterval :: DiffTime -sampleInterval = check 10 - where - check n - | n > 0 && n < wrapInterval - = n - | otherwise - = error "Infeasible sampleInterval" - wrapInterval - = remoteClockPrecision * fromIntegral (unRemoteClockModel maxBound) +sampleInterval = 10 nan :: Double nan = 0/0 diff --git a/network-mux/src/Network/Mux/DeltaQ/TraceTransformer.hs b/network-mux/src/Network/Mux/DeltaQ/TraceTransformer.hs index 381c67012d..2c0dd55a82 100644 --- a/network-mux/src/Network/Mux/DeltaQ/TraceTransformer.hs +++ b/network-mux/src/Network/Mux/DeltaQ/TraceTransformer.hs @@ -8,6 +8,7 @@ module Network.Mux.DeltaQ.TraceTransformer ) where import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad.Class.MonadTime.SI import Control.Tracer import Data.Functor.Identity @@ -19,33 +20,60 @@ import Network.Mux.Types -- | Create a trace transformer that will emit -- `MuxTraceRecvDeltaQSample` no more frequently than every 10 -- seconds (when in use). -initDeltaQTracer :: MonadSTM m +initDeltaQTracer :: (MonadSTM m, MonadMonotonicTime m) => m (Tracer m BearerTrace -> Tracer m BearerTrace) initDeltaQTracer = dqTracer <$> newTVarIO initialStatsA -initDeltaQTracer' :: MonadSTM m +initDeltaQTracer' :: (MonadSTM m, MonadMonotonicTime m) => Tracer m BearerTrace -> m (Tracer m BearerTrace) initDeltaQTracer' tr = do v <- newTVarIO initialStatsA return $ dqTracer v tr -dqTracer :: MonadSTM m +-- The transformer now consumes round-trip observations produced by +-- 'Network.Mux.RTT.processIngress' — carried in +-- 'TraceRecvDeltaQObservation' as (SDU length, round-trip delay). +-- The one-way transit variant it used to derive from clock-domain +-- timestamps is gone (cookies carry no timing info); the G/S +-- estimates the accumulator produces now characterise round-trip +-- behaviour rather than one-way transit. +dqTracer :: (MonadSTM m, MonadMonotonicTime m) => StrictTVar m StatsA -> Tracer m BearerTrace -> Tracer m BearerTrace dqTracer sTvar tr = mkTracer go where - go (TraceRecvDeltaQObservation SDUHeader { mhTimestamp, mhLength } t) - = update mhTimestamp t (fromIntegral mhLength) + -- The 'MiniProtocolNum' is available on the observation but + -- currently ignored — bucketing / filtering per protocol is a + -- downstream concern (see the tx-submission-cleanup appendix in + -- track.md). All observations feed a single 'StatsA'. + -- The 'MiniProtocolNum' is available on both observation types + -- but currently ignored — bucketing / filtering per protocol is + -- a downstream concern (see the tx-submission-cleanup appendix + -- in track.md). All observations feed a single 'StatsA'. + go (TraceRecvDeltaQObservation _mpNum obsSize delay) = do + now <- getMonotonicTime + updateRTT delay now (fromIntegral obsSize) + >>= maybe (return ()) (traceWith tr . formatSample) + -- Burst-SDU gaps feed 'stepBurst', which populates a separate + -- through-origin estimator ('estBurstS' on the emitted sample). + -- Shares the sample-period cadence with the RTT stream via a + -- common 'withSamplePeriod' helper in 'TraceStats'. + go (TraceRecvBurstSDU _mpNum obsSize gap) = do + now <- getMonotonicTime + updateBurst gap now (fromIntegral obsSize) >>= maybe (return ()) (traceWith tr . formatSample) go te@TraceEmitDeltaQ = emitSample >> traceWith tr te go x - = traceWith tr x + = pure () + + updateRTT delay now n + = atomically (stateTVar sTvar (step delay now n)) - update rClock lClock n - = atomically (stateTVar sTvar (step rClock lClock n)) + updateBurst gap now n + = atomically (stateTVar sTvar (stepBurst gap now n)) emitSample = atomically (stateTVar sTvar processSample) @@ -56,11 +84,12 @@ dqTracer sTvar tr = mkTracer go formatSample (OneWaySample {..}) = TraceRecvDeltaQSample duration sumPackets sumTotalSDU - estDeltaQS estDeltaQVMean estDeltaQVVar + estDeltaQS estBurstS + estDeltaQVMean estDeltaQVVar estR sizeDist -initDeltaQTracers :: MonadSTM m +initDeltaQTracers :: (MonadSTM m, MonadMonotonicTime m) => Tracers m -> m (Tracers m) initDeltaQTracers tracers = do diff --git a/network-mux/src/Network/Mux/Types.hs b/network-mux/src/Network/Mux/Types.hs index 964ba67997..8666178e01 100644 --- a/network-mux/src/Network/Mux/Types.hs +++ b/network-mux/src/Network/Mux/Types.hs @@ -385,8 +385,23 @@ data ReadBuffer m = ReadBuffer { data BearerTrace = TraceRecvHeaderStart | TraceRecvHeaderEnd SDUHeader - | TraceRecvDeltaQObservation SDUHeader Time - | TraceRecvDeltaQSample Double Int Int Double Double Double Double String + -- | Round-trip observation for a received SDU whose echo cookie + -- matched an outstanding send: the mini-protocol number of the + -- SDU that carried the echo, its length in bytes, and the + -- measured round-trip delay. + | TraceRecvDeltaQObservation MiniProtocolNum Word16 DiffTime + -- | A follow-up SDU in a response burst: the peer echoed a + -- cookie whose first echo we already matched. The 'DiffTime' + -- is the gap between this SDU and the previous echo of the + -- same cookie (peer's inter-SDU serialisation interval), not + -- a round-trip. See track.md's DeltaQ-caveat appendix. + | TraceRecvBurstSDU MiniProtocolNum Word16 DiffTime + -- | Periodic DeltaQ sample. Fields: duration, sumPackets, + -- sumTotalSDU, estDeltaQS (RTT-derived seconds/byte), + -- estBurstS (burst-derived seconds/byte, NaN if no burst + -- observations this period), estDeltaQVMean, estDeltaQVVar, + -- estR, sizeDist. + | TraceRecvDeltaQSample Double Int Int Double Double Double Double Double String | TraceEmitDeltaQ | TraceRecvRaw Int | TraceRecvStart Int @@ -399,18 +414,20 @@ data BearerTrace = instance Show BearerTrace where show TraceRecvHeaderStart = printf "Bearer Receive Header Start" - show (TraceRecvHeaderEnd SDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = printf "Bearer Receive Header End: ts: 0x%08x (%s) %s len %d" - (unRemoteClockModel mhTimestamp) (show mhNum) (show mhDir) mhLength - show (TraceRecvDeltaQObservation SDUHeader { mhTimestamp, mhLength } ts) = printf "Bearer DeltaQ observation: remote ts %d local ts %s length %d" - (unRemoteClockModel mhTimestamp) (show ts) mhLength - show (TraceRecvDeltaQSample d sp so dqs dqvm dqvs estR sdud) = printf "Bearer DeltaQ Sample: duration %.3e packets %d sumBytes %d DeltaQ_S %.3e DeltaQ_VMean %.3e DeltaQ_VVar %.3e DeltaQ_estR %.3e sizeDist %s" - d sp so dqs dqvm dqvs estR sdud + show (TraceRecvHeaderEnd SDUHeader { mhSendCookie, mhEchoCookie, mhNum, mhDir, mhLength }) = printf "Bearer Receive Header End: send-cookie: %s echo-cookie: %s (%s) %s len %d" + (show mhSendCookie) (show mhEchoCookie) (show mhNum) (show mhDir) mhLength + show (TraceRecvDeltaQObservation mpNum len delay) = printf "Bearer DeltaQ observation: %s length %d round-trip %s" + (show mpNum) len (show delay) + show (TraceRecvBurstSDU mpNum len gap) = printf "Bearer Burst SDU: %s length %d gap %s" + (show mpNum) len (show gap) + show (TraceRecvDeltaQSample d sp so dqs bs dqvm dqvs estR sdud) = printf "Bearer DeltaQ Sample: duration %.3e packets %d sumBytes %d DeltaQ_S %.3e Burst_S %.3e DeltaQ_VMean %.3e DeltaQ_VVar %.3e DeltaQ_estR %.3e sizeDist %s" + d sp so dqs bs dqvm dqvs estR sdud show TraceEmitDeltaQ = "emit DeltaQ" show (TraceRecvRaw len) = printf "Bearer Receive Raw: length %d" len show (TraceRecvStart len) = printf "Bearer Receive Start: length %d" len show (TraceRecvEnd len) = printf "Bearer Receive End: length %d" len - show (TraceSendStart SDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = printf "Bearer Send Start: ts: 0x%08x (%s) %s length %d" - (unRemoteClockModel mhTimestamp) (show mhNum) (show mhDir) mhLength + show (TraceSendStart SDUHeader { mhSendCookie, mhEchoCookie, mhNum, mhDir, mhLength }) = printf "Bearer Send Start: send-cookie: %s echo-cookie: %s (%s) %s length %d" + (show mhSendCookie) (show mhEchoCookie) (show mhNum) (show mhDir) mhLength show TraceSendEnd = printf "Bearer Send End" show TraceSDUReadTimeoutException = "Timed out reading SDU" show TraceSDUWriteTimeoutException = "Timed out writing SDU" From 6071470781a7d4c7d47d5a0a71a09c67ac2281ce Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Thu, 16 Jul 2026 15:41:29 +0200 Subject: [PATCH 13/17] mux: new tests --- network-mux/test/Main.hs | 2 + network-mux/test/Test/Mux.hs | 87 ++++++++------ network-mux/test/Test/Mux/RTT.hs | 197 +++++++++++++++++++++++++++++++ 3 files changed, 251 insertions(+), 35 deletions(-) create mode 100644 network-mux/test/Test/Mux/RTT.hs diff --git a/network-mux/test/Main.hs b/network-mux/test/Main.hs index ce4000e741..cd180d56ec 100644 --- a/network-mux/test/Main.hs +++ b/network-mux/test/Main.hs @@ -3,6 +3,7 @@ module Main (main) where import Test.Tasty import Test.Mux qualified (tests) +import Test.Mux.RTT qualified (tests) import Test.Mux.Timeout qualified (tests) main :: IO () @@ -13,5 +14,6 @@ tests = testGroup "mux" [ -- network logic Test.Mux.tests + , Test.Mux.RTT.tests , Test.Mux.Timeout.tests ] diff --git a/network-mux/test/Test/Mux.hs b/network-mux/test/Test/Mux.hs index c60abd563f..184c847c64 100644 --- a/network-mux/test/Test/Mux.hs +++ b/network-mux/test/Test/Mux.hs @@ -79,9 +79,19 @@ import Network.Mux.Codec qualified as Mx import Network.Mux.Types (MiniProtocolInfo (..), MiniProtocolLimits (..)) import Network.Mux.Types qualified as Mx import Network.Socket qualified as Socket +import System.Random hiding (genByteString) import Text.Show.Functions () -- import qualified Debug.Trace as Debug + +-- | Deterministic 'Mx.new' for tests — every mux gets the same seed. +mkMux :: MonadLabelledSTM m + => Mx.Tracers m + -> [MiniProtocolInfo mode] + -> m (Mux mode m) +mkMux tracers = Mx.new tracers (mkStdGen 0) + + tests :: TestTree tests = testGroup "Mux" @@ -233,7 +243,8 @@ instance Arbitrary DummyRun where map DummyRun $ filter (not . null) a' data InvalidSDU = InvalidSDU { - isTimestamp :: !Mx.RemoteClockModel + isSendCookie :: !Mx.Cookie + , isEchoCookie :: !Mx.Cookie , isIdAndMode :: !Word16 , isLength :: !Word16 , isRealLength :: !Int @@ -241,8 +252,9 @@ data InvalidSDU = InvalidSDU { } instance Show InvalidSDU where - show a = printf "InvalidSDU 0x%08x 0x%04x 0x%04x 0x%04x 0x%02x\n" - (Mx.unRemoteClockModel $ isTimestamp a) + show a = printf "InvalidSDU 0x%04x 0x%04x 0x%04x 0x%04x 0x%04x 0x%02x\n" + (Mx.unCookie $ isSendCookie a) + (Mx.unCookie $ isEchoCookie a) (isIdAndMode a) (isLength a) (isRealLength a) @@ -274,17 +286,19 @@ instance Arbitrary ArbitrarySDU where return $ ArbitraryValidSDU (DummyPayload pl) (Just (Mx.IngressQueueOverRun (Mx.MiniProtocolNum 0) Mx.InitiatorDir)) unknownMiniProtocol = do - ts <- arbitrary + sendTs <- arbitrary + echoTs <- arbitrary mid <- choose (6, 0x7fff) -- ClientChainSynWithBlocks with 5 is the highest valid mid mode <- oneof [return 0x0, return 0x8000] len <- choose (1, 0xffff) p <- arbitrary - return $ ArbitraryInvalidSDU (InvalidSDU (Mx.RemoteClockModel ts) (mid .|. mode) len + return $ ArbitraryInvalidSDU (InvalidSDU (Mx.Cookie sendTs) (Mx.Cookie echoTs) (mid .|. mode) len (8 + fromIntegral len) p) (Mx.UnknownMiniProtocol (Mx.MiniProtocolNum 0)) invalidLenght = do - ts <- arbitrary + sendTs <- arbitrary + echoTs <- arbitrary mid <- arbitrary realLen <- choose (0, Mx.msHeaderLength) -- An SDU with a payload length of 0 is also invalid. @@ -294,7 +308,7 @@ instance Arbitrary ArbitrarySDU where else arbitrary p <- arbitrary - return $ ArbitraryInvalidSDU (InvalidSDU (Mx.RemoteClockModel ts) mid len (fromIntegral realLen) p) + return $ ArbitraryInvalidSDU (InvalidSDU (Mx.Cookie sendTs) (Mx.Cookie echoTs) mid len (fromIntegral realLen) p) (Mx.SDUDecodeError "") instance Arbitrary Mx.State where @@ -382,9 +396,9 @@ prop_mux_snd_recv (DummyRun messages) = ioProperty $ do miniProtocolCapability = Nothing } - clientMux <- Mx.new clientTracer [clientApp] + clientMux <- mkMux clientTracer [clientApp] - serverMux <- Mx.new serverTracer [serverApp] + serverMux <- mkMux serverTracer [serverApp] withAsync (Mx.run clientMux clientBearer) $ \clientAsync -> withAsync (Mx.run serverMux serverBearer) $ \serverAsync -> do @@ -471,10 +485,10 @@ prop_mux_snd_recv_bi (DummyRun messages) (DummyCapability clientCap) (DummyCapab ] - clientMux <- Mx.new clientTracer clientApps + clientMux <- mkMux clientTracer clientApps clientAsync <- async $ Mx.run clientMux clientBearer - serverMux <- Mx.new serverTracer serverApps + serverMux <- mkMux serverTracer serverApps serverAsync <- async $ Mx.run serverMux serverBearer r <- step clientMux clientApps serverMux serverApps messages @@ -571,7 +585,7 @@ prop_mux_snd_recv_compat messages = ioProperty $ do ] clientAsync <- async $ do - clientMux <- Mx.new clientTracer clientBundle + clientMux <- mkMux clientTracer clientBundle res <- Mx.runMiniProtocol clientMux (Mx.MiniProtocolNum 2) @@ -589,7 +603,7 @@ prop_mux_snd_recv_compat messages = ioProperty $ do wait aid serverAsync <- async $ do - serverMux <- Mx.new serverTracer serverBundle + serverMux <- mkMux serverTracer serverBundle res <- Mx.runMiniProtocol serverMux (Mx.MiniProtocolNum 2) @@ -761,7 +775,7 @@ runMuxApplication (DummyCapability rspCap) initApps initBearer respApps respBear respApps' = zip protNum respApps initApps' = zip protNum initApps - respMux <- Mx.new serverTracer $ map (\(pn,_) -> + respMux <- mkMux serverTracer $ map (\(pn,_) -> MiniProtocolInfo { miniProtocolNum = Mx.MiniProtocolNum pn, miniProtocolDir = Mx.ResponderDirectionOnly, @@ -780,7 +794,7 @@ runMuxApplication (DummyCapability rspCap) initApps initBearer respApps respBear | (pn, app) <- respApps' ] - initMux <- Mx.new clientTracer $ map (\(pn,_) -> + initMux <- mkMux clientTracer $ map (\(pn,_) -> MiniProtocolInfo { miniProtocolNum = Mx.MiniProtocolNum pn, miniProtocolDir = Mx.InitiatorDirectionOnly, @@ -1066,14 +1080,14 @@ prop_mux_starvation (Uneven response0 response1) = miniProtocolCapability = Nothing } - serverMux <- Mx.new serverTracer [serverApp2, serverApp3] + serverMux <- mkMux serverTracer [serverApp2, serverApp3] serverMux_aid <- async $ Mx.run serverMux serverBearer serverRes2 <- Mx.runMiniProtocol serverMux (miniProtocolNum serverApp2) (miniProtocolDir serverApp2) Mx.StartOnDemand server_short serverRes3 <- Mx.runMiniProtocol serverMux (miniProtocolNum serverApp3) (miniProtocolDir serverApp3) Mx.StartOnDemand server_long - clientMux <- Mx.new clientTracer [clientApp2, clientApp3] + clientMux <- mkMux clientTracer [clientApp2, clientApp3] clientMux_aid <- async $ Mx.run clientMux clientBearer clientRes2 <- Mx.runMiniProtocol clientMux (miniProtocolNum clientApp2) (miniProtocolDir clientApp2) Mx.StartEagerly client_short @@ -1144,7 +1158,8 @@ encodeInvalidMuxSDU sdu = BL.append header $ BL.replicate (fromIntegral $ isLength sdu) (isPattern sdu) where enc = do - Bin.putWord32be $ Mx.unRemoteClockModel $ isTimestamp sdu + Bin.putWord16be $ Mx.unCookie $ isSendCookie sdu + Bin.putWord16be $ Mx.unCookie $ isEchoCookie sdu Bin.putWord16be $ isIdAndMode sdu Bin.putWord16be $ isLength sdu @@ -1274,7 +1289,7 @@ prop_demux_sdu a = do } Nothing - serverMux <- Mx.new serverTracer [serverApp] + serverMux <- mkMux serverTracer [serverApp] serverRes <- Mx.runMiniProtocol serverMux (Mx.miniProtocolNum serverApp) (Mx.miniProtocolDir serverApp) Mx.StartEagerly server_mp @@ -1301,7 +1316,8 @@ prop_demux_sdu a = do let (!frag, !rest) = BL.splitAt 0xffff payload sdu' = Mx.SDU (Mx.SDUHeader - (Mx.RemoteClockModel 0) + Mx.noCookie + Mx.noCookie (Mx.MiniProtocolNum 2) Mx.InitiatorDir (fromIntegral $ BL.length frag)) @@ -1577,7 +1593,7 @@ prop_mux_restart_m (DummyRestartingInitiatorApps apps) = do Nothing let minis = map (appToInfo Mx.InitiatorDirectionOnly . fst) apps - mux <- Mx.new Mx.nullTracers minis + mux <- mkMux Mx.nullTracers minis mux_aid <- async $ Mx.run mux bearer getRes <- sequence [ Mx.runMiniProtocol mux @@ -1624,7 +1640,7 @@ prop_mux_restart_m (DummyRestartingResponderApps rapps) = do let apps = map fst rapps minis = map (appToInfo Mx.ResponderDirectionOnly) apps - mux <- Mx.new Mx.nullTracers minis + mux <- mkMux Mx.nullTracers minis mux_aid <- async $ Mx.run mux bearer getRes <- sequence [ Mx.runMiniProtocol mux @@ -1674,7 +1690,7 @@ prop_mux_restart_m (DummyRestartingInitiatorResponderApps rapps) = do initMinis = map (appToInfo Mx.InitiatorDirection) apps respMinis = map (appToInfo Mx.ResponderDirection) apps - mux <- Mx.new Mx.nullTracers $ initMinis ++ respMinis + mux <- mkMux Mx.nullTracers $ initMinis ++ respMinis mux_aid <- async $ Mx.run mux bearer getInitRes <- sequence [ Mx.runMiniProtocol mux @@ -1760,7 +1776,7 @@ prop_mux_start_m bearer _ checkRes (DummyInitiatorApps apps) runTime _ = do let minis = map (appToInfo Mx.InitiatorDirectionOnly) apps minRunTime = minimum $ runTime : (map daRunTime $ filter (\app -> daAction app == DummyAppFail) apps) - mux <- Mx.new Mx.nullTracers minis + mux <- mkMux Mx.nullTracers minis mux_aid <- async $ Mx.run mux bearer killer <- async $ (threadDelay runTime) >> Mx.stop mux getRes <- sequence [ Mx.runMiniProtocol @@ -1784,7 +1800,7 @@ prop_mux_start_m bearer trigger checkRes (DummyResponderApps apps) runTime anySt _ -> daRunTime a + daStartAfter a ) $ filter (\app -> daAction app == DummyAppFail) apps) - mux <- Mx.new muxVerboseTracer minis + mux <- mkMux muxVerboseTracer minis mux_aid <- async $ Mx.run mux bearer getRes <- sequence [ Mx.runMiniProtocol mux @@ -1814,7 +1830,7 @@ prop_mux_start_m bearer _trigger _checkRes (DummyResponderAppsKillMux apps) runT -- not deadlocks. let minis = map (appToInfo Mx.ResponderDirectionOnly) apps - mux <- Mx.new muxVerboseTracer minis + mux <- mkMux muxVerboseTracer minis mux_aid <- async $ Mx.run mux bearer getRes <- sequence [ Mx.runMiniProtocol mux @@ -1837,7 +1853,7 @@ prop_mux_start_m bearer trigger checkRes (DummyInitiatorResponderApps apps) runT respMinis = map (appToInfo Mx.ResponderDirection) apps minRunTime = minimum $ runTime : (map (\a -> daRunTime a) $ filter (\app -> daAction app == DummyAppFail) apps) - mux <- Mx.new muxVerboseTracer $ initMinis ++ respMinis + mux <- mkMux muxVerboseTracer $ initMinis ++ respMinis mux_aid <- async $ Mx.run mux bearer getInitRes <- sequence [ Mx.runMiniProtocol mux @@ -2012,7 +2028,7 @@ close_experiment serverMuxTracer = Mx.TracersI serverMuxTracer' nullTracer nullTracer withAsync -- run client thread - (bracket (Mx.new clientMuxTracer + (bracket (mkMux clientMuxTracer [ MiniProtocolInfo { miniProtocolNum, miniProtocolDir = Mx.InitiatorDirectionOnly, @@ -2032,7 +2048,7 @@ close_experiment $ \clientAsync -> withAsync -- run server thread - (bracket ( Mx.new serverMuxTracer + (bracket ( mkMux serverMuxTracer [ MiniProtocolInfo { miniProtocolNum, miniProtocolDir = Mx.ResponderDirectionOnly, @@ -2466,7 +2482,7 @@ prop_mux_trailing_bytes reminder (NonEmptyByteString received) = do (-1) QueueChannel { writeQueue = mux_w, readQueue = mux_r } Nothing - mux <- Mx.new Mx.nullTracers + mux <- mkMux Mx.nullTracers [ MiniProtocolInfo { miniProtocolNum, miniProtocolDir = Mx.ResponderDirectionOnly, @@ -2488,10 +2504,11 @@ prop_mux_trailing_bytes reminder (NonEmptyByteString received) = do $ writeTBQueue mux_r $ Mx.encodeSDU $ Mx.SDU { Mx.msHeader = Mx.SDUHeader { - Mx.mhTimestamp = Mx.RemoteClockModel 0, - Mx.mhNum = miniProtocolNum, - Mx.mhDir = Mx.InitiatorDir, - Mx.mhLength = fromIntegral (BL.length received) + Mx.mhSendCookie = Mx.noCookie, + Mx.mhEchoCookie = Mx.noCookie, + Mx.mhNum = miniProtocolNum, + Mx.mhDir = Mx.InitiatorDir, + Mx.mhLength = fromIntegral (BL.length received) }, Mx.msBlob = received } @@ -2575,7 +2592,7 @@ prop_mux_pure_exception = do (-1) QueueChannel { writeQueue = mux_w, readQueue = mux_r } Nothing - mux <- Mx.new Mx.nullTracers -- { Mx.tracer = Tracer Debug.traceShowM } + mux <- mkMux Mx.nullTracers -- { Mx.tracer = Tracer Debug.traceShowM } [ MiniProtocolInfo { miniProtocolNum, miniProtocolDir = Mx.ResponderDirectionOnly, diff --git a/network-mux/test/Test/Mux/RTT.hs b/network-mux/test/Test/Mux/RTT.hs new file mode 100644 index 0000000000..795c1a09cd --- /dev/null +++ b/network-mux/test/Test/Mux/RTT.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Mux.RTT (tests) where + +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad.Class.MonadTime.SI +import Control.Monad.IOSim + +import System.Random + +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck + +import Network.Mux.RTT +import Network.Mux.Types + + +tests :: TestTree +tests = testGroup "RTT" + [ testProperty "matched echo yields expected RTT sample" + prop_rtt_matchedEcho + , testProperty "unknown echo cookies drop the sample" + prop_rtt_unknownEchoNoSample + , testProperty "last-peer-cookie reflects freshest send" + prop_rtt_lastPeerCookie + , testProperty "match-on-match prunes older outstanding cookies" + prop_rtt_pruneOnMatch + , testProperty "sub-interval sends reuse the same cookie" + prop_rtt_mintReuse + , testProperty "burst continuation reports inter-SDU gap" + prop_rtt_burstContinuation + , testProperty "burst tracker ages out after 'rttBurstMaxAge'" + prop_rtt_burstMaxAgeEviction + ] + + +-- | Blank SDU header carrying a specific (send, echo) cookie pair. +mkHdr :: Cookie -> Cookie -> SDUHeader +mkHdr s e = SDUHeader { + mhSendCookie = s + , mhEchoCookie = e + , mhNum = MiniProtocolNum 42 + , mhDir = InitiatorDir + , mhLength = 0 + } + + +isNoSignal :: IngressEcho -> Bool +isNoSignal EchoNoSignal = True +isNoSignal _ = False + + +-- | Draw a fresh cookie from egress at a known @sendTime@, wait +-- @rttMs@ milliseconds, then feed an ingress SDU echoing that cookie. +-- 'peerRTT' at 0.5 should return within a coarse tolerance of +-- @rttMs / 1000@. +prop_rtt_matchedEcho :: Property +prop_rtt_matchedEcho = + forAll (choose (1, 500 :: Int)) $ \rttMs -> + let sendTime = Time 0.100 + recvTime = Time (0.100 + fromIntegral rttMs / 1000) + expected = fromIntegral rttMs / 1000 :: Double + in runSimOrThrow $ do + st <- newRTTState (mkStdGen 42) + (cookie, _) <- atomically $ newSendCookie st sendTime + _ <- processIngress st (mkHdr noCookie cookie) recvTime + result <- atomically $ readPeerRTTQuantile (peerRTT st) 0.5 + return $ case result of + Nothing -> + counterexample "no RTT sample recorded" False + Just d -> + let got = realToFrac d :: Double + in counterexample + ("expected " ++ show expected ++ ", got " ++ show got) $ + abs (got - expected) <= 1e-6 + + +-- | An ingress SDU whose 'mhEchoCookie' doesn't match anything we +-- sent produces no RTT sample. (Combined with 'noCookie' sentinel: +-- that case must also drop the sample.) +prop_rtt_unknownEchoNoSample :: Property +prop_rtt_unknownEchoNoSample = once $ runSimOrThrow $ do + st <- newRTTState (mkStdGen 7) + _ <- processIngress st (mkHdr (Cookie 100) noCookie) (Time 0.001) + _ <- processIngress st (mkHdr (Cookie 200) (Cookie 999)) (Time 0.002) + result <- atomically $ readPeerRTTQuantile (peerRTT st) 0.5 + return $ counterexample + ("expected Nothing, got " ++ show result) $ + result == Nothing + + +-- | Ingress writes 'mhSendCookie' into the last-peer-cookie TVar. On +-- the next 'newSendCookie', that value is what we echo back. +prop_rtt_lastPeerCookie :: Property +prop_rtt_lastPeerCookie = once $ runSimOrThrow $ do + st <- newRTTState (mkStdGen 3) + _ <- processIngress st (mkHdr (Cookie 100) noCookie) (Time 0.001) + _ <- processIngress st (mkHdr (Cookie 200) noCookie) (Time 0.002) + (_, echo) <- atomically $ newSendCookie st (Time 0.003) + return $ counterexample + ("expected Cookie 200, got " ++ show echo) $ + echo == Cookie 200 + + +-- | Once we accept an echo for cookie C₂ (sent after C₁), C₁ must +-- have been pruned from outstanding — a subsequent echo of C₁ +-- (violating the peer's monotone-echo invariant) finds nothing and +-- yields no additional sample. +prop_rtt_pruneOnMatch :: Property +prop_rtt_pruneOnMatch = once $ runSimOrThrow $ do + st <- newRTTState (mkStdGen 11) + (c1, _) <- atomically $ newSendCookie st (Time 0.010) + (c2, _) <- atomically $ newSendCookie st (Time 0.020) + -- Accept echo of c2 first (matches, prunes c1 too). + EchoMatched _ <- processIngress st (mkHdr noCookie c2) (Time 0.050) + -- Now a stale echo of c1 must NOT produce a sample; c1 is not in + -- outstanding, and it's not the tracked burst cookie either + -- (c2 is). + m <- processIngress st (mkHdr noCookie c1) (Time 0.060) + return $ counterexample + ("expected EchoNoSignal for stale c1 echo") $ + isNoSignal m + + +-- | Two successive 'newSendCookie' calls within 'defaultMintInterval' +-- return the same cookie, and only one entry lands in outstanding +-- (verified by matching that cookie once and seeing the second +-- echo turn into a burst-SDU sample rather than a fresh match). +prop_rtt_mintReuse :: Property +prop_rtt_mintReuse = once $ runSimOrThrow $ do + st <- newRTTState (mkStdGen 5) + -- Two sends 0.1 ms apart — well inside the 1 ms mint interval. + (c1, _) <- atomically $ newSendCookie st (Time 0.001) + (c2, _) <- atomically $ newSendCookie st (Time 0.0011) + let reused = c1 == c2 + -- First echo of the shared cookie: fresh RTT match. + r1 <- processIngress st (mkHdr noCookie c1) (Time 0.010) + -- Second echo: the cookie has been deleted from outstanding + -- (prune-on-match), but the burst tracker is fresh, so we get an + -- EchoBurstSDU rather than a second EchoMatched. + r2 <- processIngress st (mkHdr noCookie c2) (Time 0.011) + return $ counterexample + ("c1=" ++ show c1 ++ " c2=" ++ show c2 ++ + " r1 matched: " ++ show (case r1 of EchoMatched _ -> True; _ -> False) ++ + " r2 burst: " ++ show (case r2 of EchoBurstSDU _ -> True; _ -> False)) $ + reused + .&&. (case r1 of EchoMatched _ -> True; _ -> False) + .&&. (case r2 of EchoBurstSDU _ -> True; _ -> False) + + +-- | A response burst — first SDU produces a fresh RTT match, the +-- second and third SDUs that echo the same cookie produce +-- 'EchoBurstSDU' samples whose gap equals the interval between +-- successive ingress arrivals. +prop_rtt_burstContinuation :: Property +prop_rtt_burstContinuation = once $ runSimOrThrow $ do + st <- newRTTState (mkStdGen 13) + (c, _) <- atomically $ newSendCookie st (Time 0.010) + r1 <- processIngress st (mkHdr noCookie c) (Time 0.100) + r2 <- processIngress st (mkHdr noCookie c) (Time 0.101) + r3 <- processIngress st (mkHdr noCookie c) (Time 0.103) + return $ conjoin + [ counterexample ("r1 not EchoMatched: " ++ show r1) $ + case r1 of EchoMatched _ -> True; _ -> False + , counterexample ("r2 not EchoBurstSDU with gap ≈ 1 ms") $ + case r2 of + EchoBurstSDU gap -> + abs (realToFrac gap - (1e-3 :: Double)) <= 1e-9 + _ -> False + , counterexample ("r3 not EchoBurstSDU with gap ≈ 2 ms") $ + case r3 of + EchoBurstSDU gap -> + abs (realToFrac gap - (2e-3 :: Double)) <= 1e-9 + _ -> False + ] + + +-- | After 'defaultBurstMaxAge' seconds elapse from the first echo, +-- further echoes of the same cookie are dropped even though the +-- burst tracker would have kept accepting them. +prop_rtt_burstMaxAgeEviction :: Property +prop_rtt_burstMaxAgeEviction = once $ runSimOrThrow $ do + st <- newRTTState (mkStdGen 17) + (c, _) <- atomically $ newSendCookie st (Time 0) + r1 <- processIngress st (mkHdr noCookie c) (Time 0.100) + -- Well past the 1 s default 'defaultBurstMaxAge' since the first + -- match; the burst tracker must be evicted, not renewed. + rLate <- processIngress st (mkHdr noCookie c) (Time 2.000) + return $ conjoin + [ counterexample ("r1 not EchoMatched: " ++ show r1) $ + case r1 of EchoMatched _ -> True; _ -> False + , counterexample ("late echo should be EchoNoSignal") $ + isNoSignal rLate + ] From 5bd568bdd92e8a88081b50a36436d0b48ce69b32 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Thu, 16 Jul 2026 15:40:59 +0200 Subject: [PATCH 14/17] mux: integrate into existing test suite --- network-mux/bench/socket_read_write/Main.hs | 23 ++++++++++++------- network-mux/demo/mux-demo.hs | 7 ++++-- network-mux/demo/mux-leios-demo.hs | 13 +++++++---- .../tests/io/Test/Ouroboros/Network/Socket.hs | 1 + 4 files changed, 30 insertions(+), 14 deletions(-) diff --git a/network-mux/bench/socket_read_write/Main.hs b/network-mux/bench/socket_read_write/Main.hs index 02a9262ced..d3c45ce8b5 100644 --- a/network-mux/bench/socket_read_write/Main.hs +++ b/network-mux/bench/socket_read_write/Main.hs @@ -25,9 +25,12 @@ import Network.Mux import Network.Mux.Bearer import Network.Mux.Egress import Network.Mux.Ingress -import Network.Mux.Timeout (withTimeoutSerial) +import Network.Mux.RTT +import Network.Mux.Timeout import Network.Mux.Types +import System.Random + activeTracer :: Tracer IO a activeTracer = nullTracer --activeTracer = show >$< stdoutTracer @@ -82,7 +85,8 @@ readDemuxerQueueBenchmark sndSizeV sndSize addr = do withReadBufferIO (\buffer -> do bearer <- getBearer makeSocketBearer sduTimeout sd buffer ms42 <- mkMiniProtocolState 42 - withAsync (demuxer [ms42] activeTracer bearer) $ \aid -> do + rtt <- newRTTState (mkStdGen 0) + withAsync (demuxer [ms42] rtt activeTracer bearer) $ \aid -> do doRead 0xa5 (totalPayloadLen sndSize) (miniProtocolIngressQueue ms42) cancel aid ) @@ -115,7 +119,8 @@ readDemuxerBenchmark sndSizeV sndSize addr = do bearer <- getBearer makeSocketBearer sduTimeout sd buffer ms42 <- mkMiniProtocolState 42 ms41 <- mkMiniProtocolState 41 - withAsync (demuxer [ms41, ms42] activeTracer bearer) $ \aid -> do + rtt <- newRTTState (mkStdGen 0) + withAsync (demuxer [ms41, ms42] rtt activeTracer bearer) $ \aid -> do withAsync (doRead 42 (totalPayloadLen sndSize) (miniProtocolIngressQueue ms42) 0) $ \aid42 -> do withAsync (doRead 41 (totalPayloadLen 10) (miniProtocolIngressQueue ms41) 0) $ \aid41 -> do _ <- waitBoth aid42 aid41 @@ -190,10 +195,11 @@ startServerMany sndSizeV ad = forever $ do wrap blob = SDU { -- it will be filled when the 'SDU' is send by the 'bearer' msHeader = SDUHeader { - mhTimestamp = RemoteClockModel 0, - mhNum = MiniProtocolNum 42, - mhDir = ResponderDir, - mhLength = fromIntegral $ BL.length blob + mhSendCookie = noCookie, + mhEchoCookie = noCookie, + mhNum = MiniProtocolNum 42, + mhDir = ResponderDir, + mhLength = fromIntegral $ BL.length blob }, msBlob = blob } @@ -217,7 +223,8 @@ startServerEgresss pollInterval sndSizeV ad = forever $ do numberOfCalls = numberOfSdus `div` 10 :: Int runtSdus = numberOfSdus `mod` 10 :: Int - withAsync (muxer eq activeTracer bearer) $ \aid -> do + rtt <- newRTTState (mkStdGen 0) + withAsync (muxer eq rtt activeTracer bearer) $ \aid -> do replicateM_ numberOfCalls $ do let payload42s = replicate 10 $ BL.replicate sndSize 42 diff --git a/network-mux/demo/mux-demo.hs b/network-mux/demo/mux-demo.hs index 60e590db5f..1a9b085bc4 100644 --- a/network-mux/demo/mux-demo.hs +++ b/network-mux/demo/mux-demo.hs @@ -24,6 +24,7 @@ import Control.Tracer (Tracer, mkTracer) import System.Environment qualified as SysEnv import System.Exit import System.IO +import System.Random #if defined(mingw32_HOST_OS) import Data.Bits @@ -127,7 +128,8 @@ server = do serverWorker :: Bearer IO -> IO () serverWorker bearer = do - mux <- Mx.new Mx.nullTracers ptcls + g <- newStdGen + mux <- Mx.new Mx.nullTracers g ptcls void $ forkIO $ do awaitResult <- @@ -187,7 +189,8 @@ client n msg = do clientWorker :: Mx.Bearer IO -> Int -> String -> IO () clientWorker bearer n msg = do - mux <- Mx.new Mx.nullTracers ptcls + g <- newStdGen + mux <- Mx.new Mx.nullTracers g ptcls void $ forkIO $ do awaitResult <- diff --git a/network-mux/demo/mux-leios-demo.hs b/network-mux/demo/mux-leios-demo.hs index 44c47eee74..8b399697d3 100644 --- a/network-mux/demo/mux-leios-demo.hs +++ b/network-mux/demo/mux-leios-demo.hs @@ -27,6 +27,7 @@ import Control.Tracer import System.Environment qualified as SysEnv import System.Exit import System.IO +import System.Random import Network.Socket (PortNumber) import Network.Socket qualified as Socket @@ -182,7 +183,8 @@ server ct ip port num len1 len2 = serverWorkerSequential :: Bearer IO -> Int -> Int -> IO () serverWorkerSequential bearer len1 len2 = do debugPutStrLn_ $ "server: " ++ show (len1, len2) - mux <- Mx.new Mx.nullTracers (protocols ResponderDirectionOnly) + g <- newStdGen + mux <- Mx.new Mx.nullTracers g (protocols ResponderDirectionOnly) void $ forkIO $ do awaitResult1 <- runMiniProtocol @@ -224,7 +226,8 @@ serverWorkerSequential bearer len1 len2 = do serverWorkerBursty :: Bearer IO -> (Int, Int) -> Int -> Int -> IO () serverWorkerBursty bearer (n1, n2) len1 len2 = do debugPutStrLn_ $ "server: " ++ show (len1, len2) - mux <- Mx.new Mx.nullTracers (protocols ResponderDirectionOnly) + g <- newStdGen + mux <- Mx.new Mx.nullTracers g (protocols ResponderDirectionOnly) void $ forkIO $ do awaitResult1 <- runMiniProtocol @@ -301,7 +304,8 @@ clientWorkerSequential -- ^ number of requests to send over `MiniProtocolNum 3` -> IO () clientWorkerSequential bearer len n1 n2 = do - mux <- Mx.new Mx.nullTracers (protocols InitiatorDirectionOnly) + g <- newStdGen + mux <- Mx.new Mx.nullTracers g (protocols InitiatorDirectionOnly) void $ forkIO $ do awaitResult1 <- runMiniProtocol @@ -341,7 +345,8 @@ clientWorkerSequential bearer len n1 n2 = do clientWorkerBursty :: Mx.Bearer IO -> IO () clientWorkerBursty bearer = do - mux <- Mx.new Mx.nullTracers (protocols InitiatorDirectionOnly) + g <- newStdGen + mux <- Mx.new Mx.nullTracers g (protocols InitiatorDirectionOnly) void $ forkIO $ do awaitResult1 <- runMiniProtocol diff --git a/ouroboros-network/tests/io/Test/Ouroboros/Network/Socket.hs b/ouroboros-network/tests/io/Test/Ouroboros/Network/Socket.hs index e8b4a7f9f2..4d593d1607 100644 --- a/ouroboros-network/tests/io/Test/Ouroboros/Network/Socket.hs +++ b/ouroboros-network/tests/io/Test/Ouroboros/Network/Socket.hs @@ -56,6 +56,7 @@ import Ouroboros.Network.Util.ShowProxy import Test.Ouroboros.Network.Serialise +import System.Random import Test.QuickCheck import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) From 926d0deebaafa7b439478e2bf24bedc7288d8621 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Thu, 16 Jul 2026 15:43:11 +0200 Subject: [PATCH 15/17] integrate into existing test and benchmark suite --- cardano-diffusion/demo/chain-sync.hs | 33 +++++---- .../ping/Cardano/Network/Ping.hs | 3 + .../Diffusion/Testnet/MiniProtocols.hs | 12 ++-- ouroboros-network/demo/connection-manager.hs | 7 +- ouroboros-network/demo/ping-pong.hs | 68 ++++++++++--------- ouroboros-network/demo/tx-submission/main.hs | 7 +- .../io-tests/Test/Ouroboros/Network/Socket.hs | 22 +++--- .../Test/Simulation/Network/Snocket.hs | 4 ++ .../Network/ConnectionManager/Experiments.hs | 26 ++++--- .../tests/io/Test/Ouroboros/Network/Pipe.hs | 7 +- .../tests/io/Test/Ouroboros/Network/Socket.hs | 4 +- .../tests/lib/Test/Ouroboros/Network/Mux.hs | 8 ++- 12 files changed, 120 insertions(+), 81 deletions(-) diff --git a/cardano-diffusion/demo/chain-sync.hs b/cardano-diffusion/demo/chain-sync.hs index 3e18fb9934..fa823609a3 100644 --- a/cardano-diffusion/demo/chain-sync.hs +++ b/cardano-diffusion/demo/chain-sync.hs @@ -35,8 +35,7 @@ import Control.Monad.Class.MonadTime.SI (Time (..)) import Control.Tracer import System.Directory -import System.Random (RandomGen, SplitGen, StdGen) -import System.Random qualified as Random +import System.Random import Options.Applicative qualified as Opts @@ -228,6 +227,7 @@ clientChainSync :: [FilePath] clientChainSync sockPaths maxSlotNo = withIOManager $ \iocp -> forConcurrently_ (zip [0..] sockPaths) $ \(index, sockPath) -> do threadDelay (50000 * index) + rttCookieSeed <- newStdGen void $ connectToNode (localSnocket iocp) makeLocalBearer @@ -236,7 +236,8 @@ clientChainSync sockPaths maxSlotNo = withIOManager $ \iocp -> ctaHandshakeTimeLimits = noTimeLimitsHandshake, ctaVersionDataCodec = unversionedProtocolDataCodec, ctaConnectTracers = nullNetworkConnectTracers, - ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion + ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion, + ctaRTTCookieSeed = rttCookieSeed } mempty (simpleSingletonVersions @@ -263,8 +264,8 @@ serverChainSync :: FilePath -> IO Void serverChainSync sockAddr slotLength seed = withIOManager $ \iocp -> do prng <- case seed of - Nothing -> Random.initStdGen - Just a -> return (Random.mkStdGen a) + Nothing -> initStdGen + Just a -> return (mkStdGen a) Server.Simple.with (localSnocket iocp) nullTracer @@ -479,8 +480,9 @@ clientBlockFetch sockAddrs maxSlotNo = withIOManager $ \iocp -> do chainSelection fingerprint' peerAsyncs <- sequence - [ async . void $ - connectToNode + [ async $ do + rttCookieSeed <- newStdGen + void $ connectToNode (localSnocket iocp) makeLocalBearer ConnectToArgs { @@ -488,7 +490,8 @@ clientBlockFetch sockAddrs maxSlotNo = withIOManager $ \iocp -> do ctaHandshakeTimeLimits = noTimeLimitsHandshake, ctaVersionDataCodec = unversionedProtocolDataCodec, ctaConnectTracers = nullNetworkConnectTracers, - ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion + ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion, + ctaRTTCookieSeed = rttCookieSeed } mempty (simpleSingletonVersions @@ -543,8 +546,8 @@ serverBlockFetch :: FilePath -> IO Void serverBlockFetch sockAddr slotLength seed = withIOManager $ \iocp -> do prng <- case seed of - Nothing -> Random.initStdGen - Just a -> return (Random.mkStdGen a) + Nothing -> initStdGen + Just a -> return (mkStdGen a) Server.Simple.with (localSnocket iocp) nullTracer @@ -792,7 +795,7 @@ genBlockChain !g prevHeader = block :< genBlockChain g'' (Just (blockHeader block)) where block = genBlock g' prevHeader - (g', g'') = Random.splitGen g + (g', g'') = splitGen g genBlock :: SplitGen g => g -> Maybe BlockHeader -> Block genBlock g prevHeader = @@ -800,7 +803,7 @@ genBlock g prevHeader = where blockBody = genBlockBody g' blockHeader = genBlockHeader g'' prevHeader blockBody - (g', g'') = Random.splitGen g + (g', g'') = splitGen g genBlockHeader :: RandomGen g => g -> Maybe BlockHeader -> BlockBody -> BlockHeader @@ -814,7 +817,7 @@ genBlockHeader g prevHeader body = headerBlockNo = maybe 1 (succ . headerBlockNo) prevHeader, headerBodyHash = hashBody body } - (slotGap, _) = Random.randomR (1,3) g + (slotGap, _) = randomR (1,3) g addSlotGap :: Int -> SlotNo -> SlotNo addSlotGap m (SlotNo n) = SlotNo (n + fromIntegral m) @@ -823,8 +826,8 @@ genBlockBody :: RandomGen g => g -> BlockBody genBlockBody g = BlockBody . BSC.take len . BSC.drop offset . BSC.pack $ bodyData where - (offset, g') = Random.randomR (0, bodyDataCycle-1) g - (len , _ ) = Random.randomR (1, bodyDataCycle*10-1) g' + (offset, g') = randomR (0, bodyDataCycle-1) g + (len , _ ) = randomR (1, bodyDataCycle*10-1) g' bodyData :: String bodyData = concat diff --git a/cardano-diffusion/ping/Cardano/Network/Ping.hs b/cardano-diffusion/ping/Cardano/Network/Ping.hs index 2070b72e81..a9c33a425c 100644 --- a/cardano-diffusion/ping/Cardano/Network/Ping.hs +++ b/cardano-diffusion/ping/Cardano/Network/Ping.hs @@ -1202,6 +1202,7 @@ pingClient' stdout infoTracer headerTracer stderr opts@PingOpts{..} signalVar ad stdGen <- initStdGen mx <- Mx.new Mx.nullTracers + stdGen [MiniProtocolInfo { miniProtocolNum = case protocol of NodeToNode -> NodeToNode.chainSyncMiniProtocolNum @@ -1241,8 +1242,10 @@ pingClient' stdout infoTracer headerTracer stderr opts@PingOpts{..} signalVar ad -- -- run keepalive client to get RTT samples -- + g <- initStdGen mx <- Mx.new Mx.nullTracers + g [MiniProtocolInfo { miniProtocolNum = NodeToNode.keepAliveMiniProtocolNum, miniProtocolDir = Mx.InitiatorDirectionOnly, diff --git a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/MiniProtocols.hs b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/MiniProtocols.hs index fb1b231ef7..8d1070fbec 100644 --- a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/MiniProtocols.hs +++ b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/MiniProtocols.hs @@ -491,7 +491,7 @@ applications debugTracer txSubmissionInboundTracer nodeKernel ) chainSyncResponder - :: MiniProtocolCb (ResponderContext NtNAddr) ByteString m () + :: MiniProtocolCb (ResponderContext NtNAddr m) ByteString m () chainSyncResponder = MiniProtocolCb $ \ ResponderContext { rcConnectionId = connId } channel -> do @@ -533,7 +533,7 @@ applications debugTracer txSubmissionInboundTracer nodeKernel nullTracer clientCtx) blockFetchResponder - :: MiniProtocolCb (ResponderContext NtNAddr) ByteString m () + :: MiniProtocolCb (ResponderContext NtNAddr m) ByteString m () blockFetchResponder = MiniProtocolCb $ \ ResponderContext { rcConnectionId = connId } @@ -587,7 +587,7 @@ applications debugTracer txSubmissionInboundTracer nodeKernel kacApp keepAliveResponder - :: MiniProtocolCb (ResponderContext NtNAddr) ByteString m () + :: MiniProtocolCb (ResponderContext NtNAddr m) ByteString m () keepAliveResponder = MiniProtocolCb $ \ ResponderContext { rcConnectionId = connId } channel -> do @@ -644,7 +644,7 @@ applications debugTracer txSubmissionInboundTracer nodeKernel (pingPongClientPeer pingPongClient) pingPongResponder - :: MiniProtocolCb (ResponderContext NtNAddr) ByteString m () + :: MiniProtocolCb (ResponderContext NtNAddr m) ByteString m () pingPongResponder = MiniProtocolCb $ \ResponderContext { rcConnectionId = connId } channel -> runPeerWithLimits @@ -679,7 +679,7 @@ applications debugTracer txSubmissionInboundTracer nodeKernel peerSharingResponder :: PeerSharingAPI NtNAddr s m - -> MiniProtocolCb (ResponderContext NtNAddr) ByteString m () + -> MiniProtocolCb (ResponderContext NtNAddr m) ByteString m () peerSharingResponder psAPI = MiniProtocolCb $ \ ResponderContext { rcConnectionId = connId } channel -> do @@ -734,7 +734,7 @@ applications debugTracer txSubmissionInboundTracer nodeKernel -> TxSubmissionCountersVar m -> SharedTxStateVar m NtNAddr Int -> PeerTxRegistry m NtNAddr - -> MiniProtocolCb (ResponderContext NtNAddr) ByteString m () + -> MiniProtocolCb (ResponderContext NtNAddr m) ByteString m () txSubmissionResponder mempool txCountersVar sharedTxStateVar inFlightRegistry = MiniProtocolCb $ \ ResponderContext { rcConnectionId = connId@ConnectionId { remoteAddress = them }} channel diff --git a/ouroboros-network/demo/connection-manager.hs b/ouroboros-network/demo/connection-manager.hs index fb80bd5437..20e3433cc5 100644 --- a/ouroboros-network/demo/connection-manager.hs +++ b/ouroboros-network/demo/connection-manager.hs @@ -230,6 +230,9 @@ withBidirectionalConnectionManager snocket makeBearer socket hotRequestsVar <- LazySTM.newTVarIO hotInitiatorRequests warmRequestsVar <- LazySTM.newTVarIO warmInitiatorRequests establishedRequestsVar <- LazySTM.newTVarIO establishedInitiatorRequests + -- Split off an independent PRNG for RTT cookie generation. + let (rttSeed, _) = Random.splitGen stdGen + rttCookieRngVar <- newTVarIO rttSeed let muxTracers = Mx.Tracers { Mx.tracer = ("mux",) `contramap` nullTracer, Mx.channelTracer = ("mux",) `contramap` nullTracer, @@ -254,6 +257,7 @@ withBidirectionalConnectionManager snocket makeBearer socket establishedRequestsVar)) (mainThreadId, debugMuxErrorRethrowPolicy <> debugIOErrorRethrowPolicy) + rttCookieRngVar withConnectionManager connectionHandler k' = CM.with @@ -510,7 +514,8 @@ bidirectionalExperiment . projectBundle tok $ controlMessageBundle, eicIsBigLedgerPeer = IsNotBigLedgerPeer, - eicExtraFlags = () + eicExtraFlags = (), + eicPeerRTT = noPeerRTT }) muxBundle res <- diff --git a/ouroboros-network/demo/ping-pong.hs b/ouroboros-network/demo/ping-pong.hs index a3626b2648..d5152ce9e9 100644 --- a/ouroboros-network/demo/ping-pong.hs +++ b/ouroboros-network/demo/ping-pong.hs @@ -23,6 +23,7 @@ import System.Directory import System.Environment import System.Exit import System.IO +import System.Random import Text.Printf (printf) import Network.Mux qualified as Mx @@ -118,23 +119,24 @@ demoProtocol0 pingPong = clientPingPong :: Bool -> IO () -clientPingPong pipelined = - withIOManager $ \iomgr -> +clientPingPong pipelined = withIOManager $ \iomgr -> do + rttCookieSeed <- newStdGen void $ - connectToNode - (Snocket.localSnocket iomgr) - makeLocalBearer - ConnectToArgs { - ctaHandshakeCodec = unversionedHandshakeCodec, - ctaHandshakeTimeLimits = noTimeLimitsHandshake, - ctaVersionDataCodec = unversionedProtocolDataCodec, - ctaConnectTracers = nullNetworkConnectTracers, - ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion - } - mempty - (unversionedProtocol app) - Nothing - defaultLocalSocketAddr + connectToNode + (Snocket.localSnocket iomgr) + makeLocalBearer + ConnectToArgs { + ctaHandshakeCodec = unversionedHandshakeCodec, + ctaHandshakeTimeLimits = noTimeLimitsHandshake, + ctaVersionDataCodec = unversionedProtocolDataCodec, + ctaConnectTracers = nullNetworkConnectTracers, + ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion, + ctaRTTCookieSeed = rttCookieSeed + } + mempty + (unversionedProtocol app) + Nothing + defaultLocalSocketAddr where app :: OuroborosApplicationWithMinimalCtx Mx.InitiatorMode LocalAddress LBS.ByteString IO () Void @@ -216,22 +218,24 @@ demoProtocol1 pingPong pingPong' = clientPingPong2 :: Bool -> IO () -clientPingPong2 flood = - withIOManager $ \iomgr -> void $ do - connectToNode - (Snocket.localSnocket iomgr) - makeLocalBearer - ConnectToArgs { - ctaHandshakeCodec = unversionedHandshakeCodec, - ctaHandshakeTimeLimits = noTimeLimitsHandshake, - ctaVersionDataCodec = unversionedProtocolDataCodec, - ctaConnectTracers = nullNetworkConnectTracers, - ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion - } - mempty - (unversionedProtocol app) - Nothing - defaultLocalSocketAddr +clientPingPong2 flood = withIOManager $ \iomgr -> do + rttCookieSeed <- newStdGen + void $ + connectToNode + (Snocket.localSnocket iomgr) + makeLocalBearer + ConnectToArgs { + ctaHandshakeCodec = unversionedHandshakeCodec, + ctaHandshakeTimeLimits = noTimeLimitsHandshake, + ctaVersionDataCodec = unversionedProtocolDataCodec, + ctaConnectTracers = nullNetworkConnectTracers, + ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion, + ctaRTTCookieSeed = rttCookieSeed + } + mempty + (unversionedProtocol app) + Nothing + defaultLocalSocketAddr where app :: OuroborosApplicationWithMinimalCtx Mx.InitiatorMode addr LBS.ByteString IO () Void diff --git a/ouroboros-network/demo/tx-submission/main.hs b/ouroboros-network/demo/tx-submission/main.hs index b519434ef5..3ee47114f1 100644 --- a/ouroboros-network/demo/tx-submission/main.hs +++ b/ouroboros-network/demo/tx-submission/main.hs @@ -50,6 +50,7 @@ import NoThunks.Class (NoThunks (..)) import Options.Applicative import Statistics.Quantile qualified as Stat import System.IO (hPutStrLn, stderr) +import System.Random qualified as Random import System.Random.SplitMix qualified as SM import Network.Mux qualified as Mx @@ -497,11 +498,12 @@ runTxInbound Addr { addr, port } txDecisionPolicy version txDelay = do $ Mx.withReadBufferIO $ \buffer -> do bearer <- Mx.getBearer Mx.makeSocketBearer 1.0 sock' buffer let dir = Mx.ResponderDirectionOnly + g <- Random.newStdGen mux <- Mx.new Mx.nullTracers { Mx.tracer = Mx.WithBearer addr' . runIdentity >$< printTracer traceLock -- , Mx.bearerTracer = Mx.WithBearer addr' . runIdentity >$< printTracer traceLock } - (protocols dir) + g (protocols dir) withAsync (Mx.run mux bearer) $ \_ -> either throwIO return =<< atomically @@ -629,11 +631,12 @@ runTxOutbound stderrTracer inboundAddr outboundAddr Mx.withReadBufferIO $ \buffer -> do bearer <- Mx.getBearer Mx.makeSocketBearer 1.0 sock buffer let dir = Mx.InitiatorDirectionOnly + g <- Random.newStdGen mux <- Mx.new Mx.nullTracers { Mx.tracer = Mx.WithBearer addr' . runIdentity >$< printTracer traceLock -- , Mx.bearerTracer = Mx.WithBearer addr' . runIdentity >$< printTracer traceLock } - (protocols dir) + g (protocols dir) withAsync (Mx.run mux bearer) $ \_ -> do let reader = Mempool.getReader diff --git a/ouroboros-network/framework/io-tests/Test/Ouroboros/Network/Socket.hs b/ouroboros-network/framework/io-tests/Test/Ouroboros/Network/Socket.hs index 1576982852..e33594822d 100644 --- a/ouroboros-network/framework/io-tests/Test/Ouroboros/Network/Socket.hs +++ b/ouroboros-network/framework/io-tests/Test/Ouroboros/Network/Socket.hs @@ -20,6 +20,7 @@ import Data.Void (Void) #ifndef mingw32_HOST_OS import System.Directory (removeFile) import System.IO.Error +import System.Random #endif import Network.Socket qualified as Socket #if defined(mingw32_HOST_OS) @@ -269,6 +270,7 @@ prop_socket_send_recv initiatorAddr responderAddr configureSock f xs = } (unversionedProtocol (SomeResponderApplication responderApp)) $ \localAddress _ -> do + rttCookieSeed <- newStdGen void $ connectToNode snocket Mx.makeSocketBearer @@ -277,7 +279,8 @@ prop_socket_send_recv initiatorAddr responderAddr configureSock f xs = ctaHandshakeTimeLimits = noTimeLimitsHandshake, ctaVersionDataCodec = unversionedProtocolDataCodec, ctaConnectTracers = NetworkConnectTracers (Mx.tracersWith activeMuxTracer) nullTracer, - ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion + ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion, + ctaRTTCookieSeed = rttCookieSeed } (`configureSock` Nothing) (unversionedProtocol initiatorApp) @@ -365,8 +368,8 @@ prop_socket_recv_error f rerr = _ <- async $ do threadDelay 0.1 atomically $ putTMVar lock () - mux <- Mx.new Mx.nullTracers (toMiniProtocolInfos (\_ _ -> Nothing) app) - let respCtx = ResponderContext connectionId + mux <- Mx.new Mx.nullTracers (mkStdGen 0) (toMiniProtocolInfos (\_ _ -> Nothing) app) + let respCtx = ResponderContext connectionId noPeerRTT resOps <- sequence [ Mx.runMiniProtocol mux @@ -496,10 +499,11 @@ prop_socket_send_error rerr = wrap blob ptclDir ptclNum = Mx.SDU { -- it will be filled when the 'SDU' is send by the 'bearer' Mx.msHeader = Mx.SDUHeader { - Mx.mhTimestamp = Mx.RemoteClockModel 0, - Mx.mhNum = ptclNum, - Mx.mhDir = ptclDir, - Mx.mhLength = fromIntegral $ BL.length blob + Mx.mhSendCookie = Mx.noCookie, + Mx.mhEchoCookie = Mx.noCookie, + Mx.mhNum = ptclNum, + Mx.mhDir = ptclDir, + Mx.mhLength = fromIntegral $ BL.length blob }, Mx.msBlob = blob } @@ -530,6 +534,7 @@ prop_socket_client_connect_error _ xs = ((), trailing) <$ atomically (putTMVar cv ()) + rttCookieSeed <- newStdGen (res :: Either IOException Bool) <- try $ False <$ connectToNode (socketSnocket iomgr) @@ -539,7 +544,8 @@ prop_socket_client_connect_error _ xs = ctaHandshakeTimeLimits = noTimeLimitsHandshake, ctaVersionDataCodec = unversionedProtocolDataCodec, ctaConnectTracers = nullNetworkConnectTracers, - ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion + ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion, + ctaRTTCookieSeed = rttCookieSeed } (`configureSocket` Nothing) (unversionedProtocol app) diff --git a/ouroboros-network/framework/sim-tests/Test/Simulation/Network/Snocket.hs b/ouroboros-network/framework/sim-tests/Test/Simulation/Network/Snocket.hs index 47e87c74b4..3017f7b1fd 100644 --- a/ouroboros-network/framework/sim-tests/Test/Simulation/Network/Snocket.hs +++ b/ouroboros-network/framework/sim-tests/Test/Simulation/Network/Snocket.hs @@ -64,6 +64,8 @@ import Test.Ouroboros.Network.Data.AbsBearerInfo import Test.Ouroboros.Network.Orphans () import Test.Ouroboros.Network.Utils (sayTracer) +import System.Random + import Test.QuickCheck hiding (Result (..)) import Test.QuickCheck.Instances.ByteString () import Test.Tasty (TestTree, testGroup) @@ -274,6 +276,7 @@ clientServerSimulation payloads = traceTime sayTracer) bracket (Mx.new (Mx.Tracers mxTracer mxTracer mxTracer) + (mkStdGen 0) [ MiniProtocolInfo { miniProtocolNum = reqRespProtocolNum, miniProtocolDir = Mx.ResponderDirectionOnly, @@ -328,6 +331,7 @@ clientServerSimulation payloads = traceTime sayTracer) mux <- Mx.new (Mx.Tracers mxTracer mxTracer mxTracer) + (mkStdGen 0) [ MiniProtocolInfo { miniProtocolNum = reqRespProtocolNum, miniProtocolDir = Mx.InitiatorDirectionOnly, diff --git a/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs b/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs index 904c2f58c5..a292f4f1c2 100644 --- a/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs +++ b/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs @@ -62,8 +62,7 @@ import Data.Proxy (Proxy (..)) import Data.Typeable (Typeable) import Data.Void (Void) -import System.Random (StdGen) -import System.Random qualified as Random +import System.Random import Test.QuickCheck @@ -282,6 +281,8 @@ withInitiatorOnlyConnectionManager withInitiatorOnlyConnectionManager name timeouts trTracer tracer stdGen snocket makeBearer connStateIdSupply localAddr nextRequests handshakeTimeLimits acceptedConnLimit k = do mainThreadId <- myThreadId + let (rttSeed, _) = splitGen stdGen + rttCookieRngVar <- newTVarIO rttSeed let muxTracers :: Mx.TracersWithBearer (ConnectionId peerAddr) m muxTracers = Mx.Tracers { Mx.tracer = WithName name `contramap` nullTracer, @@ -307,6 +308,7 @@ withInitiatorOnlyConnectionManager name timeouts trTracer tracer stdGen snocket <> debugMuxRuntimeErrorRethrowPolicy <> debugIOErrorRethrowPolicy <> assertRethrowPolicy) + rttCookieRngVar MuxInitiatorConnectionHandler @@ -342,7 +344,7 @@ withInitiatorOnlyConnectionManager name timeouts trTracer tracer stdGen snocket clientApplication :: TemperatureBundle [MiniProtocol Mx.InitiatorMode (ExpandedInitiatorContext peerAddr () m) - (ResponderContext peerAddr) + (ResponderContext peerAddr m) ByteString m [resp] Void] clientApplication = mkProto <$> (Mx.MiniProtocolNum <$> nums) <*> nextRequests @@ -361,7 +363,7 @@ withInitiatorOnlyConnectionManager name timeouts trTracer tracer stdGen snocket -> (ConnectionId peerAddr -> STM m [req]) -> RunMiniProtocol Mx.InitiatorMode (ExpandedInitiatorContext peerAddr () m) - (ResponderContext peerAddr) + (ResponderContext peerAddr m) ByteString m [resp] Void reqRespInitiator protocolNum nextRequest = InitiatorProtocolOnly @@ -488,6 +490,8 @@ withBidirectionalConnectionManager name timeouts acceptedConnLimit k = do mainThreadId <- myThreadId inbgovInfoChannel <- newInformationChannel + let (rttSeed, _) = splitGen stdGen + rttCookieRngVar <- newTVarIO rttSeed let mkConnectionHandler = makeConnectionHandler ((Compose . WithName name) `Mx.contramapTracers'` muxTracer) @@ -507,6 +511,7 @@ withBidirectionalConnectionManager name timeouts <> debugMuxRuntimeErrorRethrowPolicy <> debugIOErrorRethrowPolicy <> assertRethrowPolicy) + rttCookieRngVar withConnectionManager connectionHandler k' = CM.with CM.Arguments { @@ -572,7 +577,7 @@ withBidirectionalConnectionManager name timeouts serverApplication :: TemperatureBundle [MiniProtocol Mx.InitiatorResponderMode (ExpandedInitiatorContext peerAddr () m) - (ResponderContext peerAddr) + (ResponderContext peerAddr m) ByteString m [resp] acc] serverApplication = mkProto <$> (Mx.MiniProtocolNum <$> nums) <*> nextRequests where nums = TemperatureBundle (WithHot 1) (WithWarm 2) (WithEstablished 3) @@ -593,7 +598,7 @@ withBidirectionalConnectionManager name timeouts -> (ConnectionId peerAddr -> STM m [req]) -> RunMiniProtocol Mx.InitiatorResponderMode (ExpandedInitiatorContext peerAddr () m) - (ResponderContext peerAddr) + (ResponderContext peerAddr m) ByteString m [resp] acc reqRespInitiatorAndResponder protocolNum accInit nextRequest = InitiatorAndResponderProtocol @@ -678,7 +683,7 @@ runInitiatorProtocols => SingMuxMode muxMode -> Mx.Mux muxMode m -> OuroborosBundle muxMode (ExpandedInitiatorContext addr () m) - (ResponderContext addr) + (ResponderContext addr m) ByteString m a b -> TemperatureBundle (StrictTVar m ControlMessage) -> ConnectionId addr @@ -712,7 +717,8 @@ runInitiatorProtocols singMuxMode mux bundle controlBundle connId = do eicConnectionId = connId, eicControlMessage = controlMessage, eicIsBigLedgerPeer = IsNotBigLedgerPeer, - eicExtraFlags = () + eicExtraFlags = (), + eicPeerRTT = noPeerRTT } -- @@ -761,7 +767,7 @@ unidirectionalExperiment -> ClientAndServerData req -> m Property unidirectionalExperiment stdGen timeouts snocket makeBearer confSock socket clientAndServerData = do - let (stdGen', stdGen'') = Random.splitGen stdGen + let (stdGen', stdGen'') = splitGen stdGen nextReqs <- oneshotNextRequests clientAndServerData connStateIdSupply <- atomically $ CM.newConnStateIdSupply (Proxy @m) withInitiatorOnlyConnectionManager @@ -850,7 +856,7 @@ bidirectionalExperiment bidirectionalExperiment useLock stdGen timeouts snocket makeBearer confSock socket0 socket1 localAddr0 localAddr1 clientAndServerData0 clientAndServerData1 = do - let (stdGen', stdGen'') = Random.splitGen stdGen + let (stdGen', stdGen'') = splitGen stdGen lock <- newTMVarIO () connStateIdSupply <- atomically $ CM.newConnStateIdSupply (Proxy @m) nextRequests0 <- oneshotNextRequests clientAndServerData0 diff --git a/ouroboros-network/tests/io/Test/Ouroboros/Network/Pipe.hs b/ouroboros-network/tests/io/Test/Ouroboros/Network/Pipe.hs index 18405adbc4..63ddc3c4bd 100644 --- a/ouroboros-network/tests/io/Test/Ouroboros/Network/Pipe.hs +++ b/ouroboros-network/tests/io/Test/Ouroboros/Network/Pipe.hs @@ -48,6 +48,7 @@ import "Win32-network" System.Win32.NamedPipes qualified as Win32.NamedPipes #else import System.IO (hClose) import System.Process (createPipe) +import System.Random #endif import Ouroboros.Network.Block (decodeTip, encodeTip) @@ -204,7 +205,7 @@ demo chain0 updates = do serverBearer <- Mx.getBearer Mx.makePipeChannelBearer (-1) chan2 Nothing _ <- async $ do - clientMux <- Mx.new (Mx.Tracers activeTracer activeTracer activeTracer) + clientMux <- Mx.new (Mx.Tracers activeTracer activeTracer activeTracer) (mkStdGen 0) (toMiniProtocolInfos (\_ _ -> Nothing) consumerApp) let initCtx = MinimalInitiatorContext (ConnectionId "consumer" "producer") resOps <- sequence @@ -230,9 +231,9 @@ demo chain0 updates = do wait aid _ <- async $ do - serverMux <- Mx.new (Mx.Tracers activeTracer activeTracer activeTracer) + serverMux <- Mx.new (Mx.Tracers activeTracer activeTracer activeTracer) (mkStdGen 0) (toMiniProtocolInfos (\_ _ -> Nothing) producerApp) - let respCtx = ResponderContext (ConnectionId "consumer" "producer") + let respCtx = ResponderContext (ConnectionId "consumer" "producer") noPeerRTT resOps <- sequence [ Mx.runMiniProtocol serverMux diff --git a/ouroboros-network/tests/io/Test/Ouroboros/Network/Socket.hs b/ouroboros-network/tests/io/Test/Ouroboros/Network/Socket.hs index 4d593d1607..877f134132 100644 --- a/ouroboros-network/tests/io/Test/Ouroboros/Network/Socket.hs +++ b/ouroboros-network/tests/io/Test/Ouroboros/Network/Socket.hs @@ -272,6 +272,7 @@ demo chain0 updates = withIOManager $ \iocp -> do TestVersionData { networkMagic = NetworkMagic 0 } (\_ -> SomeResponderApplication responderApp)) $ \producerAddress' _ -> do + rttCookieSeed <- newStdGen withAsync (connectToNode (socketSnocket iocp) @@ -281,7 +282,8 @@ demo chain0 updates = withIOManager $ \iocp -> do ctaHandshakeTimeLimits = noTimeLimitsHandshake, ctaVersionDataCodec = testVersionDataCodec, ctaConnectTracers = nullNetworkConnectTracers, - ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion + ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion, + ctaRTTCookieSeed = rttCookieSeed } (`configureSocket` Nothing) (simpleSingletonVersions diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/Mux.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/Mux.hs index b8c5e35588..31b886c894 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/Mux.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/Mux.hs @@ -51,6 +51,8 @@ import Network.Mux.Bearer qualified as Mx import Network.Mux.Bearer.Queues qualified as Mx import Ouroboros.Network.Mux as Mx +import System.Random + tests :: TestTree tests = @@ -166,7 +168,7 @@ demo chain0 updates delay = do Nothing clientAsync <- async $ do - clientMux <- Mx.new (Mx.Tracers activeTracer activeTracer activeTracer) + clientMux <- Mx.new (Mx.Tracers activeTracer activeTracer activeTracer) (mkStdGen 0) (toMiniProtocolInfos (\_ _ -> Nothing) consumerApp) let initCtx = MinimalInitiatorContext (ConnectionId "consumer" "producer") resOps <- sequence @@ -192,9 +194,9 @@ demo chain0 updates delay = do wait aid serverAsync <- async $ do - serverMux <- Mx.new (Mx.Tracers activeTracer activeTracer activeTracer) + serverMux <- Mx.new (Mx.Tracers activeTracer activeTracer activeTracer) (mkStdGen 0) (toMiniProtocolInfos (\_ _ -> Nothing) producerApp) - let respCtx = ResponderContext (ConnectionId "producer" "consumer") + let respCtx = ResponderContext (ConnectionId "producer" "consumer") noPeerRTT resOps <- sequence [ Mx.runMiniProtocol serverMux From 6feb79773277082c3a491ce69d3c0832865c5bfe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Thu, 16 Jul 2026 15:43:31 +0200 Subject: [PATCH 16/17] tracing: integrate changes into libraries --- .../framework/tracing/Network/Mux/Tracing.hs | 50 ++++++++++--------- .../tracing/Network/Mux/Tracing.hs | 48 ++++++++++-------- 2 files changed, 53 insertions(+), 45 deletions(-) diff --git a/ouroboros-network/framework/tracing/Network/Mux/Tracing.hs b/ouroboros-network/framework/tracing/Network/Mux/Tracing.hs index d9cf0af888..3f870a7be4 100644 --- a/ouroboros-network/framework/tracing/Network/Mux/Tracing.hs +++ b/ouroboros-network/framework/tracing/Network/Mux/Tracing.hs @@ -19,7 +19,7 @@ import Network.Mux qualified as Mux #ifdef linux_HOST_OS import Network.Mux.TCPInfo (StructTCPInfo (..)) #endif -import Network.Mux.Types (SDUHeader (..), unRemoteClockModel) +import Network.Mux.Types -------------------------------------------------------------------------------- -- Mux Tracer @@ -54,28 +54,30 @@ instance LogFormatting Mux.BearerTrace where [ "kind" .= String "Mux.TraceRecvHeaderStart" , "msg" .= String "Bearer Receive Header Start" ] - forMachine _dtal (Mux.TraceRecvHeaderEnd SDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = mconcat + forMachine _dtal (Mux.TraceRecvHeaderEnd SDUHeader { mhSendCookie, mhEchoCookie, mhNum, mhDir, mhLength }) = mconcat [ "kind" .= String "Mux.TraceRecvHeaderStart" , "msg" .= String "Bearer Receive Header End" - , "timestamp" .= String (showTHex (unRemoteClockModel mhTimestamp)) + , "sendCookie" .= String (showTHex (unCookie mhSendCookie)) + , "echoCookie" .= String (showTHex (unCookie mhEchoCookie)) , "miniProtocolNum" .= String (showT mhNum) , "miniProtocolDir" .= String (showT mhDir) , "length" .= String (showT mhLength) ] - forMachine _dtal (Mux.TraceRecvDeltaQObservation SDUHeader { mhTimestamp, mhLength } ts) = mconcat + forMachine _dtal (Mux.TraceRecvDeltaQObservation mpNum len delay) = mconcat [ "kind" .= String "Mux.TraceRecvDeltaQObservation" , "msg" .= String "Bearer DeltaQ observation" - , "timeRemote" .= String (showT ts) - , "timeLocal" .= String (showTHex (unRemoteClockModel mhTimestamp)) - , "length" .= String (showT mhLength) + , "miniProtocolNum" .= String (showT mpNum) + , "length" .= String (showT len) + , "roundTrip" .= String (showT delay) ] - forMachine _dtal (Mux.TraceRecvDeltaQSample d sp so dqs dqvm dqvs estR sdud) = mconcat + forMachine _dtal (Mux.TraceRecvDeltaQSample d sp so dqs bs dqvm dqvs estR sdud) = mconcat [ "kind" .= String "Mux.TraceRecvDeltaQSample" , "msg" .= String "Bearer DeltaQ Sample" , "duration" .= String (showT d) , "packets" .= String (showT sp) , "sumBytes" .= String (showT so) , "DeltaQ_S" .= String (showT dqs) + , "Burst_S" .= String (showT bs) , "DeltaQ_VMean" .= String (showT dqvm) , "DeltaQ_VVar" .= String (showT dqvs) , "DeltaQ_estR" .= String (showT estR) @@ -96,10 +98,11 @@ instance LogFormatting Mux.BearerTrace where , "msg" .= String "Bearer Receive End" , "length" .= String (showT len) ] - forMachine _dtal (Mux.TraceSendStart SDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = mconcat + forMachine _dtal (Mux.TraceSendStart SDUHeader { mhSendCookie, mhEchoCookie, mhNum, mhDir, mhLength }) = mconcat [ "kind" .= String "Mux.TraceSendStart" , "msg" .= String "Bearer Send Start" - , "timestamp" .= String (showTHex (unRemoteClockModel mhTimestamp)) + , "sendCookie" .= String (showTHex (unCookie mhSendCookie)) + , "echoCookie" .= String (showTHex (unCookie mhEchoCookie)) , "miniProtocolNum" .= String (showT mhNum) , "miniProtocolDir" .= String (showT mhDir) , "length" .= String (showT mhLength) @@ -143,26 +146,27 @@ instance LogFormatting Mux.BearerTrace where forHuman Mux.TraceRecvHeaderStart = "Bearer Receive Header Start" - forHuman (Mux.TraceRecvHeaderEnd SDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = - sformat ("Bearer Receive Header End: ts:" % prefixHex % "(" % shown % ") " % shown % " len " % int) - (unRemoteClockModel mhTimestamp) mhNum mhDir mhLength - forHuman (Mux.TraceRecvDeltaQObservation SDUHeader { mhTimestamp, mhLength } ts) = - sformat ("Bearer DeltaQ observation: remote ts" % int % " local ts " % shown % " length " % int) - (unRemoteClockModel mhTimestamp) ts mhLength - forHuman (Mux.TraceRecvDeltaQSample d sp so dqs dqvm dqvs estR sdud) = + forHuman (Mux.TraceRecvHeaderEnd SDUHeader { mhSendCookie, mhEchoCookie, mhNum, mhDir, mhLength }) = + sformat ("Bearer Receive Header End: send-cookie:" % prefixHex % " echo-cookie:" % prefixHex % " (" % shown % ") " % shown % " len " % int) + (unCookie mhSendCookie) (unCookie mhEchoCookie) mhNum mhDir mhLength + forHuman (Mux.TraceRecvDeltaQObservation mpNum len delay) = + sformat ("Bearer DeltaQ observation: " % shown % " length " % int % " round-trip " % shown) + mpNum len delay + forHuman (Mux.TraceRecvDeltaQSample d sp so dqs bs dqvm dqvs estR sdud) = sformat ("Bearer DeltaQ Sample: duration " % fixed 3 % " packets " % int % " sumBytes " - % int % " DeltaQ_S " % fixed 3 % " DeltaQ_VMean " % fixed 3 % "DeltaQ_VVar " % fixed 3 + % int % " DeltaQ_S " % fixed 3 % " Burst_S " % fixed 3 + % " DeltaQ_VMean " % fixed 3 % "DeltaQ_VVar " % fixed 3 % " DeltaQ_estR " % fixed 3 % " sizeDist " % string) - d sp so dqs dqvm dqvs estR sdud + d sp so dqs bs dqvm dqvs estR sdud forHuman (Mux.TraceRecvStart len) = sformat ("Bearer Receive Start: length " % int) len forHuman (Mux.TraceRecvRaw len) = sformat ("Bearer Receive Raw: length " % int) len forHuman (Mux.TraceRecvEnd len) = sformat ("Bearer Receive End: length " % int) len - forHuman (Mux.TraceSendStart SDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = - sformat ("Bearer Send Start: ts: " % prefixHex % " (" % shown % ") " % shown % " length " % int) - (unRemoteClockModel mhTimestamp) mhNum mhDir mhLength + forHuman (Mux.TraceSendStart SDUHeader { mhSendCookie, mhEchoCookie, mhNum, mhDir, mhLength }) = + sformat ("Bearer Send Start: send-cookie: " % prefixHex % " echo-cookie: " % prefixHex % " (" % shown % ") " % shown % " length " % int) + (unCookie mhSendCookie) (unCookie mhEchoCookie) mhNum mhDir mhLength forHuman Mux.TraceSendEnd = "Bearer Send End" forHuman Mux.TraceSDUReadTimeoutException = @@ -495,7 +499,7 @@ instance MetaTrace Mux.Trace where Namespace [] ["Stopped"] severityFor (Namespace _ ["State"]) _ = Just Info - severityFor (Namespace _ ["CleanExit"]) _ = Just Info + severityFor (Namespace _ ["CleanExit"]) _ = Just Notice severityFor (Namespace _ ["ExceptionExit"]) _ = Just Notice severityFor (Namespace _ ["StartEagerly"]) _ = Just Debug severityFor (Namespace _ ["StartOnDemand"]) _ = Just Debug diff --git a/ouroboros-network/tracing/Network/Mux/Tracing.hs b/ouroboros-network/tracing/Network/Mux/Tracing.hs index 1847b5226e..3f870a7be4 100644 --- a/ouroboros-network/tracing/Network/Mux/Tracing.hs +++ b/ouroboros-network/tracing/Network/Mux/Tracing.hs @@ -19,7 +19,7 @@ import Network.Mux qualified as Mux #ifdef linux_HOST_OS import Network.Mux.TCPInfo (StructTCPInfo (..)) #endif -import Network.Mux.Types (SDUHeader (..), unRemoteClockModel) +import Network.Mux.Types -------------------------------------------------------------------------------- -- Mux Tracer @@ -54,28 +54,30 @@ instance LogFormatting Mux.BearerTrace where [ "kind" .= String "Mux.TraceRecvHeaderStart" , "msg" .= String "Bearer Receive Header Start" ] - forMachine _dtal (Mux.TraceRecvHeaderEnd SDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = mconcat + forMachine _dtal (Mux.TraceRecvHeaderEnd SDUHeader { mhSendCookie, mhEchoCookie, mhNum, mhDir, mhLength }) = mconcat [ "kind" .= String "Mux.TraceRecvHeaderStart" , "msg" .= String "Bearer Receive Header End" - , "timestamp" .= String (showTHex (unRemoteClockModel mhTimestamp)) + , "sendCookie" .= String (showTHex (unCookie mhSendCookie)) + , "echoCookie" .= String (showTHex (unCookie mhEchoCookie)) , "miniProtocolNum" .= String (showT mhNum) , "miniProtocolDir" .= String (showT mhDir) , "length" .= String (showT mhLength) ] - forMachine _dtal (Mux.TraceRecvDeltaQObservation SDUHeader { mhTimestamp, mhLength } ts) = mconcat + forMachine _dtal (Mux.TraceRecvDeltaQObservation mpNum len delay) = mconcat [ "kind" .= String "Mux.TraceRecvDeltaQObservation" , "msg" .= String "Bearer DeltaQ observation" - , "timeRemote" .= String (showT ts) - , "timeLocal" .= String (showTHex (unRemoteClockModel mhTimestamp)) - , "length" .= String (showT mhLength) + , "miniProtocolNum" .= String (showT mpNum) + , "length" .= String (showT len) + , "roundTrip" .= String (showT delay) ] - forMachine _dtal (Mux.TraceRecvDeltaQSample d sp so dqs dqvm dqvs estR sdud) = mconcat + forMachine _dtal (Mux.TraceRecvDeltaQSample d sp so dqs bs dqvm dqvs estR sdud) = mconcat [ "kind" .= String "Mux.TraceRecvDeltaQSample" , "msg" .= String "Bearer DeltaQ Sample" , "duration" .= String (showT d) , "packets" .= String (showT sp) , "sumBytes" .= String (showT so) , "DeltaQ_S" .= String (showT dqs) + , "Burst_S" .= String (showT bs) , "DeltaQ_VMean" .= String (showT dqvm) , "DeltaQ_VVar" .= String (showT dqvs) , "DeltaQ_estR" .= String (showT estR) @@ -96,10 +98,11 @@ instance LogFormatting Mux.BearerTrace where , "msg" .= String "Bearer Receive End" , "length" .= String (showT len) ] - forMachine _dtal (Mux.TraceSendStart SDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = mconcat + forMachine _dtal (Mux.TraceSendStart SDUHeader { mhSendCookie, mhEchoCookie, mhNum, mhDir, mhLength }) = mconcat [ "kind" .= String "Mux.TraceSendStart" , "msg" .= String "Bearer Send Start" - , "timestamp" .= String (showTHex (unRemoteClockModel mhTimestamp)) + , "sendCookie" .= String (showTHex (unCookie mhSendCookie)) + , "echoCookie" .= String (showTHex (unCookie mhEchoCookie)) , "miniProtocolNum" .= String (showT mhNum) , "miniProtocolDir" .= String (showT mhDir) , "length" .= String (showT mhLength) @@ -143,26 +146,27 @@ instance LogFormatting Mux.BearerTrace where forHuman Mux.TraceRecvHeaderStart = "Bearer Receive Header Start" - forHuman (Mux.TraceRecvHeaderEnd SDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = - sformat ("Bearer Receive Header End: ts:" % prefixHex % "(" % shown % ") " % shown % " len " % int) - (unRemoteClockModel mhTimestamp) mhNum mhDir mhLength - forHuman (Mux.TraceRecvDeltaQObservation SDUHeader { mhTimestamp, mhLength } ts) = - sformat ("Bearer DeltaQ observation: remote ts" % int % " local ts " % shown % " length " % int) - (unRemoteClockModel mhTimestamp) ts mhLength - forHuman (Mux.TraceRecvDeltaQSample d sp so dqs dqvm dqvs estR sdud) = + forHuman (Mux.TraceRecvHeaderEnd SDUHeader { mhSendCookie, mhEchoCookie, mhNum, mhDir, mhLength }) = + sformat ("Bearer Receive Header End: send-cookie:" % prefixHex % " echo-cookie:" % prefixHex % " (" % shown % ") " % shown % " len " % int) + (unCookie mhSendCookie) (unCookie mhEchoCookie) mhNum mhDir mhLength + forHuman (Mux.TraceRecvDeltaQObservation mpNum len delay) = + sformat ("Bearer DeltaQ observation: " % shown % " length " % int % " round-trip " % shown) + mpNum len delay + forHuman (Mux.TraceRecvDeltaQSample d sp so dqs bs dqvm dqvs estR sdud) = sformat ("Bearer DeltaQ Sample: duration " % fixed 3 % " packets " % int % " sumBytes " - % int % " DeltaQ_S " % fixed 3 % " DeltaQ_VMean " % fixed 3 % "DeltaQ_VVar " % fixed 3 + % int % " DeltaQ_S " % fixed 3 % " Burst_S " % fixed 3 + % " DeltaQ_VMean " % fixed 3 % "DeltaQ_VVar " % fixed 3 % " DeltaQ_estR " % fixed 3 % " sizeDist " % string) - d sp so dqs dqvm dqvs estR sdud + d sp so dqs bs dqvm dqvs estR sdud forHuman (Mux.TraceRecvStart len) = sformat ("Bearer Receive Start: length " % int) len forHuman (Mux.TraceRecvRaw len) = sformat ("Bearer Receive Raw: length " % int) len forHuman (Mux.TraceRecvEnd len) = sformat ("Bearer Receive End: length " % int) len - forHuman (Mux.TraceSendStart SDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = - sformat ("Bearer Send Start: ts: " % prefixHex % " (" % shown % ") " % shown % " length " % int) - (unRemoteClockModel mhTimestamp) mhNum mhDir mhLength + forHuman (Mux.TraceSendStart SDUHeader { mhSendCookie, mhEchoCookie, mhNum, mhDir, mhLength }) = + sformat ("Bearer Send Start: send-cookie: " % prefixHex % " echo-cookie: " % prefixHex % " (" % shown % ") " % shown % " length " % int) + (unCookie mhSendCookie) (unCookie mhEchoCookie) mhNum mhDir mhLength forHuman Mux.TraceSendEnd = "Bearer Send End" forHuman Mux.TraceSDUReadTimeoutException = From 219dba075e73e609408dca50feef0928dffe7a90 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Thu, 16 Jul 2026 15:43:52 +0200 Subject: [PATCH 17/17] cabal files --- network-mux/network-mux.cabal | 9 +++++++++ ouroboros-network/ouroboros-network.cabal | 3 +++ 2 files changed, 12 insertions(+) diff --git a/network-mux/network-mux.cabal b/network-mux/network-mux.cabal index 3b710a4c1d..d25d57ae47 100644 --- a/network-mux/network-mux.cabal +++ b/network-mux/network-mux.cabal @@ -65,9 +65,12 @@ library process ^>=1.6, quiet, statistics-linreg >=0.3 && <0.4, + psqueues >=0.2.3 && <0.3, + random >=1.2 && <1.4, strict, time >=1.9.1 && <1.16, vector >=0.12 && <0.14, + window-stats:with-tdigest, if os(windows) build-depends: @@ -93,6 +96,7 @@ library Network.Mux.DeltaQ.TraceTypes Network.Mux.Egress Network.Mux.Ingress + Network.Mux.RTT Network.Mux.TCPInfo Network.Mux.Time Network.Mux.Timeout @@ -130,6 +134,7 @@ test-suite test other-modules: Test.Mux Test.Mux.ReqResp + Test.Mux.RTT Test.Mux.Timeout default-language: Haskell2010 @@ -150,6 +155,7 @@ test-suite test network-mux, primitive, quickcheck-instances, + random, serialise, splitmix, tasty, @@ -194,6 +200,7 @@ executable mux-demo io-classes, network-mux, primitive, + random, serialise, stm, @@ -226,6 +233,7 @@ executable mux-leios-demo network, network-mux, primitive, + random, serialise, stm, @@ -245,6 +253,7 @@ benchmark socket-read-write-benchmarks io-classes:{io-classes, si-timers, strict-stm}, network, network-mux, + random, strict, tasty-bench, diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 4bdd7d65bd..3e8c19e869 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -713,6 +713,7 @@ executable demo-ping-pong directory, network-mux, ouroboros-network:{api, framework}, + random, typed-protocols:examples, executable demo-connection-manager @@ -756,6 +757,7 @@ executable demo-tx-submission optparse-applicative, ouroboros-network:{ouroboros-network, api, framework, protocols}, quickcheck-instances, + random, serialise, splitmix, statistics, @@ -1063,6 +1065,7 @@ test-suite ouroboros-network-io-tests network, network-mux, ouroboros-network:{api, api-tests-lib, framework, protocols, protocols-tests-lib, tests-lib}, + random, serialise, tasty, tasty-quickcheck,