bugfixes

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

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)
+        Left hx -> S.yield (HashRef hx)
-                | otherwise -> pure ()
 
         Right (hrr :: [HashRef]) -> do
           forM_ hrr $ \hx -> runMaybeT do

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
-
+--         statePutRefImported logRoot
-        when (length entries == length entries') do
+        if (length entries == length entries') then do
           statePutRefImported logRoot
+        else do
+          warn "Some entries not processed!"
 
         savepointRelease sp0