wip, refs calculation

hbs2-git3/app/Main.hs

@@ -17,6 +17,7 @@ import HBS2.Peer.CLI.Detect
 import HBS2.Peer.RPC.API.LWWRef
 import HBS2.Peer.RPC.API.Storage
 import HBS2.Peer.RPC.Client.StorageClient
+import HBS2.Storage.Operations.Missed
 
 -- move to Data.Config.Suckless.Script.Filea sepatate library
 import HBS2.Data.Log.Structured
@@ -52,6 +53,7 @@ import Data.List.Split (chunksOf)
 import Data.ByteString.Lazy.Char8 qualified as LBS8
 import Data.ByteString.Lazy qualified as LBS
 import Data.ByteString qualified as BS
+import Data.ByteString.Char8 qualified as BS8
 import Data.ByteString.Lazy ( ByteString )
 import Data.ByteString.Builder as Builder
 import Network.ByteOrder qualified as N
@@ -81,7 +83,7 @@ import System.Directory (setCurrentDirectory)
 import System.Random hiding (next)
 import System.IO.MMap (mmapFileByteString)
 import System.IO qualified as IO
-import System.IO (hPrint)
+import System.IO (hPrint,hPutStrLn,hPutStr)
 import System.IO.Temp as Temp
 import System.TimeIt
 
@@ -889,7 +891,11 @@ theDict = do
 
             forM_ decoded print
 
-        entry $ bindMatch "reflog:import:pack" $ nil_ $ \syn -> lift $ connectedDo do
+        entry $ bindMatch "reflog:refs" $ nil_ $ \syn -> lift $ connectedDo do
+          rrefs <- importedRefs
+          liftIO $ print $ pretty rrefs
+
+        entry $ bindMatch "reflog:import" $ nil_ $ \syn -> lift $ connectedDo do
           updateReflogIndex
 
           packs <- findGitDir
@@ -898,11 +904,11 @@ theDict = do
 
           state <- getStatePathM
 
+          sto <- getStorage
+
           let imported = state </> "imported"
 
-          prev <- runMaybeT do
+          prev <- importedCheckpoint
-            f <- liftIO (try @_ @IOError (readFile imported)) >>= toMPlus
-            toMPlus (fromStringMay @HashRef f)
 
           excl <- maybe1 prev (pure mempty) $ \p -> do
             txListAll (Just p) <&> HS.fromList . fmap fst
@@ -911,20 +917,34 @@ theDict = do
 
           hxs <- txList ( pure . not . flip HS.member excl ) rv
 
-          forConcurrently_ hxs $ \case
+          cp' <- flip fix (fmap snd hxs, Nothing) $ \next -> \case
-            (_, TxCheckpoint{}) -> none
+            ([], r) -> pure (gitTxTree <$> r)
-            (h, TxSegment tree) -> do
+            (TxSegment{}:xs, l) -> next (xs, l)
-              s <- writeAsGitPack  packs tree
+            (cp@(TxCheckpoint n tree) : xs, l) -> do
+              full <- findMissedBlocks sto tree <&> L.null
+              if full && Just n > (getGitTxRank <$> l) then do
+                next (xs, Just cp)
+              else do
+                next (xs, l)
 
-              for_ s $ \file -> do
+          void $ runMaybeT do
-                gitRunCommand [qc|git index-pack {file}|]
+            cp <- toMPlus cp'
-                  >>= orThrowPassIO
+            notice $ "found checkpoint" <+> pretty cp
+            txs <- lift $ txList ( pure . not . flip HS.member excl ) (Just cp)
 
-              notice $ "imported" <+> pretty h
+            lift do
+              forConcurrently_ txs $ \case
+                (_, TxCheckpoint{}) -> none
+                (h, TxSegment tree) -> do
+                  s <- writeAsGitPack  packs tree
 
-          for_ rv $ \r -> do
+                  for_ s $ \file -> do
-            liftIO $ UIO.withBinaryFileAtomic imported WriteMode $ \fh -> do
+                    gitRunCommand [qc|git index-pack {file}|]
-              IO.hPutStr fh (show $ pretty r)
+                      >>= orThrowPassIO
+
+                  notice $ "imported" <+> pretty h
+
+              updateImportedCheckpoint cp
 
         exportEntries "reflog:"
 

