diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Tree.hs b/hbs2-cli/lib/HBS2/CLI/Run/Tree.hs index ffecff12..05e90931 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Tree.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Tree.hs @@ -11,9 +11,12 @@ import HBS2.Defaults import HBS2.Data.Types.Refs import HBS2.Merkle +import HBS2.Data.Detect import HBS2.System.Dir import HBS2.Storage +import HBS2.Storage.Operations.Class import HBS2.Storage.Operations.ByteString +import HBS2.Storage.Operations.Missed import HBS2.Net.Auth.Schema() @@ -21,6 +24,7 @@ import HBS2.Peer.RPC.API.Storage import HBS2.Peer.RPC.Client import HBS2.Peer.RPC.Client.Unix +import Data.Coerce import Data.Text qualified as Text import Control.Monad.Except import Codec.Serialise @@ -98,3 +102,27 @@ It's just an easy way to create a such thing, you may browse it by hbs2 cat -H _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "hbs2:tree:missed" $ \case + [HashLike href] -> do + sto <- getStorage + findMissedBlocks sto href + <&> mkList . fmap (mkStr @c . show . pretty) + + _ -> throwIO (BadFormException @c nil) + + + entry $ bindMatch "hbs2:tree:refs" $ \case + [HashLike href] -> do + sto <- getStorage + + blk <- getBlock sto (coerce href) + >>= orThrow MissedBlockError + + let refs = extractBlockRefs (coerce href) blk + + pure $ mkList @c (fmap (mkStr . show . pretty) refs) + + _ -> throwIO (BadFormException @c nil) + + diff --git a/hbs2-core/lib/HBS2/Storage/Operations/Missed.hs b/hbs2-core/lib/HBS2/Storage/Operations/Missed.hs index a7cc64af..610818d9 100644 --- a/hbs2-core/lib/HBS2/Storage/Operations/Missed.hs +++ b/hbs2-core/lib/HBS2/Storage/Operations/Missed.hs @@ -7,7 +7,7 @@ import HBS2.Hash import HBS2.Merkle import HBS2.Storage --- import HBS2.System.Logger.Simple +import HBS2.System.Logger.Simple import Streaming.Prelude qualified as S import Streaming.Prelude (Stream, Of(..)) @@ -25,8 +25,23 @@ findMissedBlocks sto href = do S.toList_ $ findMissedBlocks2 sto href findMissedBlocks2 :: (MonadIO m) => AnyStorage -> HashRef -> Stream (Of HashRef) m () -findMissedBlocks2 sto href = do - walkMerkle (fromHashRef href) (lift . getBlock sto) $ \(hr :: Either (Hash HbSync) [HashRef]) -> do +findMissedBlocks2 sto href = void $ runMaybeT do + + self' <- getBlock sto (coerce href) + + unless (isJust self') do + lift $ S.yield (coerce href) + + self <- toMPlus self' + + let refs = extractBlockRefs (coerce href) self + + for_ refs $ \r -> do + -- findMissedBlocks sto r >>= lift . mapM_ S.yield + here <- hasBlock sto (coerce r) <&> isJust + unless here $ lift $ S.yield r + + lift $ walkMerkle (fromHashRef href) (lift . getBlock sto) $ \(hr :: Either (Hash HbSync) [HashRef]) -> do case hr of -- FIXME: investigate-this-wtf Left hx -> S.yield (HashRef hx) @@ -42,7 +57,10 @@ findMissedBlocks2 sto href = do let w = tryDetect (fromHashRef hx) bs let refs = extractBlockRefs (coerce hx) bs + -- err $ "PIZDA!" <+> pretty hx <+> pretty refs + for_ refs $ \r -> do + -- findMissedBlocks sto r >>= lift . mapM_ S.yield here <- hasBlock sto (coerce r) <&> isJust unless here $ lift $ S.yield r @@ -56,7 +74,14 @@ findMissedBlocks2 sto href = do _ -> pure mempty b1 <- findMissedBlocks sto hx - pure (b0 <> b1) + + b2 <- case _mtaCrypt t of + (EncryptGroupNaClSymm hash _) -> + findMissedBlocks sto (HashRef hash) + + _ -> pure mempty + + pure (b0 <> b1 <> b2) _ -> pure mempty