From 8ba476be173ff9b394125d3dbbe707db6dce6d35 Mon Sep 17 00:00:00 2001 From: voidlizard Date: Wed, 15 Jan 2025 09:53:25 +0300 Subject: [PATCH] wip --- hbs2-git3/app/Main.hs | 27 ++------- hbs2-git3/lib/HBS2/Git3/State/Index.hs | 78 +++++++++++++++----------- 2 files changed, 52 insertions(+), 53 deletions(-) diff --git a/hbs2-git3/app/Main.hs b/hbs2-git3/app/Main.hs index 5a1c4743..4512d597 100644 --- a/hbs2-git3/app/Main.hs +++ b/hbs2-git3/app/Main.hs @@ -66,6 +66,7 @@ import Data.HashMap.Strict qualified as HM import Data.HashMap.Strict (HashMap(..)) import Data.Word import Data.Fixed +import Data.Either import Data.Ord (comparing) import Data.Generics.Labels import Data.Generics.Product @@ -1167,19 +1168,10 @@ theDict = do else do decoded <- readTxMay sto h <&> \case - Nothing -> ("missed" <+> pretty h) - Just (AnnotatedHashRef _ x) -> (fill 44 (pretty h) <+> fill 44 (pretty x)) - print decoded + Just (TxSegment x) -> Just (fill 44 (pretty h) <+> fill 44 (pretty x)) + _ -> Nothing - entry $ bindMatch "reflog:tx:objects:list" $ nil_ $ \syn -> lift $ connectedDo do - let (_, argz) = splitOpts [] syn - txh <- headMay [ x | HashLike x <- argz ] & orThrowUser "tx hash not set" - sto <- getStorage - - AnnotatedHashRef _ tree <- readTxMay sto txh - >>= orThrowUser ("missed" <+> pretty txh) - - liftIO $ print $ pretty tree + forM_ decoded print entry $ bindMatch "test:git:import" $ nil_ $ \syn -> lift $ connectedDo do @@ -1191,19 +1183,12 @@ theDict = do rv <- callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) refLogAPI reflog >>= orThrowUser "rpc timeout" >>= orThrowUser "reflog is empty" - <&> coerce + <&> coerce @_ @HashRef notice $ "test:git:import" <+> pretty (AsBase58 reflog) <+> pretty rv sto <- getStorage - - walkMerkle @[HashRef] rv (getBlock sto) \case - Left h -> err $ "missed block" - Right hs -> do - for_ hs $ \h -> void $ runMaybeT do - AnnotatedHashRef _ tree <- readTxMay sto h >>= toMPlus - notice $ pretty tree - none + none exportEntries "reflog:" diff --git a/hbs2-git3/lib/HBS2/Git3/State/Index.hs b/hbs2-git3/lib/HBS2/Git3/State/Index.hs index 983be084..0d9038f0 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/Index.hs +++ b/hbs2-git3/lib/HBS2/Git3/State/Index.hs @@ -276,9 +276,13 @@ bloomFilterSize n k p where rnd x = 2 ** realToFrac (ceiling (logBase 2 x)) & round +data GitTx = + TxSegment HashRef + | TxCheckpoint Natural HashRef + readTxMay :: forall m . ( MonadIO m ) - => AnyStorage -> HashRef -> m (Maybe AnnotatedHashRef) + => AnyStorage -> HashRef -> m (Maybe GitTx) readTxMay sto href = runMaybeT do @@ -288,8 +292,17 @@ readTxMay sto href = runMaybeT do RefLogUpdate{..} <- deserialiseOrFail @(RefLogUpdate L4Proto) tx & toMPlus - deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict _refLogUpdData) - & toMPlus + toMPlus $ + ( deserialiseOrFail (LBS.fromStrict _refLogUpdData) & either (const Nothing) fromAnn ) + <|> + ( deserialiseOrFail (LBS.fromStrict _refLogUpdData) & either (const Nothing) fromSeq ) + + where + fromAnn = \case + AnnotatedHashRef _ h -> Just (TxSegment h) + + fromSeq = \case + (SequentialRef n (AnnotatedHashRef _ h)) -> Just $ TxCheckpoint (fromIntegral n) h updateReflogIndex :: forall m . ( Git3Perks m , MonadReader Git3Env m @@ -335,45 +348,46 @@ updateReflogIndex = do Left{} -> throwIO MissedBlockError Right (hs :: [HashRef]) -> do for_ [h | h <- hs, not (HS.member h written)] $ \h -> void $ runMaybeT do + readTxMay sto (coerce h) >>= \case + Nothing -> mzero + Just (TxCheckpoint{}) -> mzero + Just (TxSegment href) -> do + -- FIXME: error logging + chunks <- liftIO (runExceptT (getTreeContents sto href)) + >>= orThrow MissedBlockError + <&> LBS.toChunks - AnnotatedHashRef _ href <- readTxMay sto (coerce h) >>= toMPlus + what <- toMPlus =<< liftIO do + init <- decompress + flip fix (init, chunks, mempty :: LBS.ByteString) $ \next -> \case - -- FIXME: error logging - chunks <- liftIO (runExceptT (getTreeContents sto href)) - >>= orThrow MissedBlockError - <&> LBS.toChunks + (Consume work, [], o) -> do + r1 <- work "" + next (r1, [], o) - what <- toMPlus =<< liftIO do - init <- decompress - flip fix (init, chunks, mempty :: LBS.ByteString) $ \next -> \case + (Consume work, e:es, o) -> do + r1 <- work e + next (r1, es, o) - (Consume work, [], o) -> do - r1 <- work "" - next (r1, [], o) + (Produce piece r, e, o) -> do + r1 <- r + next (r1, e, LBS.append o (LBS.fromStrict piece)) - (Consume work, e:es, o) -> do - r1 <- work e - next (r1, es, o) + (ZStdS.Done bs, _, o) -> pure (Just (LBS.append o (LBS.fromStrict bs))) - (Produce piece r, e, o) -> do - r1 <- r - next (r1, e, LBS.append o (LBS.fromStrict piece)) + (Error _ _, _, _) -> do + debug $ "not a valid segment" <+> pretty h + pure Nothing - (ZStdS.Done bs, _, o) -> pure (Just (LBS.append o (LBS.fromStrict bs))) + guard (LBS.length what > 0) - (Error _ _, _, _) -> do - debug $ "not a valid segment" <+> pretty h - pure Nothing + notice $ "unpacked!" <+> pretty h <+> pretty (LBS.length what) - guard (LBS.length what > 0) + pieces <- S.toList_ $ do + void $ runConsumeLBS what $ readLogFileLBS () $ \o _ _ -> do + lift $ S.yield o - notice $ "unpacked!" <+> pretty h <+> pretty (LBS.length what) - - pieces <- S.toList_ $ do - void $ runConsumeLBS what $ readLogFileLBS () $ \o _ _ -> do - lift $ S.yield o - - lift $ S.yield (h, pieces) + lift $ S.yield (h, pieces) liftIO $ forConcurrently_ sink $ \(tx, pieces) -> do idxName <- emptyTempFile idxPath "objects-.idx"