hbs2-git3/lib/HBS2/Git3/Prelude.hs

@@ -49,6 +49,7 @@ import Data.HashSet qualified as HS
 import Data.Kind
 import System.Exit qualified as Q
 import System.IO.MMap as Exported
+import System.FilePattern as Exported
 
 import GHC.Natural as Exported
 import UnliftIO as Exported

hbs2-git3/lib/HBS2/Git3/State/Index.hs

@@ -11,6 +11,7 @@ import HBS2.Git3.Git
 import HBS2.Data.Log.Structured
 
 import Data.ByteString qualified as BS
+import Data.ByteString.Char8 qualified as BS8
 import Data.ByteString.Lazy ( ByteString )
 import Data.ByteString.Lazy qualified as LBS
 import Data.ByteString.Lazy.Char8 qualified as LBS8
@@ -32,6 +33,8 @@ import Data.Word
 import Data.Config.Suckless
 import Data.Config.Suckless.Script.File
 
+import System.IO (hPrint)
+
 import Streaming.Prelude qualified as S
 import System.TimeIt
 
@@ -378,3 +381,63 @@ updateReflogIndex = do
           UIO.withBinaryFileAtomic name WriteMode $ \wh -> do
             for_ es $ \s -> LBS8.hPutStrLn wh s
 
+
+importedCheckpoint :: forall m . ( Git3Perks m
+                                 , MonadReader Git3Env m
+                                 , HasClientAPI RefLogAPI UNIX m
+                                 , HasStorage m
+                                 ) => m (Maybe HashRef)
+
+importedCheckpoint = do
+  state <- getStatePathM
+  let imported = state </> "imported"
+  runMaybeT do
+    f <- liftIO (try @_ @IOError (readFile imported)) >>= toMPlus
+    toMPlus (fromStringMay @HashRef f)
+
+{- HLINT ignore "Functor law"-}
+importedRefs :: forall m . ( Git3Perks m
+                           , MonadReader Git3Env m
+                           , HasClientAPI RefLogAPI UNIX m
+                           , HasStorage m
+                           ) => m [(GitRef, GitHash)]
+
+importedRefs = do
+
+  state <- getStatePathM
+
+  refs <- dirFiles state
+            <&> filter ( (== ".ref") . takeExtension )
+            >>= mapM (try @_ @IOError . liftIO . readFile)
+            <&> unlines . rights
+            <&> parseTop
+            <&> fromRight mempty
+
+  txh <- maybe mempty HS.fromList <$> runMaybeT do
+           cp <- lift importedCheckpoint >>= toMPlus
+           fmap fst <$> lift (txListAll (Just cp))
+
+  let rrefs = [ (n,((GitRef (BS8.pack n),g),r))
+              | ListVal [ SymbolVal "R"
+                        , HashLike th
+                        , LitIntVal r
+                        , GitHashLike g
+                        , StringLike n ] <- refs
+              , HS.member th txh
+              ] & HM.fromListWith (\(a,t1) (b,t2) -> if t1 > t2 then (a,t1) else (b,t2))
+                & fmap fst . HM.elems
+
+  pure rrefs
+
+updateImportedCheckpoint :: forall m . ( Git3Perks m
+                                 , MonadReader Git3Env m
+                                 , HasClientAPI RefLogAPI UNIX m
+                                 , HasStorage m
+                                 ) => HashRef -> m ()
+
+updateImportedCheckpoint cp = do
+  state <- getStatePathM
+  let imported = state </> "imported"
+  liftIO $ UIO.withBinaryFileAtomic imported WriteMode $ \fh -> do
+    hPrint fh (show $ pretty cp)
+

hbs2-git3/lib/HBS2/Git3/State/RefLog.hs

@@ -8,8 +8,13 @@ import Data.Maybe
 import Streaming.Prelude qualified as S
 
 data GitTx =
-    TxSegment HashRef
+    TxSegment    { gitTxTree :: HashRef }
-  | TxCheckpoint Natural HashRef
+  | TxCheckpoint { gitTxRank :: Natural, gitTxTree ::  HashRef }
+
+getGitTxRank  :: GitTx -> Natural
+getGitTxRank = \case
+  TxSegment _ -> 0
+  TxCheckpoint n _ -> n
 
 data RefLogException =
     RefLogRPCException