voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

minor-fix

This commit is contained in:
Dmitry Zuikov 2023-02-26 14:14:58 +03:00
parent fb224635a5
commit 5b11e1d9a5
2 changed files with 11 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
hbs2-peer/app/BlockDownload.hs
View File

@ -480,6 +480,7 @@ blockDownloadLoop env0 = do
tinfo <- asks (view blockPeers) tinfo <- asks (view blockPeers)
binfo <- liftIO $ readTVarIO tinfo binfo <- liftIO $ readTVarIO tinfo
wip <- asks (view blockWip) wip <- asks (view blockWip)
wipCnt <- asks (view blocksWipCnt) >>= liftIO . readTVarIO
liftIO $ Cache.purgeExpired wip liftIO $ Cache.purgeExpired wip
@ -494,7 +495,7 @@ blockDownloadLoop env0 = do
po <- asks (view peerPostponed) >>= liftIO . readTVarIO po <- asks (view peerPostponed) >>= liftIO . readTVarIO
notice $ "maintain blocks wip" <+> pretty (Set.size aliveWip) notice $ "maintain blocks wip" <+> pretty wipCnt
<+> "postponed" <+> "postponed"
<+> pretty (HashMap.size po) <+> pretty (HashMap.size po)

6
hbs2-peer/app/PeerTypes.hs
View File

@ -150,6 +150,7 @@ data DownloadEnv e =
, _peerPostponed :: TVar (HashMap (Hash HbSync) ()) , _peerPostponed :: TVar (HashMap (Hash HbSync) ())
, _blockStored :: Cache (Hash HbSync) () , _blockStored :: Cache (Hash HbSync) ()
, _blockBanned :: Cache (Hash HbSync, Peer e) () , _blockBanned :: Cache (Hash HbSync, Peer e) ()
, _blocksWipCnt :: TVar Int
} }
makeLenses 'DownloadEnv makeLenses 'DownloadEnv
@ -167,6 +168,7 @@ newDownloadEnv = liftIO do
<*> newTVarIO mempty <*> newTVarIO mempty
<*> Cache.newCache (Just defBlockWipTimeout) <*> Cache.newCache (Just defBlockWipTimeout)
<*> Cache.newCache (Just defBlockBanTime) <*> Cache.newCache (Just defBlockBanTime)
<*> newTVarIO 0
newtype BlockDownloadM e m a = newtype BlockDownloadM e m a =
BlockDownloadM { fromBlockDownloadM :: ReaderT (DownloadEnv e) m a } BlockDownloadM { fromBlockDownloadM :: ReaderT (DownloadEnv e) m a }
@ -275,6 +277,7 @@ addDownload h = do
po <- asks (view peerPostponed) po <- asks (view peerPostponed)
tinq <- asks (view blockInQ) tinq <- asks (view blockInQ)
wipCnt <- asks (view blocksWipCnt)
doAdd <- do liftIO $ atomically $ stateTVar tinq doAdd <- do liftIO $ atomically $ stateTVar tinq
\hm -> case HashMap.lookup h hm of \hm -> case HashMap.lookup h hm of
@ -291,6 +294,7 @@ addDownload h = do
liftIO do liftIO do
atomically $ do atomically $ do
modifyTVar tinq $ HashMap.insert h () modifyTVar tinq $ HashMap.insert h ()
modifyTVar wipCnt succ
writeTQueue q h writeTQueue q h
Cache.insert wip h () Cache.insert wip h ()
@ -336,6 +340,7 @@ removeFromWip h = do
sz <- asks (view blockPeers) sz <- asks (view blockPeers)
tinq <- asks (view blockInQ) tinq <- asks (view blockInQ)
po <- asks (view peerPostponed) po <- asks (view peerPostponed)
wi <- asks (view blocksWipCnt)
liftIO $ Cache.delete wip h liftIO $ Cache.delete wip h
liftIO $ atomically $ do liftIO $ atomically $ do
@ -343,6 +348,7 @@ removeFromWip h = do
modifyTVar' sz (HashMap.delete h) modifyTVar' sz (HashMap.delete h)
modifyTVar' tinq (HashMap.delete h) modifyTVar' tinq (HashMap.delete h)
modifyTVar' po (HashMap.delete h) modifyTVar' po (HashMap.delete h)
modifyTVar' wi (max 0 . pred)
hasPeerThread :: (MyPeer e, MonadIO m) => Peer e -> BlockDownloadM e m Bool hasPeerThread :: (MyPeer e, MonadIO m) => Peer e -> BlockDownloadM e m Bool
hasPeerThread p = do hasPeerThread p = do