mirror of https://github.com/voidlizard/hbs2
block-download-fix
This commit is contained in:
Dmitry Zuikov
parent
153139d90b
commit
e10fae26db
|
|
@ -59,6 +59,9 @@ defRequestLimitSec = 60
|
|||
defBlockBanTime :: TimeSpec
|
||||
defBlockBanTime = toTimeSpec defBlockBanTimeSec
|
||||
|
||||
defBlockPostponeTime :: TimeSpec
|
||||
defBlockPostponeTime = toTimeSpec ( 60 :: Timeout 'Seconds)
|
||||
|
||||
defBlockBanTimeSec :: Timeout 'Seconds
|
||||
defBlockBanTimeSec = 60 :: Timeout 'Seconds
|
||||
|
||||
|
|
|
|||
|
|
@ -24,17 +24,16 @@ import HBS2.System.Logger.Simple
|
|||
|
||||
import PeerTypes
|
||||
import PeerInfo
|
||||
import Brains
|
||||
|
||||
import Control.Concurrent.Async
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.Cache qualified as Cache
|
||||
import Data.Foldable hiding (find)
|
||||
import Data.HashMap.Strict qualified as HashMap
|
||||
import Data.HashSet qualified as HashSet
|
||||
import Data.IntMap (IntMap)
|
||||
import Data.IntMap qualified as IntMap
|
||||
import Data.IntSet qualified as IntSet
|
||||
|
|
@ -42,7 +41,7 @@ import Data.List qualified as List
|
|||
import Data.Maybe
|
||||
import Data.Set qualified as Set
|
||||
import Lens.Micro.Platform
|
||||
|
||||
import Control.Concurrent
|
||||
|
||||
getBlockForDownload :: MonadIO m => BlockDownloadM e m (Hash HbSync)
|
||||
getBlockForDownload = do
|
||||
|
|
@ -53,12 +52,13 @@ getBlockForDownload = do
|
|||
modifyTVar' inq (HashMap.delete h)
|
||||
pure h
|
||||
|
||||
withBlockForDownload :: (MonadIO m, MyPeer e, HasStorage m, HasPeerLocator e m)
|
||||
withBlockForDownload :: forall e m . (MonadIO m, MyPeer e, HasStorage m, HasPeerLocator e m)
|
||||
=> Peer e
|
||||
-> BlockDownloadM e m ()
|
||||
-> (Hash HbSync -> BlockDownloadM e m ())
|
||||
-> BlockDownloadM e m ()
|
||||
|
||||
withBlockForDownload p action = do
|
||||
withBlockForDownload p noBlockAction action = do
|
||||
-- FIXME: busyloop-e46ad5e0
|
||||
--
|
||||
sto <- lift getStorage
|
||||
|
|
@ -67,16 +67,13 @@ withBlockForDownload p action = do
|
|||
|
||||
here <- liftIO $ hasBlock sto h <&> isJust
|
||||
|
||||
if here then do
|
||||
processBlock h
|
||||
else do
|
||||
banned <- isBanned p h
|
||||
trace $ "withBlockForDownload" <+> pretty p <+> pretty h
|
||||
if banned then do
|
||||
-- trace $ "skip banned block" <+> pretty p <+> pretty h
|
||||
addDownload h
|
||||
else do
|
||||
action h
|
||||
brains <- asks (view downloadBrains)
|
||||
|
||||
should <- shouldDownloadBlock brains p h
|
||||
|
||||
if | here -> processBlock h
|
||||
| should -> onBlockDownloadAttempt brains p h >> action h
|
||||
| otherwise -> noBlockAction >> addDownload mzero h
|
||||
|
||||
addBlockInfo :: (MonadIO m, MyPeer e)
|
||||
=> Peer e
|
||||
|
|
@ -114,6 +111,10 @@ processBlock h = do
|
|||
|
||||
sto <- lift getStorage
|
||||
|
||||
brains <- asks (view downloadBrains)
|
||||
|
||||
let parent = Just h
|
||||
|
||||
bt <- liftIO $ getBlock sto h <&> fmap (tryDetect h)
|
||||
|
||||
-- FIXME: если блок нашёлся, то удаляем его из wip
|
||||
|
|
@ -123,7 +124,7 @@ processBlock h = do
|
|||
let handleHrr = \(hrr :: Either (Hash HbSync) [HashRef]) -> do
|
||||
|
||||
case hrr of
|
||||
Left hx -> addDownload hx
|
||||
Left hx -> addDownload parent hx
|
||||
Right hr -> do
|
||||
|
||||
for_ hr $ \(HashRef blk) -> do
|
||||
|
|
@ -140,29 +141,29 @@ processBlock h = do
|
|||
-- FIXME: fugure out if it's really required
|
||||
|
||||
else do
|
||||
addDownload blk
|
||||
addDownload parent blk
|
||||
|
||||
case bt of
|
||||
Nothing -> addDownload h
|
||||
Nothing -> addDownload mzero h
|
||||
|
||||
Just (SeqRef (SequentialRef n (AnnotatedHashRef a' b))) -> do
|
||||
maybe1 a' none $ \a -> do
|
||||
addDownload (fromHashRef a)
|
||||
addDownload parent (fromHashRef a)
|
||||
|
||||
addDownload (fromHashRef b)
|
||||
addDownload parent (fromHashRef b)
|
||||
|
||||
Just (AnnRef h) -> do
|
||||
addDownload h
|
||||
addDownload parent h
|
||||
|
||||
Just (MerkleAnn ann) -> do
|
||||
case (_mtaMeta ann) of
|
||||
NoMetaData -> pure ()
|
||||
ShortMetadata {} -> pure ()
|
||||
AnnHashRef h -> addDownload h
|
||||
AnnHashRef h -> addDownload parent h
|
||||
|
||||
case (_mtaCrypt ann) of
|
||||
NullEncryption -> pure ()
|
||||
CryptAccessKeyNaClAsymm h -> addDownload h
|
||||
CryptAccessKeyNaClAsymm h -> addDownload parent h
|
||||
|
||||
debug $ "GOT WRAPPED MERKLE. requesting nodes/leaves" <+> pretty h
|
||||
walkMerkleTree (_mtaTree ann) (liftIO . getBlock sto) handleHrr
|
||||
|
|
@ -188,6 +189,8 @@ downloadFromWithPeer :: forall e m . ( DownloadFromPeerStuff e m
|
|||
-> BlockDownloadM e m ()
|
||||
downloadFromWithPeer peer thisBkSize h = do
|
||||
|
||||
brains <- asks (view downloadBrains)
|
||||
|
||||
npi <- newPeerInfo
|
||||
pinfo <- lift $ fetch True npi (PeerInfoKey peer) id
|
||||
|
||||
|
|
@ -284,6 +287,7 @@ downloadFromWithPeer peer thisBkSize h = do
|
|||
-- debug "PROCESS BLOCK"
|
||||
lift $ expire @e key
|
||||
void $ liftIO $ putBlock sto block
|
||||
onBlockDownloaded brains peer h
|
||||
void $ processBlock h
|
||||
else do
|
||||
trace "HASH NOT MATCH / PEER MAYBE JERK"
|
||||
|
|
@ -426,8 +430,11 @@ blockDownloadLoop env0 = do
|
|||
pause @'Seconds 5
|
||||
debug "I'm a peer maintaining thread"
|
||||
|
||||
brains <- withDownload env0 $ asks (view downloadBrains)
|
||||
pee <- knownPeers @e pl
|
||||
|
||||
onKnownPeers brains pee
|
||||
|
||||
for_ pee $ \p -> do
|
||||
pinfo' <- find (PeerInfoKey p) id
|
||||
auth <- find (KnownPeerKey p) id <&> isJust
|
||||
|
|
@ -516,16 +523,13 @@ blockDownloadLoop env0 = do
|
|||
|
||||
liftIO $ atomically $ writeTVar tinfo alive
|
||||
|
||||
po <- asks (view peerPostponed) >>= liftIO . readTVarIO
|
||||
ba <- asks (view blockBanned ) >>= liftIO . Cache.size
|
||||
po <- postoponedNum
|
||||
|
||||
wipNum <- liftIO $ Cache.size wip
|
||||
|
||||
notice $ "maintain blocks wip" <+> pretty wipNum
|
||||
<+> "postponed"
|
||||
<+> pretty (HashMap.size po)
|
||||
<+> "banned"
|
||||
<+> pretty ba
|
||||
<+> pretty po
|
||||
|
||||
withDownload env0 do
|
||||
|
||||
|
|
@ -570,62 +574,20 @@ postponedLoop env0 = do
|
|||
debug "download stuck"
|
||||
for_ wip1 $ \h -> do
|
||||
removeFromWip h
|
||||
addDownload h
|
||||
addDownload Nothing h
|
||||
|
||||
wip3 <- asks (view blockWip) >>= liftIO . Cache.keys
|
||||
liftIO $ atomically $ writeTVar twip (length wip3)
|
||||
|
||||
void $ liftIO $ async $ withPeerM e $ withDownload env0 do
|
||||
forever do
|
||||
pause @'Seconds 60
|
||||
ban <- asks (view blockBanned)
|
||||
void $ liftIO $ Cache.purgeExpired ban
|
||||
wip <- asks (view blockWip) >>= liftIO . Cache.keys <&> HashSet.fromList
|
||||
trace $ "wipe banned!"
|
||||
void $ liftIO $ Cache.filterWithKey (\(h,_) _ -> HashSet.member h wip ) ban
|
||||
pause @'Seconds 30
|
||||
trace "UNPOSTPONE LOOP"
|
||||
po <- asks (view blockPostponedTo) >>= liftIO . Cache.toList
|
||||
for_ po $ \(h, _, expired) -> do
|
||||
when (isJust expired) do
|
||||
unpostponeBlock h
|
||||
|
||||
void $ liftIO $ async $ withPeerM e $ withDownload env0 do
|
||||
|
||||
po <- asks (view peerPostponed)
|
||||
pl <- getPeerLocator @e
|
||||
|
||||
forever do
|
||||
|
||||
pause @'Seconds 10
|
||||
debug "findPosponedLoop"
|
||||
|
||||
ba <- asks (view blockBanned) >>= liftIO . Cache.keys
|
||||
pipsAll <- knownPeers @e pl <&> HashSet.fromList
|
||||
|
||||
let blk2pip = HashMap.fromListWith (<>) [ (h, HashSet.singleton p) | (h,p) <- ba ]
|
||||
& HashMap.toList
|
||||
|
||||
for_ blk2pip $ \(h, banned) -> do
|
||||
let notBanned = HashSet.difference pipsAll banned
|
||||
when (null notBanned) do
|
||||
liftIO $ atomically $ modifyTVar' po $ HashMap.insert h ()
|
||||
|
||||
|
||||
void $ liftIO $ async $ withPeerM e $ withDownload env0 do
|
||||
po <- asks (view peerPostponed)
|
||||
ban <- asks (view blockBanned)
|
||||
stored <- asks (view blockStored)
|
||||
|
||||
forever do
|
||||
-- FIXME: del-posponed-time-hardcode
|
||||
pause @'Seconds 60
|
||||
debug "postponedLoop"
|
||||
|
||||
liftIO $ Cache.purgeExpired ban
|
||||
liftIO $ Cache.purgeExpired stored
|
||||
|
||||
back <- liftIO $ atomically $ stateTVar po $ \hm ->
|
||||
let els = HashMap.toList hm in
|
||||
-- FIXME: back-from-postponed-size-var
|
||||
let (x,xs) = List.splitAt 10 els in
|
||||
(fmap fst x, HashMap.fromList xs)
|
||||
|
||||
for_ back returnPostponed
|
||||
|
||||
peerDownloadLoop :: forall e m . ( MyPeer e
|
||||
, Sessions e (KnownPeer e) m
|
||||
|
|
@ -696,6 +658,9 @@ peerDownloadLoop peer = do
|
|||
writeTVar downFail 0
|
||||
modifyTVar downBlk succ
|
||||
|
||||
let noBlkAction = do
|
||||
liftIO yield
|
||||
|
||||
forever do
|
||||
|
||||
liftIO do
|
||||
|
|
@ -723,7 +688,7 @@ peerDownloadLoop peer = do
|
|||
|
||||
maybe1 mbauth noAuth $ \(_,_) -> do
|
||||
|
||||
withBlockForDownload peer $ \h -> do
|
||||
withBlockForDownload peer noBlkAction $ \h -> do
|
||||
-- TODO: insert-busyloop-counter-for-block-request
|
||||
-- trace $ "withBlockForDownload" <+> pretty peer <+> pretty h
|
||||
|
||||
|
|
@ -738,8 +703,7 @@ peerDownloadLoop peer = do
|
|||
|
||||
Nothing | noBlk -> do
|
||||
trace $ pretty peer <+> "does not have block" <+> pretty h
|
||||
banBlock peer h
|
||||
addDownload h
|
||||
addDownload mzero h
|
||||
|
||||
Nothing -> do
|
||||
incBlockSizeReqCount h
|
||||
|
|
@ -756,7 +720,7 @@ peerDownloadLoop peer = do
|
|||
unless here $
|
||||
liftIO $ Cache.insert noBlock h ()
|
||||
|
||||
addDownload h
|
||||
addDownload mzero h
|
||||
|
||||
Right (Just s) -> do
|
||||
updateBlockPeerSize h peer s
|
||||
|
|
|
|||
|
|
@ -0,0 +1,153 @@
|
|||
{-# Language AllowAmbiguousTypes #-}
|
||||
{-# Language UndecidableInstances #-}
|
||||
{-# Language TemplateHaskell #-}
|
||||
module Brains where
|
||||
|
||||
import HBS2.Prelude.Plated
|
||||
import HBS2.Clock
|
||||
import HBS2.Net.Proto
|
||||
import HBS2.Hash
|
||||
|
||||
import HBS2.System.Logger.Simple
|
||||
|
||||
import Data.Maybe
|
||||
import Control.Monad
|
||||
import Control.Concurrent.STM
|
||||
import Data.HashMap.Strict
|
||||
import Lens.Micro.Platform
|
||||
import Data.HashMap.Strict qualified as HashMap
|
||||
import Data.List qualified as List
|
||||
|
||||
class HasBrains e a where
|
||||
|
||||
onKnownPeers :: MonadIO m => a -> [Peer e] -> m ()
|
||||
|
||||
onBlockDownloadAttempt :: MonadIO m => a -> Peer e -> Hash HbSync -> m ()
|
||||
|
||||
onBlockDownloaded :: MonadIO m
|
||||
=> a
|
||||
-> Peer e
|
||||
-> Hash HbSync
|
||||
-> m ()
|
||||
|
||||
onBlockPostponed :: MonadIO m
|
||||
=> a
|
||||
-> Hash HbSync
|
||||
-> m ()
|
||||
|
||||
claimBlockCameFrom :: MonadIO m
|
||||
=> a
|
||||
-> Hash HbSync
|
||||
-> Hash HbSync
|
||||
-> m ()
|
||||
|
||||
shouldPosponeBlock :: MonadIO m
|
||||
=> a
|
||||
-> Hash HbSync
|
||||
-> m Bool
|
||||
|
||||
|
||||
shouldDownloadBlock :: MonadIO m
|
||||
=> a
|
||||
-> Peer e
|
||||
-> Hash HbSync
|
||||
-> m Bool
|
||||
|
||||
type NoBrains = ()
|
||||
|
||||
instance Pretty (Peer e) => HasBrains e NoBrains where
|
||||
|
||||
onKnownPeers _ ps = pure ()
|
||||
|
||||
onBlockDownloadAttempt _ p h = do
|
||||
pure ()
|
||||
|
||||
onBlockDownloaded _ p h = do
|
||||
pure ()
|
||||
|
||||
onBlockPostponed _ h = do
|
||||
pure ()
|
||||
|
||||
claimBlockCameFrom _ _ _ = do pure ()
|
||||
|
||||
shouldPosponeBlock _ _ = pure False
|
||||
|
||||
shouldDownloadBlock _ _ _ = pure True
|
||||
|
||||
data SomeBrains e = forall a . HasBrains e a => SomeBrains a
|
||||
|
||||
instance HasBrains e (SomeBrains e) where
|
||||
onKnownPeers (SomeBrains a) = onKnownPeers a
|
||||
onBlockDownloadAttempt (SomeBrains a) = onBlockDownloadAttempt a
|
||||
onBlockDownloaded (SomeBrains a) = onBlockDownloaded a
|
||||
onBlockPostponed (SomeBrains a) = onBlockPostponed @e a
|
||||
claimBlockCameFrom (SomeBrains a) = claimBlockCameFrom @e a
|
||||
shouldPosponeBlock (SomeBrains a) = shouldPosponeBlock @e a
|
||||
shouldDownloadBlock (SomeBrains a) = shouldDownloadBlock @e a
|
||||
|
||||
data BasicBrains e =
|
||||
BasicBrains
|
||||
{ _brainsPeers :: TVar [Peer e]
|
||||
, _brainsPostponeDown :: TVar (HashMap (Peer e, Hash HbSync) Int )
|
||||
}
|
||||
|
||||
makeLenses 'BasicBrains
|
||||
|
||||
|
||||
cleanupPostponed :: MonadIO m => BasicBrains e -> Hash HbSync -> m ()
|
||||
cleanupPostponed b h = do
|
||||
let po = view brainsPostponeDown b
|
||||
let flt (_,h1) _ = h1 /= h
|
||||
liftIO $ atomically $ modifyTVar po $ HashMap.filterWithKey flt
|
||||
|
||||
instance Hashable (Peer e) => HasBrains e (BasicBrains e) where
|
||||
|
||||
onKnownPeers br ps = do
|
||||
trace "BRAINS: onKnownPeers"
|
||||
let tv = view brainsPeers br
|
||||
liftIO $ atomically $ writeTVar tv ps
|
||||
|
||||
onBlockDownloadAttempt b peer h = do
|
||||
trace "BRAINS: onBlockDownloadAttempt"
|
||||
let doAlter = HashMap.alter (maybe (Just 0) (Just . succ)) (peer,h)
|
||||
liftIO $ atomically $ modifyTVar (view brainsPostponeDown b) doAlter
|
||||
|
||||
onBlockDownloaded b p h = do
|
||||
trace "BRAINS: onBlockDownloaded"
|
||||
cleanupPostponed b h
|
||||
|
||||
onBlockPostponed b h = do
|
||||
trace "BRAINS: onBlockPostponed"
|
||||
cleanupPostponed b h
|
||||
|
||||
claimBlockCameFrom _ _ _ = do
|
||||
trace "BRAINS: claimBlockCameFrom"
|
||||
|
||||
shouldPosponeBlock b h = do
|
||||
peers <- liftIO $ readTVarIO (view brainsPeers b)
|
||||
downs <- liftIO $ readTVarIO (view brainsPostponeDown b)
|
||||
|
||||
r <- forM peers $ \p -> do
|
||||
let v = HashMap.lookup (p,h) downs & fromMaybe 0 & (<2)
|
||||
pure [v]
|
||||
|
||||
let postpone = not (List.null r || or (mconcat r) )
|
||||
|
||||
pure postpone
|
||||
|
||||
shouldDownloadBlock b p h = do
|
||||
downs <- liftIO $ readTVarIO (view brainsPostponeDown b)
|
||||
pure $ HashMap.lookup (p,h) downs & fromMaybe 0 & (<2)
|
||||
|
||||
newBasicBrains :: forall e m . (Hashable (Peer e), MonadIO m) => m (BasicBrains e)
|
||||
newBasicBrains = liftIO do
|
||||
BasicBrains <$> newTVarIO mempty
|
||||
<*> newTVarIO mempty
|
||||
|
||||
runBasicBrains :: MonadIO m => BasicBrains e -> m ()
|
||||
runBasicBrains brains = forever do
|
||||
pause @'Seconds 20
|
||||
debug "BRAINS!"
|
||||
pure()
|
||||
|
||||
|
||||
|
|
@ -186,3 +186,4 @@ peerPingLoop cfg = do
|
|||
expire (PeerInfoKey p)
|
||||
expire (KnownPeerKey p)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -30,6 +30,7 @@ import HBS2.Storage.Simple
|
|||
import HBS2.System.Logger.Simple hiding (info)
|
||||
import HBS2.System.Logger.Simple qualified as Log
|
||||
|
||||
import Brains
|
||||
import RPC
|
||||
import PeerTypes
|
||||
import BlockDownload
|
||||
|
|
@ -504,7 +505,11 @@ runPeer opts = Exception.handle myException $ do
|
|||
messMcast <- async $ runMessagingUDP mcast
|
||||
`catch` (\(e::SomeException) -> throwIO e )
|
||||
|
||||
denv <- newDownloadEnv
|
||||
brains <- newBasicBrains @e
|
||||
|
||||
brainsThread <- async $ runBasicBrains brains
|
||||
|
||||
denv <- newDownloadEnv brains
|
||||
|
||||
penv <- newPeerEnv (AnyStorage s) (Fabriq mess) (getOwnPeer mess)
|
||||
|
||||
|
|
@ -518,7 +523,7 @@ runPeer opts = Exception.handle myException $ do
|
|||
reflogReqAdapter <- RefLog.mkRefLogRequestAdapter @e
|
||||
|
||||
let doDownload h = do
|
||||
withPeerM penv $ withDownload denv (addDownload h)
|
||||
withPeerM penv $ withDownload denv (addDownload mzero h)
|
||||
|
||||
let doFetchRef puk = do
|
||||
withPeerM penv $ do
|
||||
|
|
@ -856,7 +861,7 @@ runPeer opts = Exception.handle myException $ do
|
|||
, makeResponse peerAnnounceProto
|
||||
]
|
||||
|
||||
void $ waitAnyCatchCancel $ w <> [udp,loop,rpc,mrpc,ann,messMcast]
|
||||
void $ waitAnyCatchCancel $ w <> [udp,loop,rpc,mrpc,ann,messMcast,brainsThread]
|
||||
|
||||
simpleStorageStop s
|
||||
|
||||
|
|
|
|||
|
|
@ -21,6 +21,7 @@ import HBS2.Net.PeerLocator
|
|||
import HBS2.System.Logger.Simple
|
||||
|
||||
import PeerInfo
|
||||
import Brains
|
||||
|
||||
import Data.Foldable (for_)
|
||||
import Control.Concurrent.Async
|
||||
|
|
@ -153,16 +154,17 @@ data DownloadEnv e =
|
|||
, _blockState :: TVar (HashMap (Hash HbSync) BlockState)
|
||||
, _blockInQ :: TVar (HashMap (Hash HbSync) ())
|
||||
, _peerThreads :: TVar (HashMap (Peer e) (PeerThread e))
|
||||
, _peerPostponed :: TVar (HashMap (Hash HbSync) ())
|
||||
, _blockStored :: Cache (Hash HbSync) ()
|
||||
, _blockBanned :: Cache (Hash HbSync, Peer e) ()
|
||||
, _blockPostponed :: TVar (HashMap (Hash HbSync) () )
|
||||
, _blockPostponedTo :: Cache (Hash HbSync) ()
|
||||
, _downloadBrains :: SomeBrains e
|
||||
}
|
||||
|
||||
makeLenses 'DownloadEnv
|
||||
|
||||
|
||||
newDownloadEnv :: (MonadIO m, MyPeer e) => m (DownloadEnv e)
|
||||
newDownloadEnv = liftIO do
|
||||
newDownloadEnv :: (MonadIO m, MyPeer e, HasBrains e brains) => brains -> m (DownloadEnv e)
|
||||
newDownloadEnv brains = liftIO do
|
||||
DownloadEnv <$> newTQueueIO
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO mempty
|
||||
|
|
@ -170,9 +172,10 @@ newDownloadEnv = liftIO do
|
|||
<*> newTVarIO mempty
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO mempty
|
||||
<*> Cache.newCache (Just defBlockWipTimeout)
|
||||
<*> newTVarIO mempty
|
||||
<*> Cache.newCache (Just defBlockBanTime)
|
||||
<*> pure (SomeBrains brains)
|
||||
|
||||
newtype BlockDownloadM e m a =
|
||||
BlockDownloadM { fromBlockDownloadM :: ReaderT (DownloadEnv e) m a }
|
||||
|
|
@ -184,9 +187,6 @@ newtype BlockDownloadM e m a =
|
|||
, MonadTrans
|
||||
)
|
||||
|
||||
runDownloadM :: (MyPeer e, MonadIO m) => BlockDownloadM e m a -> m a
|
||||
runDownloadM m = runReaderT ( fromBlockDownloadM m ) =<< newDownloadEnv
|
||||
|
||||
withDownload :: (MyPeer e, HasPeerLocator e m, MonadIO m) => DownloadEnv e -> BlockDownloadM e m a -> m a
|
||||
withDownload e m = runReaderT ( fromBlockDownloadM m ) e
|
||||
|
||||
|
|
@ -213,15 +213,6 @@ fetchBlockState h = do
|
|||
Nothing -> (defState, HashMap.insert h defState hm)
|
||||
Just x -> (x, hm)
|
||||
|
||||
banBlock :: (MyPeer e, MonadIO m) => Peer e -> Hash HbSync -> BlockDownloadM e m ()
|
||||
banBlock p h = do
|
||||
banned <- asks (view blockBanned)
|
||||
liftIO $ Cache.insert banned (h,p) ()
|
||||
|
||||
isBanned :: (MyPeer e, MonadIO m) => Peer e -> Hash HbSync -> BlockDownloadM e m Bool
|
||||
isBanned p h = do
|
||||
banned <- asks (view blockBanned)
|
||||
liftIO $ Cache.lookup banned (h,p) <&> isJust
|
||||
|
||||
delBlockState :: MonadIO m => Hash HbSync -> BlockDownloadM e m ()
|
||||
delBlockState h = do
|
||||
|
|
@ -270,74 +261,95 @@ checkForDownload :: forall e m . ( MyPeer e
|
|||
checkForDownload lbs = do
|
||||
pure ()
|
||||
|
||||
addDownload :: forall e m . ( MyPeer e
|
||||
, MonadIO m
|
||||
, HasPeerLocator e (BlockDownloadM e m)
|
||||
, HasStorage m -- (BlockDownloadM e m)
|
||||
, Block ByteString ~ ByteString
|
||||
type DownloadConstr e m = ( MyPeer e
|
||||
, MonadIO m
|
||||
, HasPeerLocator e (BlockDownloadM e m)
|
||||
, HasStorage m -- (BlockDownloadM e m)
|
||||
, Block ByteString ~ ByteString
|
||||
)
|
||||
|
||||
addDownload :: forall e m . ( DownloadConstr e m
|
||||
)
|
||||
=> Hash HbSync -> BlockDownloadM e m ()
|
||||
=> Maybe (Hash HbSync)
|
||||
-> Hash HbSync
|
||||
-> BlockDownloadM e m ()
|
||||
|
||||
addDownload h = do
|
||||
|
||||
po <- asks (view peerPostponed)
|
||||
addDownload mbh h = do
|
||||
|
||||
tinq <- asks (view blockInQ)
|
||||
|
||||
doAdd <- do liftIO $ atomically $ stateTVar tinq
|
||||
\hm -> case HashMap.lookup h hm of
|
||||
Nothing -> (True, HashMap.insert h () hm)
|
||||
Just{} -> (False, HashMap.insert h () hm)
|
||||
brains <- asks (view downloadBrains)
|
||||
|
||||
notHere <- isBlockHereCached h <&> not
|
||||
postponed <- isPostponed h
|
||||
|
||||
notPostponed <- liftIO $ readTVarIO po <&> isNothing . HashMap.lookup h
|
||||
unless postponed do
|
||||
|
||||
when (doAdd && notPostponed && notHere) do
|
||||
maybe1 mbh none $ \hp -> claimBlockCameFrom @e brains hp h
|
||||
|
||||
q <- asks (view downloadQ)
|
||||
wip <- asks (view blockWip)
|
||||
postpone <- shouldPosponeBlock @e brains h
|
||||
|
||||
liftIO do
|
||||
atomically $ do
|
||||
modifyTVar tinq $ HashMap.insert h ()
|
||||
writeTQueue q h
|
||||
when postpone do
|
||||
-- trace $ "addDownload postpone" <+> pretty postpone <+> pretty h
|
||||
postponeBlock h
|
||||
|
||||
Cache.insert wip h ()
|
||||
doAdd <- do liftIO $ atomically $ stateTVar tinq
|
||||
\hm -> case HashMap.lookup h hm of
|
||||
Nothing -> (True, HashMap.insert h () hm)
|
||||
Just{} -> (False, HashMap.insert h () hm)
|
||||
|
||||
-- | False -> do -- not hasSize -> do
|
||||
notHere <- isBlockHereCached h <&> not
|
||||
|
||||
-- po <- asks (view peerPostponed)
|
||||
-- liftIO $ atomically $ do
|
||||
-- modifyTVar po $ HashMap.insert h ()
|
||||
when (doAdd && notHere && not postpone) do
|
||||
|
||||
-- trace $ "postpone block" <+> pretty h <+> pretty brt
|
||||
-- <+> "here:" <+> pretty (not missed)
|
||||
trace $ "addDownload" <+> pretty h
|
||||
|
||||
-- | otherwise -> do
|
||||
-- -- TODO: counter-on-this-situation
|
||||
-- none
|
||||
q <- asks (view downloadQ)
|
||||
wip <- asks (view blockWip)
|
||||
|
||||
returnPostponed :: forall e m . ( MyPeer e
|
||||
, MonadIO m
|
||||
, HasStorage m
|
||||
, HasPeerLocator e (BlockDownloadM e m)
|
||||
)
|
||||
=> Hash HbSync -> BlockDownloadM e m ()
|
||||
liftIO do
|
||||
atomically $ do
|
||||
modifyTVar tinq $ HashMap.insert h ()
|
||||
writeTQueue q h
|
||||
|
||||
returnPostponed h = do
|
||||
tinq <- asks (view blockInQ)
|
||||
-- TODO: atomic-operations
|
||||
delFromPostponed h
|
||||
delBlockState h
|
||||
liftIO $ atomically $ modifyTVar' tinq (HashMap.delete h)
|
||||
addDownload h
|
||||
Cache.insert wip h ()
|
||||
|
||||
delFromPostponed :: MonadIO m => Hash HbSync -> BlockDownloadM e m ()
|
||||
delFromPostponed h = do
|
||||
po <- asks (view peerPostponed)
|
||||
liftIO $ atomically $ do
|
||||
modifyTVar' po (HashMap.delete h)
|
||||
|
||||
postoponedNum :: forall e m . (MyPeer e, MonadIO m) => BlockDownloadM e m Int
|
||||
postoponedNum = do
|
||||
po <- asks (view blockPostponed)
|
||||
liftIO $ readTVarIO po <&> HashMap.size
|
||||
|
||||
isPostponed :: forall e m . (MyPeer e, MonadIO m) => Hash HbSync -> BlockDownloadM e m Bool
|
||||
isPostponed h = do
|
||||
po <- asks (view blockPostponed) >>= liftIO . readTVarIO
|
||||
pure $ HashMap.member h po
|
||||
|
||||
postponeBlock :: forall e m . (MyPeer e, MonadIO m) => Hash HbSync -> BlockDownloadM e m ()
|
||||
postponeBlock h = do
|
||||
|
||||
brains <- asks (view downloadBrains)
|
||||
po <- asks (view blockPostponed)
|
||||
tto <- asks (view blockPostponedTo)
|
||||
|
||||
liftIO $ do
|
||||
already <- atomically $ readTVar po <&> HashMap.member h
|
||||
unless already do
|
||||
atomically $ modifyTVar po (HashMap.insert h ())
|
||||
Cache.insert tto h ()
|
||||
onBlockPostponed @e brains h
|
||||
|
||||
unpostponeBlock :: forall e m . (DownloadConstr e m) => Hash HbSync -> BlockDownloadM e m ()
|
||||
unpostponeBlock h = do
|
||||
|
||||
po <- asks (view blockPostponed)
|
||||
tto <- asks (view blockPostponedTo)
|
||||
|
||||
liftIO $ do
|
||||
atomically $ modifyTVar po (HashMap.delete h)
|
||||
Cache.delete tto h
|
||||
|
||||
trace $ "unpostponeBlock" <+> pretty h
|
||||
addDownload @e mzero h
|
||||
|
||||
removeFromWip :: (MyPeer e, MonadIO m) => Hash HbSync -> BlockDownloadM e m ()
|
||||
removeFromWip h = do
|
||||
|
|
@ -345,17 +357,13 @@ removeFromWip h = do
|
|||
st <- asks (view blockState)
|
||||
sz <- asks (view blockPeers)
|
||||
tinq <- asks (view blockInQ)
|
||||
po <- asks (view peerPostponed)
|
||||
ba <- asks (view blockBanned)
|
||||
|
||||
liftIO $ Cache.delete wip h
|
||||
liftIO $ Cache.filterWithKey (\(hx,_) _ -> hx /= h) ba
|
||||
|
||||
liftIO $ atomically $ do
|
||||
modifyTVar' st (HashMap.delete h)
|
||||
modifyTVar' sz (HashMap.delete h)
|
||||
modifyTVar' tinq (HashMap.delete h)
|
||||
modifyTVar' po (HashMap.delete h)
|
||||
|
||||
hasPeerThread :: (MyPeer e, MonadIO m) => Peer e -> BlockDownloadM e m Bool
|
||||
hasPeerThread p = do
|
||||
|
|
@ -404,7 +412,9 @@ failedDownload :: forall e m . ( MyPeer e
|
|||
|
||||
failedDownload p h = do
|
||||
trace $ "failedDownload" <+> pretty p <+> pretty h
|
||||
addDownload h
|
||||
addDownload mzero h
|
||||
-- FIXME: brains-download-fail
|
||||
|
||||
|
||||
updateBlockPeerSize :: forall e m . (MyPeer e, MonadIO m)
|
||||
=> Hash HbSync
|
||||
|
|
|
|||
|
|
@ -120,6 +120,7 @@ executable hbs2-peer
|
|||
, RefLog
|
||||
, CheckMetrics
|
||||
, HttpWorker
|
||||
, Brains
|
||||
|
||||
-- other-extensions:
|
||||
build-depends: base
|
||||
|
|
|
|||
Loading…
Reference in New Issue