block-download-fix

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
 

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
+  brains <- asks (view downloadBrains)
-    processBlock h
+
-  else do
+  should <- shouldDownloadBlock brains p h
-    banned <- isBanned p h
+
-    trace $ "withBlockForDownload" <+> pretty p <+> pretty h
+  if | here      -> processBlock h
-    if banned then do
+     | should    -> onBlockDownloadAttempt brains p h >> action h
-      -- trace $ "skip banned block" <+> pretty p <+> pretty h
+     | otherwise -> noBlockAction >> addDownload mzero h
-      addDownload h
-    else do
-      action 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
+    po <- postoponedNum
-    ba <- asks (view blockBanned ) >>= liftIO . Cache.size
 
     wipNum <- liftIO $ Cache.size wip
 
     notice $ "maintain blocks wip" <+> pretty wipNum
                                    <+> "postponed"
-                                   <+> pretty (HashMap.size po)
+                                   <+> pretty po
-                                   <+> "banned"
-                                   <+> pretty ba
 
   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
+      pause @'Seconds 30
-      ban <- asks (view blockBanned)
+      trace "UNPOSTPONE LOOP"
-      void $ liftIO $ Cache.purgeExpired ban
+      po <- asks (view blockPostponedTo) >>= liftIO . Cache.toList
-      wip <- asks (view blockWip) >>= liftIO . Cache.keys <&> HashSet.fromList
+      for_ po $ \(h, _, expired) -> do
-      trace $ "wipe banned!"
+        when (isJust expired) do
-      void $ liftIO $ Cache.filterWithKey (\(h,_) _ -> HashSet.member h wip ) ban
+          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 mzero h
-            addDownload 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

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()
+
+

hbs2-peer/app/PeerInfo.hs

@@ -186,3 +186,4 @@ peerPingLoop cfg = do
         expire (PeerInfoKey p)
         expire (KnownPeerKey p)
 
+

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
 

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 :: (MonadIO m, MyPeer e, HasBrains e brains) => brains -> m (DownloadEnv e)
-newDownloadEnv = liftIO do
+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
+type DownloadConstr e m = ( MyPeer e
-                            , MonadIO m
+                          , MonadIO m
-                            , HasPeerLocator e (BlockDownloadM e m)
+                          , HasPeerLocator e (BlockDownloadM e m)
-                            , HasStorage m -- (BlockDownloadM e m)
+                          , HasStorage m -- (BlockDownloadM e m)
-                            , Block ByteString ~ ByteString
+                          , 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
+addDownload mbh h = do
-
-  po <- asks (view peerPostponed)
 
   tinq <- asks (view blockInQ)
 
-  doAdd <- do liftIO $ atomically $ stateTVar tinq
+  brains <- asks (view downloadBrains)
-                                  \hm -> case HashMap.lookup h hm of
-                                           Nothing -> (True,  HashMap.insert h () hm)
-                                           Just{}  -> (False, HashMap.insert h () hm)
 
-  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)
+    postpone <- shouldPosponeBlock @e brains h
-    wip <- asks (view blockWip)
 
-    liftIO do
+    when postpone do
-      atomically $ do
+      -- trace $ "addDownload postpone" <+> pretty postpone <+> pretty h
-        modifyTVar tinq $ HashMap.insert h ()
+      postponeBlock h
-        writeTQueue q 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)
+    when (doAdd && notHere && not postpone) do
-     --  liftIO $ atomically $ do
-     --    modifyTVar po $ HashMap.insert h ()
 
-     --  trace $ "postpone block" <+> pretty h <+> pretty brt
+      trace $ "addDownload" <+> pretty h
-     --                           <+> "here:" <+> pretty (not missed)
 
-     --  | otherwise -> do
+      q <- asks (view downloadQ)
-     --    -- TODO: counter-on-this-situation
+      wip <- asks (view blockWip)
-     --    none
 
-returnPostponed :: forall e m . ( MyPeer e
+      liftIO do
-                               , MonadIO m
+        atomically $ do
-                               , HasStorage m
+          modifyTVar tinq $ HashMap.insert h ()
-                               , HasPeerLocator e (BlockDownloadM e m)
+          writeTQueue q h
-                               )
-            => Hash HbSync -> BlockDownloadM e m ()
 
-returnPostponed h = do
+        Cache.insert wip h ()
-  tinq <- asks (view blockInQ)
-  -- TODO: atomic-operations
-  delFromPostponed h
-  delBlockState h
-  liftIO $ atomically $ modifyTVar' tinq (HashMap.delete h)
-  addDownload h
 
-delFromPostponed :: MonadIO m => Hash HbSync -> BlockDownloadM e m ()
+
-delFromPostponed h = do
+postoponedNum :: forall e  m . (MyPeer e, MonadIO m) => BlockDownloadM e m Int
-  po  <- asks (view peerPostponed)
+postoponedNum = do
-  liftIO $ atomically $ do
+  po <- asks (view blockPostponed)
-    modifyTVar' po (HashMap.delete h)
+  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

hbs2-peer/hbs2-peer.cabal

@@ -120,6 +120,7 @@ executable hbs2-peer
                     , RefLog
                     , CheckMetrics
                     , HttpWorker
+                    , Brains
 
     -- other-extensions:
     build-depends:    base