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@(MLeaf _) -> sink (Right n)
-        Just n@(MNode _ hashes) -> sink n >> traverse_ go hashes
+        Just n@(MNode _ hashes) -> sink (Right n) >> traverse_ go hashes
-        Nothing -> pure ()
+        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
+        (Right (MLeaf s))   -> sink (Right s)
-        (MNode _ _) -> pure ()
+        (Right (MNode _ _)) -> pure ()
-
+        Left hx             -> sink (Left hx)
--- 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
 

hbs2-peer/app/BlockDownload.hs

@@ -215,23 +215,27 @@ 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
 
-         for_ hr $ \(HashRef blk) -> do
+        case hrr of
+          Left hx -> addDownload hx
+          Right hr -> do
 
-           -- debug $ pretty blk
+            for_ hr $ \(HashRef blk) -> do
 
-           here <- liftIO (hasBlock sto blk) <&> isJust
+              -- debug $ pretty blk
 
-           if here then do
+              here <- liftIO (hasBlock sto blk) <&> isJust
-             debug $ "block" <+> pretty blk <+> "is already here"
-             processBlock blk -- NOTE: хуже не стало
-                              -- FIXME:  fugure out if it's really required
 
-             pure () -- we don't need to recurse, cause walkMerkle is recursing for us
+              if here then do
+                -- debug $ "block" <+> pretty blk <+> "is already here"
+                processBlock blk -- NOTE: хуже не стало
+                                 -- FIXME:  fugure out if it's really required
 
-           else do
+                pure () -- we don't need to recurse, cause walkMerkle is recursing for us
-              addDownload blk
+
+              else do
+                 addDownload blk
 
 
      Just (Blob{}) -> do
@@ -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,16 +108,18 @@ runCat opts ss = do
 
     liftIO $ do
 
-      let walk h = walkMerkle h (getBlock ss) $ \(hr :: [HashRef]) -> do
+      let walk h = walkMerkle h (getBlock ss) $ \(hr :: Either (Hash HbSync) [HashRef]) -> do
-           forM_ hr $ \(HashRef h) -> do
+            case hr of
-             if honly then do
+              Left hx -> void $ hPrint stderr $ "missed block:" <+> pretty hx
-               print $ pretty h
+              Right (hrr :: [HashRef]) -> do
-             else do
+                 forM_ hrr $ \(HashRef hx) -> do
-               mblk <- getBlock ss h
+                   if honly then do
-               case mblk of
+                     print $ pretty hx
-                 Nothing  -> die $ show $ "missed block: " <+> pretty h
+                   else do
-                 Just blk -> LBS.putStr blk
+                     mblk <- getBlock ss hx
-
+                     case mblk of
+                       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