diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,5 +1,10 @@ # Revision history for network-control +## 0.1.0 + +* Breaking change: Renaming rxfWindow to rxfBufSize. +* Updating the document about flow control. + ## 0.0.2 * Adding constants. diff --git a/Network/Control.hs b/Network/Control.hs --- a/Network/Control.hs +++ b/Network/Control.hs @@ -1,4 +1,5 @@ -- | Common parts to control network protocols. +-- This library assumes that 'Int' is 64bit. module Network.Control ( module Network.Control.Flow, module Network.Control.LRUCache, diff --git a/Network/Control/Flow.hs b/Network/Control/Flow.hs --- a/Network/Control/Flow.hs +++ b/Network/Control/Flow.hs @@ -1,18 +1,24 @@ {-# LANGUAGE RecordWildCards #-} module Network.Control.Flow ( - -- * Constants for flow control. + -- * Flow control + + -- | This is based on the total approach of QUIC rather than + -- the difference approach of HTTP\/2 because QUIC'one is + -- considered safer. Please refer to [Using HTTP\/3 Stream Limits in HTTP\/2](https://datatracker.ietf.org/doc/draft-thomson-httpbis-h2-stream-limits/) to understand that QUIC's approaches are better though its topic is about stream concurrency. + + -- ** Constants for flow control. defaultMaxStreams, defaultMaxStreamData, defaultMaxData, - -- * Flow control for sending + -- ** Flow control for sending TxFlow (..), newTxFlow, txWindowSize, WindowSize, - -- * Flow control for receiving + -- ** Flow control for receiving RxFlow (..), newRxFlow, FlowControlType (..), @@ -38,13 +44,24 @@ type WindowSize = Int -- | Flow for sending +-- +-- @ +-- --------------------------------------> +-- ^ ^ +-- txfSent txfLimit +-- +-- |-----------| The size which this node can send +-- txWindowSize +-- @ data TxFlow = TxFlow { txfSent :: Int + -- ^ The total size of sent data. , txfLimit :: Int + -- ^ The total size of data which can be sent. } - deriving (Show) + deriving (Eq, Show) --- | Creating TX flow with an initial window size. +-- | Creating TX flow with a receive buffer size. newTxFlow :: WindowSize -> TxFlow newTxFlow win = TxFlow 0 win @@ -52,14 +69,29 @@ txWindowSize :: TxFlow -> WindowSize txWindowSize TxFlow{..} = txfLimit - txfSent --- | Flow for receiving +-- | Flow for receiving. +-- +-- @ +-- rxfBufSize +-- |------------------------| +-- --------------------------------------> +-- ^ ^ ^ +-- rxfConsumed rxfReceived rxfLimit +-- +-- |-----------| The size which the peer can send +-- Window +-- @ data RxFlow = RxFlow - { rxfWindow :: WindowSize + { rxfBufSize :: Int + -- ^ Receive buffer size. , rxfConsumed :: Int + -- ^ The total size which the application is consumed. , rxfReceived :: Int + -- ^ The total already-received size. , rxfLimit :: Int + -- ^ The total size which can be recived. } - deriving (Show) + deriving (Eq, Show) -- | Creating RX flow with an initial window size. newRxFlow :: WindowSize -> RxFlow @@ -72,10 +104,42 @@ | -- | QUIC style FCTMaxData --- | When an application consumed received data, --- this function should be called to update 'rxfConsumed'. --- If the window size is less than the half of the initial window. +-- | When an application consumed received data, this function should +-- be called to update 'rxfConsumed'. If the available buffer size +-- is less than the half of the total buffer size. -- the representation of window size update is returned. +-- +-- @ +-- Example: +-- +-- rxfBufSize +-- |------------------------| +-- --------------------------------------> +-- ^ ^ ^ +-- rxfConsumed rxfReceived rxfLimit +-- |01234567890| +-- +-- In the case where the window update should be informed to the peer, +-- 'rxfConsumed' and 'rxfLimit' move to the right. The difference +-- of old and new 'rxfLimit' is window update. +-- +-- rxfBufSize +-- |------------------------| +-- --------------------------------------> +-- ^ ^ ^ +-- rxfConsumed rxfReceived rxfLimit +-- |0123456789012| : window glows +-- +-- Otherwise, only 'rxfConsumed' moves to the right. +-- +-- rxfBufSize +-- |------------------------| +-- --------------------------------------> +-- ^ ^ ^ +-- rxfConsumed rxfReceived rxfLimit +-- |01234567890| : window stays +-- +-- @ maybeOpenRxWindow :: Int -- ^ The consumed size. @@ -85,22 +149,22 @@ -- ^ 'Just' if the size should be informed to the peer. maybeOpenRxWindow consumed fct flow@RxFlow{..} | available < threshold = - let limit = consumed' + rxfWindow + let rxfLimit' = consumed' + rxfBufSize flow' = flow { rxfConsumed = consumed' - , rxfLimit = limit + , rxfLimit = rxfLimit' } update = case fct of - FCTWindowUpdate -> limit - rxfLimit - FCTMaxData -> limit + FCTWindowUpdate -> rxfLimit' - rxfLimit + FCTMaxData -> rxfLimit' in (flow', Just update) | otherwise = let flow' = flow{rxfConsumed = consumed'} in (flow', Nothing) where available = rxfLimit - rxfReceived - threshold = rxfWindow `unsafeShiftR` 1 + threshold = rxfBufSize `unsafeShiftR` 1 consumed' = rxfConsumed + consumed -- | Checking if received data is acceptable against the diff --git a/network-control.cabal b/network-control.cabal --- a/network-control.cabal +++ b/network-control.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: network-control -version: 0.0.2 +version: 0.1.0 license: BSD-3-Clause license-file: LICENSE maintainer: kazu@iij.ad.jp @@ -25,3 +25,22 @@ base >=4.14 && <5, psqueues, unix-time + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-tool-depends: hspec-discover:hspec-discover + hs-source-dirs: test + other-modules: + Network.Control.FlowSpec + + default-language: Haskell2010 + default-extensions: Strict StrictData + ghc-options: -Wall -threaded + build-depends: + base, + hspec >=1.3, + network-control, + QuickCheck, + pretty-simple, + text diff --git a/test/Network/Control/FlowSpec.hs b/test/Network/Control/FlowSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Control/FlowSpec.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans -Wno-incomplete-patterns #-} + +module Network.Control.FlowSpec where + +import Data.List +import Data.Text.Lazy (unpack) +import Network.Control +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck +import Text.Pretty.Simple + +-- types + +data Op = Consume | Receive + deriving (Eq, Show, Bounded, Enum) + +data OpWithResult = ConsumeWithResult (Maybe Int) | ReceiveWithResult Bool + deriving (Eq, Show) + +data Step op = Step {stepOp :: op, stepArg :: Int} + deriving (Eq, Show) + +data Trace = Trace + { traceStart :: RxFlow + , traceSteps :: [(Int, Step OpWithResult, RxFlow)] + } + deriving (Eq, Show) + +-- arbitrary instances + +maxWindowSize :: Int +maxWindowSize = 200 -- (more realistic: 2_000_000) + +minFrameSize :: Int +minFrameSize = -20 + +instance Arbitrary RxFlow where + arbitrary = newRxFlow <$> chooseInt (1, maxWindowSize) + +instance Arbitrary Op where + arbitrary = elements [minBound ..] + +instance Arbitrary Trace where + arbitrary = do + initialFlow <- arbitrary + len <- chooseInt (0, 500) + Trace initialFlow <$> runManySteps len 0 initialFlow + where + runManySteps :: Int -> Int -> RxFlow -> Gen [(Int, Step OpWithResult, RxFlow)] + runManySteps 0 _ _ = pure [] + runManySteps len ix oldFlow | len > 0 = do + (newStep, newFlow) <- runStep oldFlow <$> genStep oldFlow + ((ix, newStep, newFlow) :) <$> runManySteps (len - 1) (ix + 1) newFlow + + -- Not sure frame size > window size or 0 or engative consumed or received bytes are + -- legal, but RxFlow works fine with them. :) + genStep :: RxFlow -> Gen (Step Op) + genStep oldFlow = oneof [mkConsume, mkReceive] + where + mkReceive = + Step Receive <$> chooseInt (minFrameSize, rxfBufSize oldFlow * 2) + + mkConsume = + let recv = rxfReceived oldFlow + in if recv > 0 + then Step Consume <$> chooseInt (minFrameSize, rxfReceived oldFlow) + else mkReceive + + runStep :: RxFlow -> Step Op -> (Step OpWithResult, RxFlow) + runStep oldFlow = \case + Step Consume arg -> + let (newFlow, limitDelta) = maybeOpenRxWindow arg FCTWindowUpdate oldFlow + in (Step (ConsumeWithResult limitDelta) arg, newFlow) + Step Receive arg -> + let (newFlow, isAcceptable) = checkRxLimit arg oldFlow + in (Step (ReceiveWithResult isAcceptable) arg, newFlow) + + shrink trace@(Trace initialFlow steps) = + trunc trace <> (Trace initialFlow <$> init (inits steps)) + where + trunc :: Trace -> [Trace] + trunc (Trace _ stp) = case reverse stp of + [] -> [] + [_] -> [] + ((ix, lastStep, lastFlow) : (_, _, initFlow) : _) -> [Trace initFlow [(ix, lastStep, lastFlow)]] + +-- invariants + +assertTrace :: Trace -> Property +assertTrace (Trace initialFlow steps) = assertStep initialFlow steps + +assertStep :: RxFlow -> [(Int, Step OpWithResult, RxFlow)] -> Property +assertStep _ [] = property True +assertStep oldFlow ((ix, step, newFlow) : steps) = + (counterexample ("step #" <> show ix) check) .&. assertStep newFlow steps + where + check :: Expectation + check = case step of + Step (ConsumeWithResult limitDelta) arg -> do + newFlow + `shouldBe` RxFlow + { rxfBufSize = rxfBufSize newFlow + , rxfConsumed = rxfConsumed oldFlow + arg + , rxfReceived = rxfReceived oldFlow + , rxfLimit = + if rxfLimit oldFlow - rxfReceived oldFlow < rxfBufSize oldFlow `div` 2 + then rxfConsumed oldFlow + arg + rxfBufSize oldFlow + else rxfLimit oldFlow + } + limitDelta + `shouldBe` case rxfLimit newFlow - rxfLimit oldFlow of + 0 -> Nothing + n -> Just n + Step (ReceiveWithResult isAcceptable) arg -> do + newFlow + `shouldBe` if isAcceptable + then + RxFlow + { rxfBufSize = rxfBufSize newFlow + , rxfConsumed = rxfConsumed oldFlow + , rxfReceived = rxfReceived oldFlow + arg + , rxfLimit = rxfLimit oldFlow + } + else oldFlow + +spec :: Spec +spec = do + focus . prop "state transition graph checks out" $ + \trace -> counterexample (unpack $ pShowNoColor trace) (assertTrace trace) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}