diff --git a/hbs2-core/lib/HBS2/Defaults.hs b/hbs2-core/lib/HBS2/Defaults.hs index 5a0d265b..f249c312 100644 --- a/hbs2-core/lib/HBS2/Defaults.hs +++ b/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! diff --git a/hbs2-peer/app/BlockDownload.hs b/hbs2-peer/app/BlockDownload.hs index b2e31dea..e42a4cf2 100644 --- a/hbs2-peer/app/BlockDownload.hs +++ b/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 - let newBurst = max defBurst $ floor (realToFrac newBurst' * 0.5 ) + newBurst <- liftIO $ readTVarIO burstSizeT + -- 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 - max 1 $ min defBurstMax - $ if eps == 0 then - ceiling $ realToFrac bu * 1.10 -- FIXME: to defaults - else - floor $ realToFrac bu * 0.55 - else - max defBurst $ floor (realToFrac bu * 0.75) + when (down - downLast > 0 || onError) do - writeTVar (view peerErrorsLast pinfo) errs - writeTVar (view peerLastWatched pinfo) t1 - writeTVar (view peerErrorsPerSec pinfo) eps - writeTVar (view peerBurst pinfo) bu1 - writeTVar (view peerDownloadedLast pinfo) down + (bu1, bus) <- if eps == 0 then do + let bmm = fromMaybe defBurstMax buMax + let buN = min bmm (ceiling $ (realToFrac bu * 1.05)) + pure (buN, trimUp 50 $ IntSet.insert buN buSet) + else do + 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 () diff --git a/hbs2-peer/app/PeerInfo.hs b/hbs2-peer/app/PeerInfo.hs index 4308f157..24d43fa2 100644 --- a/hbs2-peer/app/PeerInfo.hs +++ b/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