diff --git a/hbs2-core/lib/HBS2/Defaults.hs b/hbs2-core/lib/HBS2/Defaults.hs index fc2162ae..340ff9f3 100644 --- a/hbs2-core/lib/HBS2/Defaults.hs +++ b/hbs2-core/lib/HBS2/Defaults.hs @@ -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 diff --git a/hbs2-peer/app/BlockDownload.hs b/hbs2-peer/app/BlockDownload.hs index cee94b7e..28a18b25 100644 --- a/hbs2-peer/app/BlockDownload.hs +++ b/hbs2-peer/app/BlockDownload.hs @@ -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 diff --git a/hbs2-peer/app/Brains.hs b/hbs2-peer/app/Brains.hs new file mode 100644 index 00000000..7fb43b76 --- /dev/null +++ b/hbs2-peer/app/Brains.hs @@ -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() + + diff --git a/hbs2-peer/app/PeerInfo.hs b/hbs2-peer/app/PeerInfo.hs index d6f99c9a..ce05f2ba 100644 --- a/hbs2-peer/app/PeerInfo.hs +++ b/hbs2-peer/app/PeerInfo.hs @@ -186,3 +186,4 @@ peerPingLoop cfg = do expire (PeerInfoKey p) expire (KnownPeerKey p) + diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index bbe5d685..dccff01b 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -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 diff --git a/hbs2-peer/app/PeerTypes.hs b/hbs2-peer/app/PeerTypes.hs index cd21c3cb..a1db09c8 100644 --- a/hbs2-peer/app/PeerTypes.hs +++ b/hbs2-peer/app/PeerTypes.hs @@ -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 diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index ca68c6d7..40eba0db 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -120,6 +120,7 @@ executable hbs2-peer , RefLog , CheckMetrics , HttpWorker + , Brains -- other-extensions: build-depends: base