network-control (empty) → 0.0.0

raw patch · 7 files changed

+272/−0 lines, 7 filesdep +basedep +psqueuesdep +unix-time

Dependencies added: base, psqueues, unix-time

Files

• Changelog.md +5/−0
• LICENSE +29/−0
• Network/Control.hs +10/−0
• Network/Control/Flow.hs +103/−0
• Network/Control/LRUCache.hs +52/−0
• Network/Control/Rate.hs +46/−0
• network-control.cabal +27/−0

@@ -0,0 +1,5 @@+# Revision history for network-control++## 0.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

@@ -0,0 +1,29 @@+Copyright (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.

@@ -0,0 +1,10 @@+-- | Common parts to control network protocols.+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

@@ -0,0 +1,103 @@+{-# LANGUAGE RecordWildCards #-}++module Network.Control.Flow (+    -- * Flow control for sending+    TxFlow (..),+    newTxFlow,+    txWindowSize,+    WindowSize,++    -- * Flow control for receiving+    RxFlow (..),+    newRxFlow,+    FlowControlType (..),+    maybeOpenRxWindow,+    checkRxLimit,+) where++import Data.Bits++-- | Window size.+type WindowSize = Int++-- | Flow for sending+data TxFlow = TxFlow+    { txfSent :: Int+    , txfLimit :: Int+    }+    deriving (Show)++-- | Creating TX flow with an initial window size.+newTxFlow :: WindowSize -> TxFlow+newTxFlow win = TxFlow 0 win++-- | 'txfLimit' - 'txfSent'.+txWindowSize :: TxFlow -> WindowSize+txWindowSize TxFlow{..} = txfLimit - txfSent++-- | Flow for receiving+data RxFlow = RxFlow+    { rxfWindow :: WindowSize+    , rxfConsumed :: Int+    , rxfReceived :: Int+    , rxfLimit :: Int+    }+    deriving (Show)++-- | Creating RX flow with an initial window size.+newRxFlow :: WindowSize -> RxFlow+newRxFlow win = RxFlow win 0 0 win++-- | The representation of window size update.+data FlowControlType+    = -- | HTTP\/2 style+      FCTWindowUpdate+    | -- | 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.+--   the representation of window size update is returned.+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{..}+    | available < threshold =+        let limit = consumed' + rxfWindow+            flow' =+                flow+                    { rxfConsumed = consumed'+                    , rxfLimit = limit+                    }+            update = case fct of+                FCTWindowUpdate -> limit - rxfLimit+                FCTMaxData -> limit+         in (flow', Just update)+    | otherwise =+        let flow' = flow{rxfConsumed = consumed'}+         in (flow', Nothing)+  where+    available = rxfLimit - rxfReceived+    threshold = rxfWindow .>>. 1+    consumed' = rxfConsumed + consumed++-- | 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

@@ -0,0 +1,52 @@+{-# LANGUAGE RecordWildCards #-}++module Network.Control.LRUCache (+    -- * LRU cache+    LRUCache,+    empty,+    insert,+    delete,+    lookup,+) where++import Prelude hiding (lookup)++import Data.OrdPSQ (OrdPSQ)+import qualified Data.OrdPSQ as PSQ++type Priority = Int++-- | Sized cache based on least recently used.+data LRUCache k v = LRUCache+    { lcLimit :: Int+    , lcSize :: Int+    , lcTick :: Priority+    , lcQueue :: OrdPSQ k Priority v+    }++-- | Empty 'LRUCache'.+empty+    :: Int+    -- ^ The size of 'LRUCache'.+    -> LRUCache k v+empty lim = LRUCache lim 0 0 PSQ.empty++-- | Inserting.+insert :: Ord k => k -> v -> LRUCache k v -> LRUCache k v+insert k v c@LRUCache{..}+    | lcSize == lcLimit =+        let q = PSQ.insert k lcTick v $ PSQ.deleteMin lcQueue+         in c{lcTick = lcTick + 1, lcQueue = q}+    | otherwise =+        let q = PSQ.insert k lcTick v lcQueue+         in c{lcTick = lcTick + 1, lcQueue = q, lcSize = lcSize + 1}++-- | Deleting.+delete :: Ord k => k -> LRUCache k v -> LRUCache k v+delete k c@LRUCache{..} =+    let q = PSQ.delete k lcQueue+     in c{lcQueue = q, lcSize = lcSize - 1}++-- | Looking up.+lookup :: Ord k => k -> LRUCache k v -> Maybe v+lookup k LRUCache{..} = snd <$> PSQ.lookup k lcQueue

@@ -0,0 +1,46 @@+module 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'

@@ -0,0 +1,27 @@+cabal-version:   3.0+name:            network-control+version:         0.0.0+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.15 && <5,+        psqueues,+        unix-time