diff --git a/hbs2-git3/lib/HBS2/Git3/Import.hs b/hbs2-git3/lib/HBS2/Git3/Import.hs index cb4a00b2..4a0ebe18 100644 --- a/hbs2-git3/lib/HBS2/Git3/Import.hs +++ b/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 UnliftIO.IO.File qualified as UIO +import Data.List qualified as L 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 + diff --git a/hbs2-git3/lib/HBS2/Git3/Run.hs b/hbs2-git3/lib/HBS2/Git3/Run.hs index 844a53fb..61a7cf44 100644 --- a/hbs2-git3/lib/HBS2/Git3/Run.hs +++ b/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 - - 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 + importGitRefLog exportEntries "reflog:"