wip

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

@@ -6,9 +6,11 @@ import HBS2.Git3.Prelude
 import HBS2.Git3.State.Index
 import HBS2.Git3.Git
 import HBS2.Git3.Git.Pack
-import HBS2.CLI.Run.Internal.Merkle (getTreeContents)
+import HBS2.Git3.State.RefLog
 import HBS2.Git3.State.Segment
 
+import HBS2.Storage.Operations.Missed
+import HBS2.CLI.Run.Internal.Merkle (getTreeContents)
 import HBS2.Data.Log.Structured
 
 import HBS2.System.Dir
@@ -19,9 +21,11 @@ import Data.ByteString.Lazy qualified as LBS
 import Data.ByteString qualified as BS
 import Data.HashSet (HashSet)
 import Data.HashSet qualified as HS
-import System.IO.Temp as Temp
+import Data.List qualified as L
-import UnliftIO.IO.File qualified as UIO
 import Network.ByteOrder qualified as N
+import System.IO.Temp as Temp
+import Text.InterpolatedString.Perl6 (qc)
+import UnliftIO.IO.File qualified as UIO
 
 data ImportException =
   ImportInvalidSegment HashRef
@@ -101,3 +105,61 @@ writeAsGitPack dir href = do
     rm file
     pure Nothing
 
+
+
+importGitRefLog :: forall m . ( HBS2GitPerks m
+                              , HasStorage m
+                              , HasClientAPI PeerAPI UNIX m
+                              , HasClientAPI RefLogAPI UNIX m
+                              , MonadReader Git3Env m
+                              )
+             => m ()
+
+importGitRefLog = do
+
+  updateReflogIndex
+
+  packs <- findGitDir
+             >>= orThrowUser "git directory not found"
+             <&> (</> "objects/pack")
+
+  sto <- getStorage
+
+  prev <- importedCheckpoint
+
+  excl <- maybe1 prev (pure mempty) $ \p -> do
+    txListAll (Just p) <&> HS.fromList . fmap fst
+
+  rv <- refLogRef
+
+  hxs <- txList ( pure . not . flip HS.member excl ) rv
+
+  cp' <- flip fix (fmap snd hxs, Nothing) $ \next -> \case
+    ([], r) -> pure (gitTxTree <$> r)
+    (TxSegment{}:xs, l) -> next (xs, l)
+    (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)
+
+  void $ runMaybeT do
+    cp <- toMPlus cp'
+    notice $ "found checkpoint" <+> pretty cp
+    txs <- lift $ txList ( pure . not . flip HS.member excl ) (Just cp)
+
+    lift do
+      forConcurrently_ txs $ \case
+        (_, TxCheckpoint{}) -> none
+        (h, TxSegment tree) -> do
+          s <- writeAsGitPack  packs tree
+
+          for_ s $ \file -> do
+            gitRunCommand [qc|git index-pack {file}|]
+              >>= orThrowPassIO
+
+          notice $ "imported" <+> pretty h
+
+      updateImportedCheckpoint cp
+

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

@@ -685,51 +685,7 @@ theDict = do
           liftIO $ print $ pretty p
 
         entry $ bindMatch "reflog:import" $ nil_ $ \syn -> lift $ connectedDo do
-          updateReflogIndex
+          importGitRefLog
-
-          packs <- findGitDir
-                     >>= orThrowUser "git directory not found"
-                     <&> (</> "objects/pack")
-
-          sto <- getStorage
-
-          prev <- importedCheckpoint
-
-          excl <- maybe1 prev (pure mempty) $ \p -> do
-            txListAll (Just p) <&> HS.fromList . fmap fst
-
-          rv <- refLogRef
-
-          hxs <- txList ( pure . not . flip HS.member excl ) rv
-
-          cp' <- flip fix (fmap snd hxs, Nothing) $ \next -> \case
-            ([], r) -> pure (gitTxTree <$> r)
-            (TxSegment{}:xs, l) -> next (xs, l)
-            (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)
-
-          void $ runMaybeT do
-            cp <- toMPlus cp'
-            notice $ "found checkpoint" <+> pretty cp
-            txs <- lift $ txList ( pure . not . flip HS.member excl ) (Just cp)
-
-            lift do
-              forConcurrently_ txs $ \case
-                (_, TxCheckpoint{}) -> none
-                (h, TxSegment tree) -> do
-                  s <- writeAsGitPack  packs tree
-
-                  for_ s $ \file -> do
-                    gitRunCommand [qc|git index-pack {file}|]
-                      >>= orThrowPassIO
-
-                  notice $ "imported" <+> pretty h
-
-              updateImportedCheckpoint cp
 
         exportEntries "reflog:"