fixed big blocks downloading bug

hbs2-core/lib/HBS2/Merkle.hs

@@ -134,7 +134,7 @@ makeMerkle h0 pt f = fst <$> go h0 pt
 walkMerkle' :: (Serialise (MTree a), Monad m)
            => Hash HbSync
            -> ( Hash HbSync -> m (Maybe LBS.ByteString) )
-           -> ( MTree a -> m () )
+           -> ( Either (Hash HbSync) (MTree a) -> m () )
            -> m ()
 
 walkMerkle' root flookup sink = go root
@@ -142,28 +142,20 @@ walkMerkle' root flookup sink = go root
     go hash = do
       t <- (deserialise <$>) <$> flookup hash
       case t of
-        Just n@(MLeaf _) -> sink n
-        Just n@(MNode _ hashes) -> sink n >> traverse_ go hashes
-        Nothing -> pure ()
+        Just n@(MLeaf _) -> sink (Right n)
+        Just n@(MNode _ hashes) -> sink (Right n) >> traverse_ go hashes
+        Nothing -> sink (Left hash)
 
 walkMerkle :: (Serialise (MTree a), Monad m)
            => Hash HbSync
            -> ( Hash HbSync -> m (Maybe LBS.ByteString) )
-           -> ( a -> m () )
+           -> ( Either (Hash HbSync) a -> m () )
            -> m ()
 
 walkMerkle root flookup sink = walkMerkle' root flookup withTree
   where
     withTree = \case
-        (MLeaf s) -> sink s
-        (MNode _ _) -> pure ()
-
--- walkMerkle root flookup sink = go root
---   where
---     go hash = do
---       t <- (deserialise <$>) <$> flookup hash
---       case t of
---         Nothing -> pure ()
---         Just (MLeaf s) -> sink s
---         Just (MNode _ hashes) -> traverse_ go hashes
+        (Right (MLeaf s))   -> sink (Right s)
+        (Right (MNode _ _)) -> pure ()
+        Left hx             -> sink (Left hx)
 

hbs2-peer/app/BlockDownload.hs

@@ -215,7 +215,11 @@ processBlock h = do
 
      Just (Merkle{}) -> do
        debug $ "GOT MERKLE. requesting nodes/leaves" <+> pretty h
-       walkMerkle h (liftIO . getBlock sto)  $ \(hr :: [HashRef]) -> do
+       walkMerkle h (liftIO . getBlock sto)  $ \(hrr :: Either (Hash HbSync) [HashRef]) -> do
+
+        case hrr of
+          Left hx -> addDownload hx
+          Right hr -> do
 
             for_ hr $ \(HashRef blk) -> do
 
@@ -224,7 +228,7 @@ processBlock h = do
               here <- liftIO (hasBlock sto blk) <&> isJust
 
               if here then do
-             debug $ "block" <+> pretty blk <+> "is already here"
+                -- debug $ "block" <+> pretty blk <+> "is already here"
                 processBlock blk -- NOTE: хуже не стало
                                  -- FIXME:  fugure out if it's really required
 
@@ -446,7 +450,7 @@ blockDownloadLoop env0 = do
 
 
   void $ liftIO $ async $ forever $ withPeerM e do
-    pause @'Seconds 5
+    pause @'Seconds 2
 
     pee <- knownPeers @e pl
     npi <- newPeerInfo

hbs2/Main.hs

@@ -108,17 +108,19 @@ runCat opts ss = do
 
     liftIO $ do
 
-      let walk h = walkMerkle h (getBlock ss) $ \(hr :: [HashRef]) -> do
-           forM_ hr $ \(HashRef h) -> do
+      let walk h = walkMerkle h (getBlock ss) $ \(hr :: Either (Hash HbSync) [HashRef]) -> do
+            case hr of
+              Left hx -> void $ hPrint stderr $ "missed block:" <+> pretty hx
+              Right (hrr :: [HashRef]) -> do
+                 forM_ hrr $ \(HashRef hx) -> do
                    if honly then do
-               print $ pretty h
+                     print $ pretty hx
                    else do
-               mblk <- getBlock ss h
+                     mblk <- getBlock ss hx
                      case mblk of
-                 Nothing  -> die $ show $ "missed block: " <+> pretty h
+                       Nothing  -> die $ show $ "missed block: " <+> pretty hx
                        Just blk -> LBS.putStr blk
 
-
       case q of
         Blob h -> getBlock ss h >>= maybe (die "blob not found") LBS.putStr
         Merkle h -> walk h