wip

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 (TxSegment x)  -> Just (fill 44 (pretty h) <+> fill 44 (pretty x))
-                    Just (AnnotatedHashRef _ x)  -> (fill 44 (pretty h) <+> fill 44 (pretty x))
+                    _ -> Nothing
-              print decoded
 
-        entry $ bindMatch "reflog:tx:objects:list" $ nil_ $ \syn -> lift $ connectedDo do
+              forM_ decoded print
-          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
 
         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
-
+          none
-          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
 
         exportEntries "reflog:"
 

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
+                      (Consume work, [], o) -> do
-              chunks <- liftIO (runExceptT (getTreeContents sto href))
+                        r1 <- work ""
-                           >>= orThrow MissedBlockError
+                        next (r1, [], o)
-                           <&> LBS.toChunks
 
-              what <- toMPlus =<< liftIO do
+                      (Consume work, e:es, o) -> do
-                init <- decompress
+                        r1 <- work e
-                flip fix (init, chunks, mempty :: LBS.ByteString) $ \next -> \case
+                        next (r1, es, o)
 
-                  (Consume work, [], o) -> do
+                      (Produce piece r, e, o) -> do
-                    r1 <- work ""
+                        r1 <- r
-                    next (r1, [], o)
+                        next (r1, e, LBS.append o (LBS.fromStrict piece))
 
-                  (Consume work, e:es, o) -> do
+                      (ZStdS.Done bs, _, o) -> pure (Just (LBS.append o (LBS.fromStrict bs)))
-                    r1 <- work e
-                    next (r1, es, o)
 
-                  (Produce piece r, e, o) -> do
+                      (Error _ _, _, _) -> do
-                    r1 <- r
+                        debug $ "not a valid segment" <+> pretty h
-                    next (r1, e, LBS.append o (LBS.fromStrict piece))
+                        pure Nothing
 
-                  (ZStdS.Done bs, _, o) -> pure (Just (LBS.append o (LBS.fromStrict bs)))
+                  guard (LBS.length what > 0)
 
-                  (Error _ _, _, _) -> do
+                  notice $ "unpacked!" <+> pretty h <+> pretty (LBS.length what)
-                    debug $ "not a valid segment" <+> pretty h
-                    pure Nothing
 
-              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)
+                  lift $ S.yield (h, pieces)
-
-              pieces <- S.toList_ $ do
-                void $ runConsumeLBS what $ readLogFileLBS () $ \o _ _ -> do
-                  lift $ S.yield o
-
-              lift $ S.yield (h, pieces)
 
       liftIO $ forConcurrently_ sink $ \(tx, pieces) -> do
         idxName <- emptyTempFile idxPath "objects-.idx"