wip HEsUhP3CJN

hbs2-core/lib/HBS2/Defaults.hs

@@ -16,7 +16,7 @@ defBurst :: Integral a => a
 defBurst = 4
 
 defBurstMax :: Integral a => a
-defBurstMax = 128
+defBurstMax = 32
 
 -- defChunkSize :: Integer
 defChunkSize :: Integral a => a
@@ -61,11 +61,11 @@ defBlockInfoTimeout = 2
 
 -- how much time wait for block from peer?
 defBlockWaitMax :: Timeout 'Seconds
-defBlockWaitMax = 2.5 :: Timeout 'Seconds
+defBlockWaitMax = 1.5 :: Timeout 'Seconds
 
 -- how much time wait for block from peer?
 defChunkWaitMax :: Timeout 'Seconds
-defChunkWaitMax = 0.35 :: Timeout 'Seconds
+defChunkWaitMax = 0.15 :: Timeout 'Seconds
 
 defSweepTimeout :: Timeout 'Seconds
 defSweepTimeout = 30 -- FIXME: only for debug!

hbs2-peer/app/BlockDownload.hs

@@ -293,8 +293,8 @@ downloadFromWithPeer peer thisBkSize h = do
             -- liftIO $ atomically $ modifyTVar (view peerErrors pinfo) succ
             updatePeerInfo True pinfo
 
-            newBurst' <- liftIO $ readTVarIO burstSizeT
+            newBurst <- liftIO $ readTVarIO burstSizeT
-            let newBurst = max defBurst $ floor (realToFrac newBurst' * 0.5 )
+            -- let newBurst = max defBurst $ floor (realToFrac newBurst' * 0.5 )
 
             liftIO $ atomically $ modifyTVar (view peerDownloaded pinfo) (+chunksN)
 
@@ -348,6 +348,9 @@ instance HasPeerLocator e m => HasPeerLocator e (BlockDownloadM e m) where
   getPeerLocator = lift getPeerLocator
 
 
+-- NOTE: updatePeerInfo is CC
+--   updatePeerInfo is actuall doing CC (congestion control)
+
 updatePeerInfo :: MonadIO m => Bool -> PeerInfo e -> m ()
 updatePeerInfo onError pinfo = do
 
@@ -356,6 +359,8 @@ updatePeerInfo onError pinfo = do
   void $ liftIO $ atomically $ do
 
           bu        <- readTVar (view peerBurst pinfo)
+          buMax     <- readTVar (view peerBurstMax pinfo)
+          buSet     <- readTVar (view peerBurstSet pinfo)
           errs      <- readTVar (view peerErrors pinfo)
           errsLast  <- readTVar (view peerErrorsLast pinfo)
           t0        <- readTVar (view peerLastWatched pinfo)
@@ -367,22 +372,35 @@ updatePeerInfo onError pinfo = do
 
           let eps = floor (dE / dT)
 
-          let bu1 = if (down - downLast > 0 || onError) then
+          when (down - downLast > 0 || onError) do
-                      max 1 $ min defBurstMax
+
-                              $ if eps == 0 then
+            (bu1, bus) <- if  eps == 0 then do
-                                   ceiling $ realToFrac bu * 1.10 -- FIXME: to defaults
+                            let bmm = fromMaybe defBurstMax buMax
-                                 else
+                            let buN = min bmm (ceiling $ (realToFrac bu * 1.05))
-                                   floor $ realToFrac bu * 0.55
+                            pure (buN, trimUp 50 $ IntSet.insert buN buSet)
-                    else
+                          else do
-                      max defBurst $ floor (realToFrac bu * 0.75)
+                            let buM = headMay $ drop 2 $ IntSet.toDescList buSet
+                            writeTVar (view peerBurstMax pinfo) buM
+                            -- let s = IntSet.size buSet
+                            let buN = defBurst -- atDef defBurst (IntSet.toList buSet) (s `div` 2 )
+                            pure (buN, trimDown 50 $ IntSet.insert buN buSet)
+
 
             writeTVar (view peerErrorsLast pinfo) errs
             writeTVar (view peerLastWatched pinfo) t1
             writeTVar (view peerErrorsPerSec pinfo) eps
             writeTVar (view peerBurst pinfo) bu1
+            writeTVar (view peerBurstSet pinfo) bus
             writeTVar (view peerDownloadedLast pinfo) down
 
 
+    where
+      trimUp n s | IntSet.size s >= n = IntSet.deleteMin s
+                 | otherwise       = s
+
+      trimDown n s | IntSet.size s >= n = IntSet.deleteMax s
+                   | otherwise       = s
+
 blockDownloadLoop :: forall e  m . ( m ~ PeerM e IO
                                    ,  MonadIO m
                                    , Request e (BlockInfo e) m
@@ -416,7 +434,7 @@ blockDownloadLoop env0 = do
 
 
   void $ liftIO $ async $ forever $ withPeerM e do
-    pause @'Seconds 2
+    pause @'Seconds 5
 
     pee <- knownPeers @e pl
     npi <- newPeerInfo
@@ -430,7 +448,7 @@ blockDownloadLoop env0 = do
 
   -- TODO: peer info loop
   void $ liftIO $ async $ forever $ withPeerM e $ do
-    pause @'Seconds 20
+    pause @'Seconds 10
     pee <- knownPeers @e pl
 
     npi <- newPeerInfo
@@ -440,8 +458,10 @@ blockDownloadLoop env0 = do
     for_ pee $ \p -> do
       pinfo <- fetch True npi (PeerInfoKey p) id
       burst  <- liftIO $ readTVarIO (view peerBurst pinfo)
+      buM    <- liftIO $ readTVarIO (view peerBurstMax pinfo)
       errors <- liftIO $ readTVarIO (view peerErrorsPerSec pinfo)
-      debug $ "peer" <+> pretty p <+> "burst: " <+> pretty burst
+      debug $ "peer" <+> pretty p <+> "burst:" <+> pretty burst
+                                  <+> "burst-max:" <+> pretty buM
                                   <+> "errors:" <+> pretty errors
       pure ()
 

hbs2-peer/app/PeerInfo.hs

@@ -25,11 +25,14 @@ import Control.Concurrent.STM
 import Control.Monad
 import Control.Concurrent.Async
 import System.Random.Shuffle
+import Data.IntSet (IntSet)
 import Prettyprinter
 
 data PeerInfo e =
   PeerInfo
   { _peerBurst          :: TVar Int
+  , _peerBurstMax       :: TVar (Maybe Int)
+  , _peerBurstSet       :: TVar IntSet
   , _peerErrors         :: TVar Int
   , _peerErrorsLast     :: TVar Int
   , _peerErrorsPerSec   :: TVar Int
@@ -46,6 +49,8 @@ makeLenses 'PeerInfo
 newPeerInfo :: MonadIO m => m (PeerInfo e)
 newPeerInfo = liftIO do
   PeerInfo <$> newTVarIO defBurst
+           <*> newTVarIO Nothing
+           <*> newTVarIO mempty
            <*> newTVarIO 0
            <*> newTVarIO 0
            <*> newTVarIO 0