diff --git a/cabal.project b/cabal.project index 32e5cc6667d..5a0b4167d6b 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/cardano-diffusion/demo/chain-sync.hs b/cardano-diffusion/demo/chain-sync.hs index 3e18fb99347..fa823609a3e 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/lib/Cardano/Network/NodeToClient.hs b/cardano-diffusion/lib/Cardano/Network/NodeToClient.hs index 5864d76eac4..797fb48469f 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 ec3a1f45ba0..181629dcdd6 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) @@ -152,9 +153,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 { @@ -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/cardano-diffusion/ping/Cardano/Network/Ping.hs b/cardano-diffusion/ping/Cardano/Network/Ping.hs index 2070b72e817..a9c33a425c8 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 fb1b231ef7c..8d1070fbec4 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/network-mux/bench/socket_read_write/Main.hs b/network-mux/bench/socket_read_write/Main.hs index 02a9262ceda..d3c45ce8b5e 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 60e590db5f9..1a9b085bc43 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 44c47eee740..8b399697d31 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/network-mux/network-mux.cabal b/network-mux/network-mux.cabal index 3b710a4c1de..d25d57ae473 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/network-mux/src/Network/Mux.hs b/network-mux/src/Network/Mux.hs index 80e78fb9e20..a2a2e5bfa03 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. @@ -59,6 +57,10 @@ module Network.Mux , WithBearer (..) , TracersWithBearer , tracersWithBearer + -- * Peer RTT + , RTT.PeerRTT (..) + , RTT.noPeerRTT + , peerRTT ) where import Data.ByteString.Builder (lazyByteString, toLazyByteString) @@ -81,10 +83,14 @@ 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 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 @@ -131,20 +143,24 @@ 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 muxStatus <- newTVarIO Ready + muxRTTState <- RTT.newRTTState rttSeed return Mux { muxMiniProtocols, muxControlCmdQueue, muxStatus, - muxTracers + muxTracers, + muxRTTState } mkMiniProtocolStateMap :: MonadSTM m @@ -240,7 +256,8 @@ run Mux { muxMiniProtocols, muxTracers = tracers@TracersI { tracer_, bearerTracer_ - } + }, + muxRTTState } bearer@Bearer{name} = do @@ -278,13 +295,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 d407fddf2c4..176b997ed62 100644 --- a/network-mux/src/Network/Mux/Bearer/AttenuatedChannel.hs +++ b/network-mux/src/Network/Mux/Bearer/AttenuatedChannel.hs @@ -298,16 +298,13 @@ 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 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/NamedPipe.hs b/network-mux/src/Network/Mux/Bearer/NamedPipe.hs index 74b4c79317b..8bea38d9491 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 92d111a183d..de78f13629c 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 @@ -111,10 +110,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 b80916bc3a0..aae70f473c1 100644 --- a/network-mux/src/Network/Mux/Bearer/Queues.hs +++ b/network-mux/src/Network/Mux/Bearer/Queues.hs @@ -58,16 +58,13 @@ 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 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 b33cc8bd7fb..a1661851935 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 @@ -182,10 +181,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 +214,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 7e5e0c4164d..829467a3126 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/DeltaQ/TraceStats.hs b/network-mux/src/Network/Mux/DeltaQ/TraceStats.hs index f6ddb7cbd82..cf1c721776f 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 381c67012d4..2c0dd55a826 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/Egress.hs b/network-mux/src/Network/Mux/Egress.hs index ef8fcd5b769..940e6a2516b 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 263d31517c7..ec5af413992 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 new file mode 100644 index 00000000000..3d31e0e3c8b --- /dev/null +++ b/network-mux/src/Network/Mux/RTT.hs @@ -0,0 +1,349 @@ +{-# 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 + , processIngress + , IngressEcho (..) + , peerRTT + -- * Configuration + , defaultBucketDur + , defaultRetention + , defaultHoldDuration + , defaultMaxOutstanding + , defaultMintInterval + , defaultBurstMaxAge + , 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 + +-- | 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 { + -- | 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))) + -- | 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. + , 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 + -- | Maximum age of the burst tracker; see 'defaultBurstMaxAge'. + , rttBurstMaxAge :: !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 + rttLastEcho <- 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, + rttBurstMaxAge = defaultBurstMaxAge + } + + +-- | 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 + + +-- | 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 + 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 a743b813af9..8b004fdb041 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 00fd1e47dcc..8666178e014 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 } @@ -353,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 @@ -367,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" diff --git a/network-mux/test/Main.hs b/network-mux/test/Main.hs index ce4000e741b..cd180d56ec0 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 c60abd563f5..184c847c648 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 00000000000..795c1a09cd8 --- /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 + ] diff --git a/ouroboros-network/demo/connection-manager.hs b/ouroboros-network/demo/connection-manager.hs index fb80bd5437c..20e3433cc53 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 a3626b26485..d5152ce9e96 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 b519434ef58..3ee47114f13 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 15769828525..e33594822d0 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/lib/Ouroboros/Network/ConnectionHandler.hs b/ouroboros-network/framework/lib/Ouroboros/Network/ConnectionHandler.hs index b4b93544114..d47e0118391 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 @@ -144,7 +145,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 +155,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. @@ -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/Context.hs b/ouroboros-network/framework/lib/Ouroboros/Network/Context.hs index 49d4da94db4..dc33533cf44 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 7e515d9fe99..08f43284e7b 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 3ec04788d51..b86219a6171 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 0904451bc23..d85a6990362 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/framework/lib/Ouroboros/Network/Server/Simple.hs b/ouroboros-network/framework/lib/Ouroboros/Network/Server/Simple.hs index 44e426e4233..65b658862d7 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 246c48b97a3..0d192858cf3 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/framework/sim-tests/Test/Simulation/Network/Snocket.hs b/ouroboros-network/framework/sim-tests/Test/Simulation/Network/Snocket.hs index 47e87c74b4c..3017f7b1fdc 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 904c2f58c57..a292f4f1c2b 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/framework/tracing/Network/Mux/Tracing.hs b/ouroboros-network/framework/tracing/Network/Mux/Tracing.hs index d9cf0af8889..3f870a7be49 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/lib/Ouroboros/Network/Diffusion.hs b/ouroboros-network/lib/Ouroboros/Network/Diffusion.hs index 4ed434a2876..cd517d236df 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: diff --git a/ouroboros-network/lib/Ouroboros/Network/Diffusion/Types.hs b/ouroboros-network/lib/Ouroboros/Network/Diffusion/Types.hs index 3089351cd64..a7467aa501a 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 3d037275c32..7ceda3f31ce 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 } diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 4bdd7d65bd9..3e8c19e869c 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, diff --git a/ouroboros-network/tests/io/Test/Ouroboros/Network/Pipe.hs b/ouroboros-network/tests/io/Test/Ouroboros/Network/Pipe.hs index 18405adbc4d..63ddc3c4bd7 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 e8b4a7f9f23..877f1341326 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) @@ -271,6 +272,7 @@ demo chain0 updates = withIOManager $ \iocp -> do TestVersionData { networkMagic = NetworkMagic 0 } (\_ -> SomeResponderApplication responderApp)) $ \producerAddress' _ -> do + rttCookieSeed <- newStdGen withAsync (connectToNode (socketSnocket iocp) @@ -280,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 b8c5e35588f..31b886c8943 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 diff --git a/ouroboros-network/tracing/Network/Mux/Tracing.hs b/ouroboros-network/tracing/Network/Mux/Tracing.hs index 1847b5226ed..3f870a7be49 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 = diff --git a/window-stats/CHANGELOG.md b/window-stats/CHANGELOG.md new file mode 100644 index 00000000000..d3fecf5c6b0 --- /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 00000000000..d6456956733 --- /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 00000000000..025f8f91dcc --- /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 00000000000..83b324365f7 --- /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/bench/Main.hs b/window-stats/bench/Main.hs new file mode 100644 index 00000000000..54e4fdc4e77 --- /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/changelog.d/scriv.ini b/window-stats/changelog.d/scriv.ini new file mode 100644 index 00000000000..0d51d54748e --- /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/fold/lib/Data/Window/Fold/Count.hs b/window-stats/fold/lib/Data/Window/Fold/Count.hs new file mode 100644 index 00000000000..a1681203991 --- /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 00000000000..ecc6180470b --- /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 diff --git a/window-stats/lib/Data/Window/Count.hs b/window-stats/lib/Data/Window/Count.hs new file mode 100644 index 00000000000..9876b776d67 --- /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 00000000000..fed9c233ba4 --- /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 00000000000..341f34f95d9 --- /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 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 00000000000..e7273f4bdb8 --- /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 00000000000..1ffc9ea61e7 --- /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 00000000000..9db8bdf90cd --- /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 diff --git a/window-stats/tdigest/Data/Window/DigestTimeBatched.hs b/window-stats/tdigest/Data/Window/DigestTimeBatched.hs new file mode 100644 index 00000000000..6353be06b60 --- /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 00000000000..c0d55bbd94d --- /dev/null +++ b/window-stats/tdigest/Data/Window/Internal/DigestTimeBatched.hs @@ -0,0 +1,244 @@ +{-# 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)) + , 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) + + +-- | 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 + , 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, tdwCacheDigest = Nothing } + + +-- | 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. Forces the cached 'tdwCacheDigest' on the first +-- call after a batch of writes. +windowDigest :: KnownNat comp => TimedDigestWindow t comp -> Maybe (TDigest comp) +windowDigest tdw = case tdwCacheDigest tdw of + Nothing -> Nothing + Just !d -> Just d + + +-- | 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) -> + -- 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 forces the tree measure and refreshes the cache w/o forcing + 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' + , tdwCacheDigest = cache + } + 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) + -- 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 +-- 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 tdw = + case windowDigest tdw of + Nothing -> Nothing + Just d -> Just (TD.minimumValue d, TD.maximumValue d) + + +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 diff --git a/window-stats/test/Main.hs b/window-stats/test/Main.hs new file mode 100644 index 00000000000..790b1b58a52 --- /dev/null +++ b/window-stats/test/Main.hs @@ -0,0 +1,405 @@ +{-# 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) + + +-- | 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; +-- 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) + + +-- 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 + +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 + , testProperty "cascade generator has dense stretches" + unit_cascadeGeneratorHasDenseStretches + , testProperty "cascade generator triggers multi-bucket eviction" + unit_cascadeGeneratorTriggersMultiBucketEviction + ] + ] diff --git a/window-stats/window-stats.cabal b/window-stats/window-stats.cabal new file mode 100644 index 00000000000..90df2ac9be9 --- /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,