From 328275d14ec85cff353ea159d7652a360790ba59 Mon Sep 17 00:00:00 2001
From: Dmitry Zuikov <dzuikov@gmail.com>
Date: Wed, 18 Oct 2023 17:06:43 +0300
Subject: [PATCH] bugfixes

---
 hbs2-core/lib/HBS2/Merkle.hs                    | 14 +++++++++-----
 hbs2-core/lib/HBS2/Storage/Operations/Missed.hs |  8 +++-----
 hbs2-git/lib/HBS2Git/Import.hs                  | 10 +++++++---
 3 files changed, 19 insertions(+), 13 deletions(-)

diff --git a/hbs2-core/lib/HBS2/Merkle.hs b/hbs2-core/lib/HBS2/Merkle.hs
index 41bc32c3..20cc0ebf 100644
--- a/hbs2-core/lib/HBS2/Merkle.hs
+++ b/hbs2-core/lib/HBS2/Merkle.hs
@@ -166,20 +166,24 @@ walkMerkle' :: (Serialise (MTree a), Monad m)
 walkMerkle' root flookup sink = go root
   where
     go hash = do
-      -- t <- (either (error . show) id . deserialiseOrFail <$>) <$> flookup hash
+      -- t <- (either (error . show . tryDetect) id . deserialiseOrFail <$>) <$> flookup hash
       t <- ((either (const Nothing) Just . deserialiseOrFail) =<<) <$> flookup hash
       case t of
         Just n@(MLeaf _) -> sink (Right n)
         Just n@(MNode _ hashes) -> sink (Right n) >> traverse_ go hashes
-        Nothing -> sink (Left hash)
+        Nothing -> do
+          sink (Left hash)
 
-walkMerkle :: (Serialise (MTree a), Monad m)
+walkMerkle :: forall a m . (Serialise (MTree a), Serialise (MTreeAnn a), Serialise a, Monad m)
            => Hash HbSync
            -> ( Hash HbSync -> m (Maybe LBS.ByteString) )
            -> ( Either (Hash HbSync) a -> m () )
            -> m ()
 
-walkMerkle root flookup sink = walkMerkle' root flookup withTree
+walkMerkle root flookup sink = do
+
+  walkMerkle' root flookup withTree
+
   where
     withTree = \case
         (Right (MLeaf s))   -> sink (Right s)
@@ -187,7 +191,7 @@ walkMerkle root flookup sink = walkMerkle' root flookup withTree
         Left hx             -> sink (Left hx)
 
 
-walkMerkleTree :: (Serialise (MTree a), Monad m)
+walkMerkleTree :: (Serialise (MTree a), Serialise a, Monad m)
            => MTree a
            -> ( Hash HbSync -> m (Maybe LBS.ByteString) )
            -> ( Either (Hash HbSync) a -> m () )
diff --git a/hbs2-core/lib/HBS2/Storage/Operations/Missed.hs b/hbs2-core/lib/HBS2/Storage/Operations/Missed.hs
index b33fd5d2..a71ae4b9 100644
--- a/hbs2-core/lib/HBS2/Storage/Operations/Missed.hs
+++ b/hbs2-core/lib/HBS2/Storage/Operations/Missed.hs
@@ -18,16 +18,14 @@ import Data.Maybe
 findMissedBlocks :: (MonadIO m) => AnyStorage -> HashRef -> m [HashRef]
 findMissedBlocks sto href = do
 
-  trace $ "findMissedBlocks" <+> pretty href
+  -- trace $ "findMissedBlocks" <+> pretty href
 
-  S.toList_ $
+  S.toList_ $ do
 
     walkMerkle (fromHashRef href) (lift . getBlock sto) $ \(hr :: Either (Hash HbSync) [HashRef]) -> do
       case hr of
-
         -- FIXME: investigate-this-wtf
-        Left hx | fromHashRef href /= hx -> S.yield (HashRef hx)
-                | otherwise -> pure ()
+        Left hx -> S.yield (HashRef hx)
 
         Right (hrr :: [HashRef]) -> do
           forM_ hrr $ \hx -> runMaybeT do
diff --git a/hbs2-git/lib/HBS2Git/Import.hs b/hbs2-git/lib/HBS2Git/Import.hs
index ab199ae3..e27c8cc6 100644
--- a/hbs2-git/lib/HBS2Git/Import.hs
+++ b/hbs2-git/lib/HBS2Git/Import.hs
@@ -176,7 +176,9 @@ importRefLogNew opts ref = runResourceT do
                     if null missed then do
                       S.yield e
                     else do
-                      trace $ "missed blocks in tree" <+> pretty e --  <+> pretty m
+                      S.yield e
+                      forM_ missed $ \m -> do
+                        debug $ "missed blocks in tree" <+> pretty e  <+> pretty m
 
       pCommit <- liftIO $ startGitHashObject Commit
       pTree <- liftIO $ startGitHashObject Tree
@@ -382,9 +384,11 @@ importRefLogNew opts ref = runResourceT do
 
       withDB db $ do
         stateUpdateCommitDepths
-
-        when (length entries == length entries') do
+--         statePutRefImported logRoot
+        if (length entries == length entries') then do
           statePutRefImported logRoot
+        else do
+          warn "Some entries not processed!"
 
         savepointRelease sp0