fix: hbs2-git. proper refval calculation

Now "git push --force" and "git push origing :branch" aka brancg
removing work.

Basing on "rank", where "rank" is a number
of transactions in reflog on  commit time,
It works, cause reflog is append-only and
transaction number is growing-only and there
is only one writer.

WARNING: you **must** move to this commit right now.

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

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)
                                                                               ])
 

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
 

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
+                    void $ runMaybeT do
-                                <$> s >>= either (const Nothing) Just <&> commitsOfGitLogContextEntry
+                      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

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
+  CREATE VIEW v_refval_actual AS
-    SELECT
+  WITH ranks AS (
-        rv.refname
+      SELECT  rv.refname,
-      , rv.refval
+              MAX(COALESCE(d.depth, 0)) as max_depth,
-      , MAX(d.depth) as depth
+              MAX(COALESCE(r.rank, 0)) as max_rank
-    FROM logrefval rv
+      FROM logrefval rv
-    JOIN logcommitdepth d ON rv.refval = d.kommit
+      LEFT JOIN logcommitdepth d ON rv.refval = d.kommit
-    WHERE rv.refval <> '0000000000000000000000000000000000000000'
+      LEFT JOIN logrank r ON r.hash = rv.loghash
-    GROUP BY rv.refname;
+      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