network-control-0.1.7/0000755000000000000000000000000007346545000013057 5ustar0000000000000000network-control-0.1.7/Changelog.md0000644000000000000000000000152407346545000015272 0ustar0000000000000000# Revision history for network-control ## 0.1.7 * Implementing setLRUCapacity. ## 0.1.6 * Allowing size 0. ## 0.1.5 * New API: `lookup'` adjusts the target priority. * New API: `LRUCacheRef` stuffs * `insert` rebuilds PSQ when reached the limit. ## 0.1.4 * Using Integer instead of Int in LRUCache. ## 0.1.3 * Simplify `maybeOpenRxWindow` and improve docs [#7](https://github.com/kazu-yamamoto/network-control/pull/7) ## 0.1.2 * introducing a minimum size for window update [#5](https://github.com/kazu-yamamoto/network-control/pull/5) ## 0.1.1 * Change defaultMaxData [#4](https://github.com/kazu-yamamoto/network-control/pull/4) ## 0.1.0 * Breaking change: Renaming rxfWindow to rxfBufSize. * Updating the document about flow control. ## 0.0.2 * Adding constants. ## 0.0.1 * Supporting GHC 8.10. ## 0.0.0 * First version. network-control-0.1.7/LICENSE0000644000000000000000000000276507346545000014076 0ustar0000000000000000Copyright (c) 2023, IIJ Innovation Institute Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holders nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. network-control-0.1.7/Network/0000755000000000000000000000000007346545000014510 5ustar0000000000000000network-control-0.1.7/Network/Control.hs0000644000000000000000000000050007346545000016457 0ustar0000000000000000-- | Common parts to control network protocols. -- This library assumes that 'Int' is 64bit. module Network.Control ( module Network.Control.Flow, module Network.Control.LRUCache, module Network.Control.Rate, ) where import Network.Control.Flow import Network.Control.LRUCache import Network.Control.Rate network-control-0.1.7/Network/Control/0000755000000000000000000000000007346545000016130 5ustar0000000000000000network-control-0.1.7/Network/Control/Flow.hs0000644000000000000000000001432607346545000017401 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} module Network.Control.Flow ( -- * 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 TxFlow (..), newTxFlow, txWindowSize, WindowSize, -- ** Flow control for receiving RxFlow (..), newRxFlow, rxWindowSize, FlowControlType (..), maybeOpenRxWindow, checkRxLimit, ) where import Data.Bits -- | Default max streams. (64) defaultMaxStreams :: Int defaultMaxStreams = 64 -- | Default max data of a stream. (256K bytes) defaultMaxStreamData :: Int defaultMaxStreamData = 262144 -- | Default max data of a connection. -- -- By default, this is set to @defaultMaxStreams * defaultMaxStreamData@. This -- ensures that streams that are not currently handled cannot exhaust the -- connection window. -- -- If you use a smaller connection window size, you __must__ ensure that if you -- are handling fewer concurrent streams than allowed by 'defaultMaxStreams', -- that the unhandled streams cannot exhaust the connection window, or risk the -- entire system deadlocking. defaultMaxData :: Int defaultMaxData = defaultMaxStreamData * defaultMaxStreams -- | Window size. 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 (Eq, Show) -- | Creating TX flow with a receive buffer size. newTxFlow :: WindowSize -> TxFlow newTxFlow win = TxFlow 0 win -- | 'txfLimit' - 'txfSent'. txWindowSize :: TxFlow -> WindowSize txWindowSize TxFlow{..} = txfLimit - txfSent -- | Flow for receiving. -- -- The goal of 'RxFlow' is to ensure that our network peer does not send us data -- faster than we can consume it. We therefore impose a maximum number of -- unconsumed bytes that we are willing to receive from the peer, which we refer -- to as the buffer size: -- -- @ -- rxfBufSize -- |---------------------------| -- --------------------------------------------> -- ^ ^ -- rxfConsumed rxvReceived -- @ -- -- The peer does not know of course how many bytes we have consumed of the data -- that they sent us, so they keep track of their own limit of how much data -- they are allowed to send. We keep track of this limit also: -- -- @ -- rxfBufSize -- |---------------------------| -- --------------------------------------------> -- ^ ^ ^ -- rxfConsumed rxvReceived | -- rxfLimit -- @ -- -- Each time we receive data from the peer, we check that they do not exceed the -- limit ('checkRxLimit'). When we consume data, we periodically send the peer -- an update (known as a _window update_) of what their new limit is -- ('maybeOpenRxWindow'). To decrease overhead, we only this if the window -- update is at least half the window size. data RxFlow = RxFlow { rxfBufSize :: Int -- ^ Maxinum number of unconsumed bytes the peer can send us -- -- See discussion above for details. , rxfConsumed :: Int -- ^ How much of the data that the peer has sent us have we consumed? -- -- This is an absolute number: the total about of bytes consumed over the -- lifetime of the connection or stream (i.e., not relative to the window). , rxfReceived :: Int -- ^ How much data have we received from the peer? -- -- Like 'rxfConsumed', this is an absolute number. , rxfLimit :: Int -- ^ Current limit on how many bytes the peer is allowed to send us. -- -- Like 'rxfConsumed, this is an absolute number. } deriving (Eq, Show) -- | Creating RX flow with an initial window size. newRxFlow :: WindowSize -> RxFlow newRxFlow win = RxFlow win 0 0 win -- | 'rxfLimit' - 'rxfReceived'. -- -- This is the number of bytes the peer is still allowed to send before they -- must wait for a window update; see 'RxFlow' for details. rxWindowSize :: RxFlow -> WindowSize rxWindowSize RxFlow{..} = rxfLimit - rxfReceived -- | The representation of window size update. data FlowControlType = -- | HTTP\/2 style FCTWindowUpdate | -- | QUIC style FCTMaxData -- | Record that we have consumed some received data -- -- May return a window update; see 'RxFlow' for details. maybeOpenRxWindow :: Int -- ^ The consumed size. -> FlowControlType -> RxFlow -> (RxFlow, Maybe Int) -- ^ 'Just' if the size should be informed to the peer. maybeOpenRxWindow consumed fct flow@RxFlow{..} | winUpdate >= threshold = let flow' = flow { rxfConsumed = rxfConsumed' , rxfLimit = rxfLimit' } update = case fct of FCTWindowUpdate -> winUpdate FCTMaxData -> rxfLimit' in (flow', Just update) | otherwise = let flow' = flow{rxfConsumed = rxfConsumed'} in (flow', Nothing) where rxfConsumed' = rxfConsumed + consumed -- Minimum window update size threshold = rxfBufSize `unsafeShiftR` 1 -- The window update, /if/ we choose to send it rxfLimit' = rxfConsumed' + rxfBufSize winUpdate = rxfLimit' - rxfLimit -- | Checking if received data is acceptable against the -- current window. checkRxLimit :: Int -- ^ The size of received data. -> RxFlow -> (RxFlow, Bool) -- ^ Acceptable if 'True'. checkRxLimit received flow@RxFlow{..} | received' <= rxfLimit = let flow' = flow{rxfReceived = received'} in (flow', True) | otherwise = (flow, False) where received' = rxfReceived + received network-control-0.1.7/Network/Control/LRUCache.hs0000644000000000000000000001054607346545000020060 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} module Network.Control.LRUCache ( -- * LRU cache LRUCache, empty, insert, delete, lookup, lookup', -- * IO LRUCacheRef, newLRUCacheRef, cached, cached', setLRUCapacity, -- * Internal empty', ) where import Data.IORef (IORef, atomicModifyIORef', newIORef) import Data.Int (Int64) import Data.OrdPSQ (OrdPSQ) import qualified Data.OrdPSQ as PSQ import Prelude hiding (lookup) ---------------------------------------------------------------- type Priority = Int64 -- | Sized cache based on least recently used. data LRUCache k v = LRUCache { lcLimit :: Int -- ^ The maximum number of elements in the queue , lcTick :: Priority -- ^ The next logical time , lcQueue :: OrdPSQ k Priority v } deriving (Eq, Show) ---------------------------------------------------------------- -- | Empty 'LRUCache'. /O(1)/ empty :: Int -- ^ The size of 'LRUCache'. -> LRUCache k v empty capacity = LRUCache { lcLimit = capacity , lcTick = 0 , lcQueue = PSQ.empty } -- | Empty 'LRUCache'. /O(1)/ empty' :: Int -- ^ The size of 'LRUCache'. -> Int64 -- ^ Counter -> LRUCache k v empty' capacity tick = LRUCache { lcLimit = capacity , lcTick = tick , lcQueue = PSQ.empty } ---------------------------------------------------------------- trim :: Ord k => LRUCache k v -> LRUCache k v trim c@LRUCache{..} | lcTick == maxBound = let siz = fromIntegral $ PSQ.size lcQueue diff = (maxBound :: Priority) - siz psq = PSQ.unsafeMapMonotonic (\_ p v -> (p - diff, v)) lcQueue in LRUCache { lcLimit = lcLimit , lcTick = siz , lcQueue = psq } | PSQ.size lcQueue > lcLimit = c{lcQueue = PSQ.deleteMin lcQueue} | otherwise = c ---------------------------------------------------------------- -- | Inserting. /O(log n)/ insert :: Ord k => k -> v -> LRUCache k v -> LRUCache k v insert key val c@LRUCache{..} = trim c' where queue = PSQ.insert key lcTick val lcQueue c' = c{lcTick = lcTick + 1, lcQueue = queue} ---------------------------------------------------------------- -- | Deleting. /O(log n)/ delete :: Ord k => k -> LRUCache k v -> LRUCache k v delete k c@LRUCache{..} = c{lcQueue = q} where q = PSQ.delete k lcQueue ---------------------------------------------------------------- -- | Looking up. /O(log n)/ lookup :: Ord k => k -> LRUCache k v -> Maybe v lookup k LRUCache{..} = snd <$> PSQ.lookup k lcQueue -- | Looking up and changing priority. /O(log n)/ lookup' :: Ord k => k -> LRUCache k v -> Maybe (v, LRUCache k v) lookup' k c@LRUCache{..} = case PSQ.alter lookupAndBump k lcQueue of (Nothing, _) -> Nothing (Just v, q) -> let c' = trim $ c{lcTick = lcTick + 1, lcQueue = q} in Just (v, c') where lookupAndBump Nothing = (Nothing, Nothing) -- setting its priority to lcTick lookupAndBump (Just (_p, v)) = (Just v, Just (lcTick, v)) ---------------------------------------------------------------- -- | Mutable LRUCache. newtype LRUCacheRef k v = LRUCacheRef (IORef (LRUCache k v)) -- | Creating 'LRUCacheRef'. newLRUCacheRef :: Int -> IO (LRUCacheRef k v) newLRUCacheRef capacity = LRUCacheRef <$> newIORef (empty capacity) -- | Looking up a target and adjusting the LRU cache. -- If not found, a new value is inserted. -- A pair of value and "found" is returned. cached :: Ord k => LRUCacheRef k v -> k -> IO v -> IO (v, Bool) cached (LRUCacheRef ref) k io = do lookupRes <- atomicModifyIORef' ref $ \c -> case lookup' k c of Nothing -> (c, Nothing) Just (v, c') -> (c', Just v) case lookupRes of Just v -> return (v, True) Nothing -> do v <- io atomicModifyIORef' ref $ \c -> (insert k v c, ()) return (v, False) -- | Looking up a target and adjusting the LRU cache. cached' :: Ord k => LRUCacheRef k v -> k -> IO (Maybe v) cached' (LRUCacheRef ref) k = do atomicModifyIORef' ref $ \c -> case lookup' k c of Nothing -> (c, Nothing) Just (v, c') -> (c', Just v) -- | Setting capacity of the LRU cache. setLRUCapacity :: LRUCacheRef k v -> Int -> IO () setLRUCapacity (LRUCacheRef ref) lim = atomicModifyIORef' ref $ \c -> (c{lcLimit = lim}, ()) network-control-0.1.7/Network/Control/Rate.hs0000644000000000000000000000231007346545000017353 0ustar0000000000000000module Network.Control.Rate ( -- * Rate control Rate, newRate, getRate, addRate, ) where import Data.IORef import Data.UnixTime -- | Type for rating. newtype Rate = Rate (IORef Counter) data Counter = Counter Int UnixTime -- | Creating a new 'Rate'. newRate :: IO Rate newRate = do cntr <- Counter 0 <$> getUnixTime Rate <$> newIORef cntr -- | Getting the current rate. -- If one or more seconds have passed since the previous call, the -- counter is re-initialized with 1 and it is returned. Otherwise, -- incremented counter number is returned. getRate :: Rate -> IO Int getRate r = addRate r 1 -- | Getting the current rate. -- If one or more seconds have passed since the previous call, the -- counter is re-initialized with the second argument and it is -- returned. Otherwise, increased counter number is returned. addRate :: Rate -> Int -> IO Int addRate (Rate ref) x = do Counter n beg <- readIORef ref cur <- getUnixTime if (cur `diffUnixTime` beg) > 1 then do let n' = x writeIORef ref $ Counter n' cur return n' else do let n' = n + x writeIORef ref $ Counter n' beg return n' network-control-0.1.7/network-control.cabal0000644000000000000000000000234707346545000017220 0ustar0000000000000000cabal-version: 3.0 name: network-control version: 0.1.7 license: BSD-3-Clause license-file: LICENSE maintainer: kazu@iij.ad.jp author: Kazu Yamamoto synopsis: Library to control network protocols description: Common parts to control network protocols category: Network build-type: Simple extra-doc-files: Changelog.md library exposed-modules: Network.Control other-modules: Network.Control.Flow Network.Control.LRUCache Network.Control.Rate default-language: Haskell2010 default-extensions: Strict StrictData ghc-options: -Wall build-depends: 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 Network.Control.LRUCacheSpec default-language: Haskell2010 default-extensions: Strict StrictData ghc-options: -Wall -threaded build-depends: base, hspec >=1.3, network-control, QuickCheck, pretty-simple, text network-control-0.1.7/test/Network/Control/0000755000000000000000000000000007346545000017107 5ustar0000000000000000network-control-0.1.7/test/Network/Control/FlowSpec.hs0000644000000000000000000001417507346545000021175 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-orphans -Wno-incomplete-patterns #-} module Network.Control.FlowSpec (spec) 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) instance Arbitrary RxFlow where -- Prefer to generate a simple window size arbitrary = newRxFlow <$> oneof [ elements [1, 10, 50, 100] , 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 = do (newStep, newFlow) <- runStep oldFlow <$> genStep oldFlow ((ix, newStep, newFlow) :) <$> runManySteps (len - 1) (ix + 1) newFlow genStep :: RxFlow -> Gen (Step Op) genStep oldFlow = oneof [mkConsume, mkReceive] where -- Negative frames are non-sensical; frames larger than the window -- size are theoretically possible (but will trivially be rejected -- as exceeding the window). mkReceive = Step Receive <$> chooseInt (0, rxfBufSize oldFlow * 2) -- We can only consume as much as we have received -- (but it is in principle not a problem to consume 0 bytes) mkConsume = Step Consume <$> chooseInt (0, rxfReceived oldFlow - rxfConsumed oldFlow) 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 initialFlow steps) = concat [ -- Take a prefix (starting with the same initialFlow) Trace initialFlow <$> init (inits steps) , -- Take a suffix (starting with a later initialFlow) map shiftInitialFlow $ drop 1 (tails steps) ] where shiftInitialFlow :: [(Int, Step OpWithResult, RxFlow)] -> Trace shiftInitialFlow [] = Trace initialFlow [] shiftInitialFlow ((_, _, initialFlow') : rest) = Trace initialFlow' rest -- 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 -- There is no point duplicating precisely the same logic here as in -- 'maybeOpenRxWindow': that would result in circular reasoning. -- Instead, we leave 'maybeOpenRxWindow' some implementation -- freedom, and only verify that the window update makes sense: -- -- (a) It can't be too large: the new window after the update should -- never exceed the specified buffer size. -- (b) It can't be too late: if we consume /all/ received data, and -- do not allow the peer to send any further data, then the -- system deadlocks. -- (c) It shouldn't be too small: very small window updates are -- wasteful. -- -- Within these parameters 'maybeOpenRxWindow' can decide when to -- send window updates and how large they should be. We also don't -- set the bound on (c) too strict. newFlow `shouldBe` RxFlow { rxfBufSize = rxfBufSize oldFlow , rxfConsumed = rxfConsumed oldFlow + arg , rxfReceived = rxfReceived oldFlow , rxfLimit = case limitDelta of Nothing -> rxfLimit oldFlow Just upd -> rxfLimit oldFlow + upd } -- Condition (a) newFlow `shouldSatisfy` \flow -> rxfLimit flow - rxfConsumed flow <= rxfBufSize flow -- Condition (b) newFlow `shouldSatisfy` \flow -> rxfLimit flow > rxfConsumed flow -- Condition (c) limitDelta `shouldSatisfy` \case Nothing -> True Just upd -> upd >= rxfBufSize newFlow `div` 8 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 describe "Flow" $ do prop "state transition graph checks out" $ \trace -> counterexample (unpack $ pShowNoColor trace) (assertTrace trace) network-control-0.1.7/test/Network/Control/LRUCacheSpec.hs0000644000000000000000000000171407346545000021647 0ustar0000000000000000module Network.Control.LRUCacheSpec (spec) where import Data.Maybe import Network.Control import qualified Network.Control as LRU import Test.Hspec spec :: Spec spec = do describe "LRUCache" $ do it "can keep entry if looked up" $ do let cache = insert 'b' "bar" $ insert 'a' "foo" $ empty 2 (v, cache') = fromJust $ LRU.lookup' 'a' cache v `shouldBe` "foo" let cache'' = insert 'c' "baz" cache' fst <$> LRU.lookup' 'a' cache'' `shouldBe` Just "foo" fst <$> LRU.lookup' 'b' cache'' `shouldBe` Nothing fst <$> LRU.lookup' 'c' cache'' `shouldBe` Just "baz" it "can rebuild PSQ when reached the limit" $ do let cache = insert 'b' "bar" $ insert 'a' "foo" $ empty' 2 (maxBound - 2) show cache `shouldBe` "LRUCache {lcLimit = 2, lcTick = 2, lcQueue = Winner (E 'a' 0 \"foo\") (RLoser 1 (E 'b' 1 \"bar\") Start 'a' Start) 'b'}" network-control-0.1.7/test/0000755000000000000000000000000007346545000014036 5ustar0000000000000000network-control-0.1.7/test/Spec.hs0000644000000000000000000000005407346545000015263 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-}