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,18 +1183,11 @@ 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
 
         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,9 +348,10 @@ 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
-              AnnotatedHashRef _ href <- readTxMay sto (coerce h) >>= toMPlus
+                Nothing -> mzero
-
+                Just (TxCheckpoint{}) -> mzero
+                Just (TxSegment href) -> do
                   -- FIXME: error logging
                   chunks <- liftIO (runExceptT (getTreeContents sto href))
                                >>= orThrow MissedBlockError