diff --git a/hbs2-git/lib/HBS2Git/App.hs b/hbs2-git/lib/HBS2Git/App.hs index 94c0b86d..26d6a31d 100644 --- a/hbs2-git/lib/HBS2Git/App.hs +++ b/hbs2-git/lib/HBS2Git/App.hs @@ -56,6 +56,8 @@ import Control.Concurrent.Async import System.Environment import Prettyprinter.Render.Terminal +import Streaming.Prelude qualified as S + instance MonadIO m => HasCfgKey ConfBranch (Set String) m where key = "branch" @@ -321,12 +323,26 @@ readObject h = runMaybeT do Left{} -> mzero Right (hrr :: [HashRef]) -> do for_ hrr $ \(HashRef hx) -> do - block <- MaybeT $ readBlock (HashRef hx) liftIO $ atomically $ writeTQueue q block mconcat <$> liftIO (atomically $ flushTQueue q) +calcRank :: forall m . (MonadIO m, HasCatAPI m) => HashRef -> m Int +calcRank h = fromMaybe 0 <$> runMaybeT do + + blk <- MaybeT $ readBlock h + + ann <- MaybeT $ pure $ deserialiseOrFail @(MTree [HashRef]) blk & either (const Nothing) Just + + n <- S.toList_ $ do + walkMerkleTree ann (lift . readBlock . HashRef) $ \(hr :: Either (Hash HbSync) [HashRef]) -> do + case hr of + Left{} -> pure () + Right (hrr :: [HashRef]) -> do + S.yield (List.length hrr) + + pure $ sum n postRefUpdate :: ( MonadIO m , HasRefCredentials m diff --git a/hbs2-git/lib/HBS2Git/Export.hs b/hbs2-git/lib/HBS2Git/Export.hs index 8245a2e1..2f8ef3d2 100644 --- a/hbs2-git/lib/HBS2Git/Export.hs +++ b/hbs2-git/lib/HBS2Git/Export.hs @@ -51,6 +51,7 @@ import System.IO.Temp import Control.Monad.Trans.Resource import Data.List.Split (chunksOf) import Codec.Compression.GZip +import Control.Monad.Trans.Maybe class ExportRepoOps a where @@ -111,8 +112,16 @@ exportRefDeleted _ repo ref = do let ha = gitHashObject (GitObject Blob repoHeadStr) let headEntry = GitLogEntry GitLogEntryHead (Just ha) ( fromIntegral $ LBS.length repoHeadStr ) + r <- fromMaybe 0 <$> runMaybeT do + h <- MaybeT $ readRef repo + calcRank h + + let rankBs = serialise (GitLogContextRank r) + let rank = GitLogEntry GitLogContext Nothing (fromIntegral $ LBS.length rankBs) + let content = gitRepoLogMakeEntry opts ctxHead ctxBs - <> gitRepoLogMakeEntry opts headEntry repoHeadStr + <> gitRepoLogMakeEntry opts headEntry repoHeadStr + <> gitRepoLogMakeEntry opts rank rankBs -- FIXME: remove-code-dup let meta = fromString $ show @@ -125,7 +134,7 @@ exportRefDeleted _ repo ref = do pure logMerkle makeContextEntry :: [GitHash] -> (GitLogEntry, LBS.ByteString) -makeContextEntry hashes = (entryHead, payload) +makeContextEntry hashes = (entryHead, payload) where ha = Nothing payload = GitLogContextCommits (HashSet.fromList hashes) & serialise @@ -251,7 +260,6 @@ exportRefOnly :: forall o m . ( MonadIO m exportRefOnly _ remote rfrom ref val = do - let repoHead = RepoHead Nothing (HashMap.fromList [(ref,val)]) let repoHeadStr = (LBS.pack . show . pretty . AsGitRefsFile) repoHead @@ -259,6 +267,10 @@ exportRefOnly _ remote rfrom ref val = do dbPath <- makeDbPath remote db <- dbEnv dbPath + r <- fromMaybe 0 <$> runMaybeT do + h <- MaybeT $ readRef remote + calcRank h + trace $ "exportRefOnly" <+> pretty remote <+> pretty ref <+> pretty val -- 1. get max ref value for known REMOTE branch @@ -341,9 +353,13 @@ exportRefOnly _ remote rfrom ref val = do vals <- withDB db $ stateGetLastKnownCommits 10 let (ctx, ctxBs) = makeContextEntry (List.nub $ val:vals) + let rankBs = serialise (GitLogContextRank r) + let rank = GitLogEntry GitLogContext Nothing (fromIntegral $ LBS.length rankBs) + -- we need context entries to determine log HEAD operation sequence -- so only the last section needs it alongwith headEntry logz <- lift $ withExportEnv env (writeLogSegments upd val objects batch [ (ctx, ctxBs) + , (rank, rankBs) , (headEntry, repoHeadStr) ]) diff --git a/hbs2-git/lib/HBS2Git/GitRepoLog.hs b/hbs2-git/lib/HBS2Git/GitRepoLog.hs index 1630281b..1ead5034 100644 --- a/hbs2-git/lib/HBS2Git/GitRepoLog.hs +++ b/hbs2-git/lib/HBS2Git/GitRepoLog.hs @@ -96,12 +96,13 @@ instance Serialise GitLogHeadDelEntry data GitLogContextEntry = GitLogNoContext | GitLogContextCommits (HashSet GitHash) + | GitLogContextRank Int deriving stock (Eq,Data,Generic) commitsOfGitLogContextEntry :: GitLogContextEntry -> [GitHash] commitsOfGitLogContextEntry = \case - GitLogNoContext -> mempty GitLogContextCommits co -> HashSet.toList co + _ -> mempty instance Serialise GitLogContextEntry diff --git a/hbs2-git/lib/HBS2Git/Import.hs b/hbs2-git/lib/HBS2Git/Import.hs index e9b68ab9..2abfae64 100644 --- a/hbs2-git/lib/HBS2Git/Import.hs +++ b/hbs2-git/lib/HBS2Git/Import.hs @@ -289,10 +289,18 @@ importRefLogNew opts ref = runResourceT do GitLogContext -> do trace $ "logobject" <+> pretty h <+> "context" <+> pretty (view gitLogEntryHash entry) - let co = fromMaybe mempty $ deserialiseOrFail @GitLogContextEntry - <$> s >>= either (const Nothing) Just <&> commitsOfGitLogContextEntry + void $ runMaybeT do + ss <- MaybeT $ pure s + logEntry <- MaybeT $ pure $ deserialiseOrFail @GitLogContextEntry ss & either (const Nothing) Just - forM_ co (statePutLogContextCommit h) + case logEntry of + GitLogContextRank n -> do + lift $ statePutLogContextRank h n + + GitLogContextCommits co -> do + lift $ forM_ co (statePutLogContextCommit h) + + _ -> pure () GitLogEntryHead -> do trace $ "HEAD ENTRY" <+> viaShow s diff --git a/hbs2-git/lib/HBS2Git/State.hs b/hbs2-git/lib/HBS2Git/State.hs index a79d669b..1534b23d 100644 --- a/hbs2-git/lib/HBS2Git/State.hs +++ b/hbs2-git/lib/HBS2Git/State.hs @@ -183,6 +183,14 @@ stateInit = do ); |] + liftIO $ execute_ conn [qc| + CREATE TABLE IF NOT EXISTS logrank + ( hash text not null + , rank int not null + , primary key (hash) + ); + |] + liftIO $ execute_ conn [qc| DROP VIEW IF EXISTS v_log_depth; |] @@ -192,18 +200,28 @@ stateInit = do |] liftIO $ execute_ conn [qc| - CREATE VIEW v_refval_actual AS - SELECT - rv.refname - , rv.refval - , MAX(d.depth) as depth - FROM logrefval rv - JOIN logcommitdepth d ON rv.refval = d.kommit - WHERE rv.refval <> '0000000000000000000000000000000000000000' - GROUP BY rv.refname; + CREATE VIEW v_refval_actual AS + WITH ranks AS ( + SELECT rv.refname, + MAX(COALESCE(d.depth, 0)) as max_depth, + MAX(COALESCE(r.rank, 0)) as max_rank + FROM logrefval rv + LEFT JOIN logcommitdepth d ON rv.refval = d.kommit + LEFT JOIN logrank r ON r.hash = rv.loghash + GROUP BY rv.refname + ) + SELECT r.refname, rv.refval, r.max_rank as r, r.max_depth as d + FROM logrefval rv + JOIN ranks r ON r.refname = rv.refname + WHERE + ( + (r.max_rank > 0 AND rv.loghash IN (SELECT hash FROM logrank WHERE rank = r.max_rank)) + OR (r.max_rank = 0 AND rv.refval IN (SELECT kommit FROM logcommitdepth WHERE depth = r.max_depth)) + ) + AND rv.refval <> '0000000000000000000000000000000000000000' + ORDER BY r.refname; |] - newtype Savepoint = Savepoint String deriving newtype (IsString) @@ -296,6 +314,15 @@ statePutLogContextCommit loghash ctx = do on conflict (loghash,githash) do nothing |] (loghash,ctx) + +statePutLogContextRank :: MonadIO m => HashRef -> Int -> DB m () +statePutLogContextRank loghash rank = do + conn <- stateConnection + liftIO $ execute conn [qc| + insert into logrank (hash,rank) values(?,?) + on conflict (hash) do nothing + |] (loghash,rank) + statePutLogCommitParent :: MonadIO m => (GitHash, GitHash) -> DB m () statePutLogCommitParent row = do conn <- stateConnection