From 3681fd7beedf8bce7dba095a50f7abc657781268 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Thu, 29 Jun 2023 10:26:27 +0300 Subject: [PATCH] hbs2-git-log-segmentation --- docs/todo/hbs2-git-new-repo.txt | 117 ++++++++++++++ hbs2-git/git-hbs2/GitRemoteMain.hs | 4 + hbs2-git/git-hbs2/GitRemotePush.hs | 8 +- hbs2-git/git-hbs2/GitRemoteTypes.hs | 2 + hbs2-git/hbs2-git.cabal | 1 + hbs2-git/lib/HBS2/Git/Local/CLI.hs | 56 ++++++- hbs2-git/lib/HBS2Git/Export.hs | 242 ++++++++++++++++++---------- hbs2-git/lib/HBS2Git/Import.hs | 5 +- hbs2-git/lib/HBS2Git/State.hs | 53 +++--- hbs2-git/lib/HBS2Git/Types.hs | 10 ++ hbs2-tests/hbs2-tests.cabal | 50 ++++++ hbs2-tests/test/TopSortCommits.hs | 39 +++++ 12 files changed, 471 insertions(+), 116 deletions(-) create mode 100644 hbs2-tests/test/TopSortCommits.hs diff --git a/docs/todo/hbs2-git-new-repo.txt b/docs/todo/hbs2-git-new-repo.txt index 2d4e3f4a..b3fa084d 100644 --- a/docs/todo/hbs2-git-new-repo.txt +++ b/docs/todo/hbs2-git-new-repo.txt @@ -41,3 +41,120 @@ TODO: log-object-reorder-for-better-dedup что префикс лога будет более константным, что ли. т.е при последующем разбиении на сегменты есть шансы, что сегменты в начале лога будут лучше дедупиться. + + +FIXME: segmented-log-import-issue + заметил, что не сразу срабатывает fetch, + а только после скана. + + Выяснить, почему. + + Появилось только после сегментации лога, + возможно, связано с асинхронностью прибытия секций, + а может, сломан импорт. Проверить. + + +FIXME: hbs2-segmented-log-remove-temp-files-ASAP + Удалять временные файлы при импорте (и экспорте) + максимально быстро. + Наличие огромного количества временных файлов в каталоге + убивает произодительность, и сильно жрёт дисковый ресурс + и память, если это tmpfs, драматически замедляя процесс + импорта/экспорта + +FIXME: check-merkle-meta + Проверять метаданные аннотированного дерева. + Писать версию лога в эти данные. + +FIXME: mandatory-compress-whole-log + Эксперимент показал разницу в размере репозитория git и + соответствующего ему стейта hbs2-git приблизительно в 10 раз (!!). + + Очевидно, что git сжимает даже лучше, чем мы бы просто сжали его + объекты архиватором, он проделывает еще некоторые дополнительные + манипуляции, к которым шёл годами. + + Всё, что мы пока можем сделать --- это хотя бы сжимать секции лога + целиком. + + Вопрос, ломать или не ломать при этом совместимость, т.е оставить ли + возможность несжатых логов. + + Указывать ли информацию в аннотации дерева, либо же завести секцию + лога, указывающую, что за ней следуют сжатые данные. + + Сжатие на уровне лога целиком нужно обязательно, т.к. сейчас мы + имеем стейт размера 36G вместо 3.5G на тестовом примере репозитория + nixpkgs. + + Сжатие лога внутри секций неэффективно и, кажется, бесполезно. + + Если его дропнуть, то поломается совместимость. + + Если оставить, но поставить нулевую компрессию --- то будет + бесполезное замедление работы. + + Сжимать на уровне лога целиком --- правильно. + + Но если иметь несегментированный лог, или очень большой размер + сегмента, то это будет очень медленно, и чем больше файл, тем хуже + будет ситуация. + + На сжатии в памяти, кроме того, мы можем исчерпать память. + +TODO: reflog-purge-function-ASAP + Рекурсивное удаление всех данных ссылки при удалении + ссылки. + + Сейчас есть рекурсивное удаление дерева, но для ссылок + будет удалён только журнал транзакций, а сами данные + останутся. + + Можно парсить ссылку, и если там обнаруживаем там дерево, + то сносить его рекурсивно. + + Это надо сделать ASAP, т.к. растёт стейт на тестовых данных, + надо сносить. + + + +NOTE: wtf? + +FIXME: hbs2-git-storeObject-read-chunked + возможно, очень большой mem footprint при экспорте + больших репо объясняется тем, что мы читаем файл + целиком (хоть в LBS). Попробовать читать частями. + +TODO: reflog-monitoring-features + сделать возможность теста рефлога и перезапроса + его секций. почему-то сейчас рефлог подъехал не сразу, + это довольно тревожно. + + +TODO: hbs2-peer-dynamic-reflog-subscription + сделать динамическую персистентную подписку + на рефлоги. + hbs2-peer reflog add REFLOG + hbs2-peer reflog list + hbs2-peer reflog del + сделать соответствующие API + + git clone hbs2://XXX --- добавляет подписку динамически (?) + или по крайней мере может, если есть такая опция в конфиге + +TODO: hbs2-git-remove-REFLOG-from-export + Можно же использовать ключ, если он передан. + Таким образом, параметр можно сделать необязательным, + и если он не задан, то брать из ключа. + +TODO: hbs2-git-export-segment-params-to-export-ASAP + Отдельно обрабатывать блобы, деревья и коммиты + при экспорте. Ввести умолчания -- для блобов + сегмент меньше, для блобов --- больше. + Нужно, так как блобы обычно больше, tree -- в зависимости + от проекта, коммиты -- более менее стабильного размера и + маленькие. + +NOTE: test-1 +NOTE: test-2 + diff --git a/hbs2-git/git-hbs2/GitRemoteMain.hs b/hbs2-git/git-hbs2/GitRemoteMain.hs index 8940127f..5fb66833 100644 --- a/hbs2-git/git-hbs2/GitRemoteMain.hs +++ b/hbs2-git/git-hbs2/GitRemoteMain.hs @@ -81,6 +81,7 @@ guessHead = \case loop :: forall m . ( MonadIO m , MonadCatch m , MonadUnliftIO m + , MonadMask m , HasProgress (RunWithConfig (GitRemoteApp m)) ) => [String] -> GitRemoteApp m () loop args = do @@ -164,16 +165,19 @@ loop args = do next ["list"] -> do + importRefLogNew False ref for_ (LBS.lines hd) (sendLn . LBS.toStrict) sendEol next ["list","for-push"] -> do + importRefLogNew False ref for_ (LBS.lines hd) (sendLn . LBS.toStrict) sendEol next ["fetch", sha1, x] -> do + importRefLogNew False ref trace $ "fetch" <+> pretty (BS.unpack sha1) <+> pretty (BS.unpack x) liftIO $ atomically $ writeTVar batch True -- sendEol diff --git a/hbs2-git/git-hbs2/GitRemotePush.hs b/hbs2-git/git-hbs2/GitRemotePush.hs index d016f776..fbac91e3 100644 --- a/hbs2-git/git-hbs2/GitRemotePush.hs +++ b/hbs2-git/git-hbs2/GitRemotePush.hs @@ -36,7 +36,7 @@ newtype RunWithConfig m a = , MonadTrans , MonadThrow , MonadCatch - -- , MonadMask + , MonadMask , MonadUnliftIO ) @@ -60,7 +60,9 @@ instance MonadIO m => HasRefCredentials (RunWithConfig (GitRemoteApp m)) where push :: forall m . ( MonadIO m , MonadCatch m , HasProgress (RunWithConfig (GitRemoteApp m)) + , MonadMask (RunWithConfig (GitRemoteApp m)) , MonadUnliftIO m + , MonadMask m ) => RepoRef -> [Maybe GitRef] -> GitRemoteApp m (Maybe GitRef) @@ -79,7 +81,7 @@ push remote what@[Just bFrom , Just br] = do trace $ "PUSH PARAMS" <+> pretty what gh <- gitGetHash (normalizeRef bFrom) `orDie` [qc|can't read hash for ref {pretty br}|] _ <- traceTime "TIME: exportRefOnly" $ exportRefOnly () remote (Just bFrom) br gh - importRefLogNew False remote + -- importRefLogNew False remote pure (Just br) push remote [Nothing, Just br] = do @@ -90,7 +92,7 @@ push remote [Nothing, Just br] = do loadCredentials mempty trace $ "deleting remote reference" <+> pretty br exportRefDeleted () remote br - importRefLogNew False remote + -- importRefLogNew False remote pure (Just br) push r w = do diff --git a/hbs2-git/git-hbs2/GitRemoteTypes.hs b/hbs2-git/git-hbs2/GitRemoteTypes.hs index 8be51961..edc03dd3 100644 --- a/hbs2-git/git-hbs2/GitRemoteTypes.hs +++ b/hbs2-git/git-hbs2/GitRemoteTypes.hs @@ -37,6 +37,8 @@ newtype GitRemoteApp m a = , MonadThrow , MonadCatch , MonadUnliftIO + , MonadMask + , MonadTrans ) runRemoteM :: MonadIO m => RemoteEnv -> GitRemoteApp m a -> m a diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index 7547a9bc..603d9a21 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/hbs2-git/hbs2-git.cabal @@ -77,6 +77,7 @@ common shared-properties , resourcet , safe , serialise + , split , sqlite-simple , stm , suckless-conf diff --git a/hbs2-git/lib/HBS2/Git/Local/CLI.hs b/hbs2-git/lib/HBS2/Git/Local/CLI.hs index 929f932d..b8bd5910 100644 --- a/hbs2-git/lib/HBS2/Git/Local/CLI.hs +++ b/hbs2-git/lib/HBS2/Git/Local/CLI.hs @@ -2,6 +2,7 @@ module HBS2.Git.Local.CLI ( module HBS2.Git.Local.CLI , getStdin + , getStdout , stopProcess ) where @@ -31,6 +32,8 @@ import Data.Text.Encoding (decodeLatin1) import Data.Text qualified as Text import System.Process.Typed import Text.InterpolatedString.Perl6 (qc) +import Lens.Micro.Platform +import Control.Monad.Trans.Maybe import System.IO -- FIXME: specify-git-dir @@ -412,7 +415,8 @@ gitRevList :: MonadIO m => Maybe GitHash -> GitHash -> m [GitHash] gitRevList l h = do let from = maybe mempty (\r -> [qc|{pretty r}..|] ) l -- let cmd = [qc|git rev-list --objects --in-commit-order --reverse --date-order {from}{pretty h}|] - let cmd = [qc|git rev-list --objects --reverse --in-commit-order {from}{pretty h}|] + -- let cmd = [qc|git rev-list --objects --reverse --in-commit-order {from}{pretty h}|] + let cmd = [qc|git rev-list --reverse --in-commit-order --objects {from}{pretty h}|] let procCfg = setStdin closed $ setStderr closed (shell cmd) (_, out, _) <- readProcess procCfg pure $ mapMaybe (fmap (fromString . LBS.unpack) . headMay . LBS.words) (LBS.lines out) @@ -453,11 +457,59 @@ gitGetCommitImmediateDeps h = do pure $ fromString @GitHash $ LBS.unpack firstWord -startGitHashObject :: GitObjectType -> IO (Process Handle () ()) +startGitHashObject :: MonadIO m => GitObjectType -> m (Process Handle () ()) startGitHashObject objType = do let cmd = "git" let args = ["hash-object", "-w", "-t", show (pretty objType), "--stdin-paths"] let config = setStdin createPipe $ setStdout closed $ setStderr inherit $ proc cmd args startProcess config +startGitCatFile :: MonadIO m => m (Process Handle Handle ()) +startGitCatFile = do + let cmd = "git" + let args = ["cat-file", "--batch"] + let config = setStdin createPipe $ setStdout createPipe $ setStderr closed $ proc cmd args + startProcess config + +gitReadFromCatFileBatch :: MonadIO m + => Process Handle Handle a + -> GitHash + -> m (Maybe GitObject) + +gitReadFromCatFileBatch prc gh = do + + let ssin = getStdin prc + let sout = getStdout prc + + liftIO $ hPrint ssin (pretty gh) >> hFlush ssin + + runMaybeT do + + here <- liftIO $ hWaitForInput sout 1000 + + guard here + + header <- liftIO $ BS8.hGetLine sout + + case BS8.unpack <$> BS8.words header of + [ha, t, s] -> do + (_, tp, size) <- MaybeT $ pure $ (,,) <$> fromStringMay @GitHash ha + <*> fromStringMay @GitObjectType t + <*> readMay s + + content <- liftIO $ LBS.hGet sout size + + guard (LBS.length content == fromIntegral size) + + void $ liftIO $ LBS.hGet sout 1 + + let object = GitObject tp content + + -- TODO: optionally-check-hash + -- guard (gh== gitHashObject object) + + pure object + + _ -> MaybeT $ pure Nothing + diff --git a/hbs2-git/lib/HBS2Git/Export.hs b/hbs2-git/lib/HBS2Git/Export.hs index ddb9e6ad..b20cb68e 100644 --- a/hbs2-git/lib/HBS2Git/Export.hs +++ b/hbs2-git/lib/HBS2Git/Export.hs @@ -1,11 +1,19 @@ {-# Language AllowAmbiguousTypes #-} -module HBS2Git.Export where +{-# Language RankNTypes #-} +{-# Language TemplateHaskell #-} +module HBS2Git.Export + ( exportRefDeleted + , exportRefOnly + , runExport + , ExportRepoOps + ) where import HBS2.Prelude.Plated import HBS2.Data.Types.Refs import HBS2.OrDie import HBS2.System.Logger.Simple import HBS2.Net.Proto.Definition() +import HBS2.Clock import HBS2.Base58 import HBS2.Git.Local @@ -19,7 +27,6 @@ import HBS2Git.GitRepoLog import Control.Applicative import Control.Monad.Catch import Control.Monad.Reader -import UnliftIO.Async import Control.Concurrent.STM import Data.ByteString.Lazy.Char8 qualified as LBS import Data.Foldable (for_) @@ -37,14 +44,28 @@ import System.Directory import System.FilePath import Text.InterpolatedString.Perl6 (qc) import UnliftIO.IO -import System.IO hiding (hClose,hPrint) +import System.IO hiding (hClose,hPrint,hPutStrLn,hFlush) import System.IO.Temp import Control.Monad.Trans.Resource +import Data.List.Split (chunksOf) class ExportRepoOps a where instance ExportRepoOps () +data ExportEnv = + ExportEnv + { _exportDB :: DBEnv + , _exportWritten :: TVar (HashSet GitHash) + , _exportFileName :: FilePath + , _exportDir :: FilePath + , _exportRepo :: RepoRef + , _exportReadObject :: GitHash -> IO (Maybe GitObject) + } + +makeLenses 'ExportEnv + + exportRefDeleted :: forall o m . ( MonadIO m , MonadCatch m -- , MonadMask m @@ -75,8 +96,7 @@ exportRefDeleted _ repo ref = do -- но вот если мы удаляем уже удаленную ссылку, то для ссылки 00..0 -- будет ошибка где-то. - vals <- withDB db $ stateGetActualRefs <&> List.nub . fmap snd - + vals <- withDB db $ stateGetLastKnownCommits 10 let (ctxHead, ctxBs) = makeContextEntry vals trace $ "DELETING REF CONTEXT" <+> pretty vals @@ -106,11 +126,97 @@ makeContextEntry hashes = (entryHead, payload) payload = GitLogContextCommits (HashSet.fromList hashes) & serialise entryHead = GitLogEntry GitLogContext ha undefined + +newtype ExportT m a = ExportT { fromExportT :: ReaderT ExportEnv m a } + deriving newtype ( Functor + , Applicative + , Monad + , MonadIO + , MonadTrans + , MonadReader ExportEnv + , MonadMask + , MonadCatch + , MonadThrow + ) + +withExportEnv :: MonadIO m => ExportEnv -> ExportT m a -> m a +withExportEnv env f = runReaderT (fromExportT f) env + +writeLogSegments :: forall m . ( MonadIO m + , HasCatAPI m + , MonadMask m + , HasRefCredentials m + , HasConf m + ) + => ( Int -> m () ) + -> GitHash + -> [GitHash] + -> Int + -> [(GitLogEntry, LBS.ByteString)] + -> ExportT m [HashRef] + +writeLogSegments onProgress val objs chunkSize trailing = do + + db <- asks $ view exportDB + written <- asks $ view exportWritten + fname <- asks $ view exportFileName + dir <- asks $ view exportDir + remote <- asks $ view exportRepo + readGit <- asks $ view exportReadObject + + -- FIXME: fix-code-dup + let meta = fromString $ show + $ "hbs2-git" <> line + <> "type:" <+> "hbs2-git-push-log" + <> line + + let segments = chunksOf chunkSize objs + let totalSegments = length segments + + forM (zip segments [1..]) $ \(segment, segmentIndex) -> do + let fpath = dir fname <> "_" <> show segmentIndex + bracket (liftIO $ openBinaryFile fpath AppendMode) + (const $ pure ()) $ \fh -> do + for_ segment $ \d -> do + here <- liftIO $ readTVarIO written <&> HashSet.member d + inState <- withDB db (stateIsLogObjectExists d) + + lift $ onProgress 1 + + unless (here || inState) do + + GitObject tp o <- liftIO $ readGit d `orDie` [qc|error reading object {pretty d}|] + + let entry = GitLogEntry ( gitLogEntryTypeOf tp ) (Just d) ( fromIntegral $ LBS.length o ) + gitRepoLogWriteEntry fh entry o + liftIO $ atomically $ modifyTVar written (HashSet.insert d) + + -- gitRepoLogWriteEntry fh ctx ctxBs + + trace $ "writing" <+> pretty tp <+> pretty d + + when (segmentIndex == totalSegments) $ do + for_ trailing $ \(e, bs) -> do + gitRepoLogWriteEntry fh e bs + + -- finalize log section + hClose fh + + content <- liftIO $ LBS.readFile fpath + logMerkle <- lift $ storeObject meta content `orDie` [qc|Can't store push log|] + + trace $ "PUSH LOG HASH: " <+> pretty logMerkle + trace $ "POSTING REFERENCE UPDATE TRANSACTION" <+> pretty remote <+> pretty logMerkle + + lift $ postRefUpdate remote 0 logMerkle + + pure logMerkle + -- | Exports only one ref to the repo. -- Corresponds to a single ```git push``` operation exportRefOnly :: forall o m . ( MonadIO m , MonadCatch m - -- , MonadMask m + , MonadMask m , MonadUnliftIO m , HasCatAPI m , HasConf m @@ -123,10 +229,11 @@ exportRefOnly :: forall o m . ( MonadIO m -> Maybe GitRef -> GitRef -> GitHash - -> m HashRef + -> m (Maybe HashRef) exportRefOnly _ remote rfrom ref val = do + let repoHead = RepoHead Nothing (HashMap.fromList [(ref,val)]) let repoHeadStr = (LBS.pack . show . pretty . AsGitRefsFile) repoHead @@ -150,15 +257,23 @@ exportRefOnly _ remote rfrom ref val = do trace $ "LAST_KNOWN_REV" <+> braces (pretty rfrom) <+> braces (pretty ref) <+> braces (pretty lastKnownRev) - entries <- gitRevList lastKnownRev val + entries <- traceTime "gitRevList" $ gitRevList lastKnownRev val + + let entryNum = length entries -- NOTE: just-for-test-new-non-empty-push-to-another-branch-112 -- FIXME: may-blow-on-huge-repo-export - types <- gitGetObjectTypeMany entries <&> Map.fromList + types <- traceTime "gitGetObjectTypeMany" $ gitGetObjectTypeMany entries <&> Map.fromList let lookupType t = Map.lookup t types - let justOrDie msg x = pure x `orDie` msg + + let onEntryType e = (fx $ lookupType e, e) + where fx = \case + Just Blob -> 0 + Just Tree -> 1 + Just Commit -> 2 + Nothing -> 3 trace $ "ENTRIES:" <+> pretty (length entries) @@ -166,98 +281,59 @@ exportRefOnly _ remote rfrom ref val = do let fname = [qc|{pretty val}.data|] + -- TODO: investigate-on-signal-behaviour + -- похоже, что в случае прилёта сигнала он тут не обрабатывается, + -- и временный каталог остаётся runResourceT $ do + gitCatFile <- startGitCatFile + written <- liftIO $ newTVarIO (HashSet.empty :: HashSet GitHash) let myTempDir = "hbs-git" temp <- liftIO getCanonicalTemporaryDirectory + (_,dir) <- allocate (createTempDirectory temp myTempDir) removeDirectoryRecursive - let fpath = dir fname - fh <- liftIO $ openBinaryFile fpath AppendMode + let (blobs, notBlobs) = List.partition (\e -> fst (onEntryType e) == 0) entries + let (trees, notTrees) = List.partition (\e -> fst (onEntryType e) == 1) notBlobs + -- FIXME: others-might-be-tags + let (commits, others) = List.partition (\e -> fst (onEntryType e) == 2) notTrees - expMon <- newProgressMonitor "export objects" (length entries) + -- FIXME: hbs2-git-size-hardcode-to-args + let batch = 10000 + let objects = blobs <> trees <> others <> commits + mon <- newProgressMonitor "write objects" (length objects) - enq <- liftIO newTQueueIO + let env = ExportEnv + { _exportDB = db + , _exportWritten = written + , _exportFileName = fname + , _exportDir = dir + , _exportRepo = remote + , _exportReadObject = gitReadFromCatFileBatch gitCatFile + } - -- FIXME: export-wtf? - - aread <- async $ do - for_ entries $ \d -> do - here <- liftIO $ readTVarIO written <&> HashSet.member d - inState <- withDB db (stateIsLogObjectExists d) - updateProgress expMon 1 - unless (here || inState) do - tp <- lookupType d & justOrDie [qc|no object type for {pretty d}|] - o <- gitReadObject (Just tp) d - let entry = GitLogEntry ( gitLogEntryTypeOf tp ) (Just d) ( fromIntegral $ LBS.length o ) - liftIO $ atomically $ writeTQueue enq (Just (d,tp,entry,o)) - - liftIO $ atomically $ writeTQueue enq Nothing - - fix \next -> do - mbEntry <- liftIO $ atomically $ readTQueue enq - case mbEntry of - Nothing -> pure () - Just (d,tp,entry,o) -> do - gitRepoLogWriteEntry fh entry o - liftIO $ atomically $ modifyTVar written (HashSet.insert d) - trace $ "writing" <+> pretty tp <+> pretty d - -- TODO: here-split-log-to-parts - next - - mapM_ wait [aread] - - -- FIXME: problem-log-is-not-assotiated-with-commit - -- Если так получилось, что в журнале подъехала только ссылка, - -- и больше нет никакой информации -- мы не можем определить - -- глубину(высоту?) этой ссылки, и, соответственно, вычислить - -- её depth в стейте. - -- Решение: в этом (или иных) случаях добавлять информацию о контексте, - -- например, состояние других известных ссылок в моменте. Список ссылок - -- берём из state, полагая, что раз ссылка в стейте, значит, она является - -- важной. Имея эту информацию, мы можем хоть как-то вычислять depth - -- этого лога. Похоже на векторные часы, кстати. - - -- это "нормальный" лог. даже если хвост его приедет пустым (не будет коммитов) - -- тут мы запомним, что его контекст = коммит, на который он устанавливает ссылку - -- и этот коммит должен быть в секциях лога, которые приехали перед ним. - -- следствие: у предыдущего лога будет такая же глубина, как и у этого. - - vals <- withDB db $ stateGetActualRefs <&> List.nub . fmap snd - let (e, bs) = makeContextEntry (val:vals) - trace $ "writing context entry" <+> pretty [val] - gitRepoLogWriteEntry fh e bs let ha = gitHashObject (GitObject Blob repoHeadStr) let headEntry = GitLogEntry GitLogEntryHead (Just ha) ( fromIntegral $ LBS.length repoHeadStr ) - gitRepoLogWriteEntry fh headEntry repoHeadStr - -- TODO: find-prev-push-log-and-make-ref - gitRepoLogWriteHead fh (GitLogHeadEntry Nothing) + let upd = updateProgress mon - hClose fh + vals <- withDB db $ stateGetLastKnownCommits 10 + let (ctx, ctxBs) = makeContextEntry (List.nub $ val:vals) - trace "STORING PUSH LOG" + -- 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) + , (headEntry, repoHeadStr) + ]) - let meta = fromString $ show - $ "hbs2-git" <> line - <> "type:" <+> "hbs2-git-push-log" - <> line + -- NOTE: отдаём только последнюю секцию лога, + -- что бы оставить совместимость + pure $ lastMay logz - content <- liftIO $ LBS.readFile fpath - logMerkle <- lift $ storeObject meta content `orDie` [qc|Can't store push log|] - - trace $ "PUSH LOG HASH: " <+> pretty logMerkle - trace $ "POSTING REFERENCE UPDATE TRANSACTION" <+> pretty remote <+> pretty logMerkle - - -- FIXME: calculate-seqno-as-topsort-order - lift $ postRefUpdate remote 0 logMerkle - - pure logMerkle - -runExport :: forall m . (MonadIO m, MonadUnliftIO m, MonadCatch m, HasProgress (App m)) +runExport :: forall m . (MonadIO m, MonadUnliftIO m, MonadCatch m, HasProgress (App m), MonadMask (App m)) => Maybe FilePath -> RepoRef -> App m () runExport fp repo = do diff --git a/hbs2-git/lib/HBS2Git/Import.hs b/hbs2-git/lib/HBS2Git/Import.hs index e2c211c7..4da77b84 100644 --- a/hbs2-git/lib/HBS2Git/Import.hs +++ b/hbs2-git/lib/HBS2Git/Import.hs @@ -200,12 +200,13 @@ importRefLogNew force ref = runResourceT do statePutLogImported h statePutTranImported e + mapM_ hClose handles + withDB db $ do - statePutRefImported logRoot stateUpdateCommitDepths + statePutRefImported logRoot savepointRelease sp0 - mapM_ hClose handles where diff --git a/hbs2-git/lib/HBS2Git/State.hs b/hbs2-git/lib/HBS2Git/State.hs index 08155a0b..c22fe964 100644 --- a/hbs2-git/lib/HBS2Git/State.hs +++ b/hbs2-git/lib/HBS2Git/State.hs @@ -12,7 +12,6 @@ import Data.Function import Database.SQLite.Simple import Database.SQLite.Simple.FromField import Database.SQLite.Simple.ToField -import Control.Monad.IO.Class import Control.Monad.Reader import Text.InterpolatedString.Perl6 (qc) import Data.String @@ -26,6 +25,8 @@ import Data.UUID.V4 qualified as UUID import Control.Monad.Catch import Control.Concurrent.STM import System.IO.Unsafe +import Data.Graph (graphFromEdges, topSort) +import Data.Map qualified as Map -- FIXME: move-orphans-to-separate-module @@ -360,36 +361,36 @@ stateGetActualRefValue ref = do where refname = ? |] (Only ref) <&> fmap fromOnly . listToMaybe +stateGetLastKnownCommits :: MonadIO m => Int -> DB m [GitHash] +stateGetLastKnownCommits n = do + conn <- ask + liftIO $ query conn [qc| + select kommit from logcommitdepth order by depth asc limit ?; + |] (Only n) <&> fmap fromOnly + stateUpdateCommitDepths :: MonadIO m => DB m () stateUpdateCommitDepths = do conn <- ask sp <- savepointNew + + rows <- liftIO $ query_ @(GitHash, GitHash) conn [qc|SELECT kommit, parent FROM logcommitparent|] + + -- TODO: check-it-works-on-huge-graphs + let commitEdges = rows + let (graph, nodeFromVertex, _) = graphFromEdges [(commit, commit, [parent]) | (commit, parent) <- commitEdges] + let sortedVertices = topSort graph + let sortedCommits = reverse [commit | vertex <- sortedVertices, let (commit, _, _) = nodeFromVertex vertex] + let ordered = zip sortedCommits [1..] + savepointBegin sp - -- TODO: check-if-delete-logcommitdepth-is-needed liftIO $ execute_ conn [qc|DELETE FROM logcommitdepth|] - liftIO $ execute_ conn [qc| - INSERT INTO logcommitdepth (kommit, depth) - WITH RECURSIVE depths(kommit, level) AS ( - SELECT - kommit, - 0 - FROM logcommitparent - - UNION ALL - - SELECT - p.kommit, - d.level + 1 - FROM logcommitparent p - INNER JOIN depths d ON p.parent = d.kommit - ) - SELECT - kommit, - MAX(level) - FROM depths - WHERE kommit NOT IN (SELECT kommit FROM logcommitdepth) - GROUP BY kommit; - |] + forM_ ordered $ \(co, n) -> do + liftIO $ execute conn + [qc| INSERT INTO logcommitdepth(kommit,depth) + VALUES(?,?) + ON CONFLICT(kommit) + DO UPDATE SET depth = ? + |] (co,n,n) + pure () savepointRelease sp - diff --git a/hbs2-git/lib/HBS2Git/Types.hs b/hbs2-git/lib/HBS2Git/Types.hs index b783aedc..64e56f96 100644 --- a/hbs2-git/lib/HBS2Git/Types.hs +++ b/hbs2-git/lib/HBS2Git/Types.hs @@ -37,10 +37,12 @@ import Data.HashMap.Strict qualified as HashMap import Codec.Serialise import Control.Concurrent.STM import System.IO qualified as IO +import UnliftIO.IO qualified as UIO import System.IO (Handle) import Data.Kind import Control.Monad.Catch import Control.Monad.IO.Unlift +import Control.Monad.Trans.Resource import System.TimeIt @@ -167,6 +169,13 @@ instance (HasCatAPI m, MonadIO m) => HasCatAPI (MaybeT m) where getHttpPutAPI = lift getHttpPutAPI getHttpRefLogGetAPI = lift getHttpRefLogGetAPI + +instance (HasCatAPI m, MonadIO m) => HasCatAPI (ResourceT m) where + getHttpCatAPI = lift getHttpCatAPI + getHttpSizeAPI = lift getHttpSizeAPI + getHttpPutAPI = lift getHttpPutAPI + getHttpRefLogGetAPI = lift getHttpRefLogGetAPI + -- instance (HasCatAPI (App m), MonadIO m) => HasCatAPI (ResourceT (App m)) where -- getHttpCatAPI = lift getHttpCatAPI -- getHttpSizeAPI = lift getHttpSizeAPI @@ -192,6 +201,7 @@ newtype App m a = , MonadReader AppEnv , MonadThrow , MonadCatch + , MonadMask , MonadUnliftIO , MonadTrans ) diff --git a/hbs2-tests/hbs2-tests.cabal b/hbs2-tests/hbs2-tests.cabal index 3e94e70a..ffb49a7c 100644 --- a/hbs2-tests/hbs2-tests.cabal +++ b/hbs2-tests/hbs2-tests.cabal @@ -545,3 +545,53 @@ test-suite test-misc , vector , terminal-progress-bar + +executable topsort-commits + import: shared-properties + import: common-deps + default-language: Haskell2010 + + ghc-options: + -- -prof + -- -fprof-auto + + other-modules: + + -- other-extensions: + + -- type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: TopSortCommits.hs + + build-depends: + base, hbs2-core + -- , async + -- , attoparsec + , bytestring + -- , cache + -- , clock + , containers + , interpolatedstring-perl6 + -- , data-default + -- , data-textual + -- , directory + -- , hashable + -- , microlens-platform + -- , mtl + -- , mwc-random + -- , network + -- , network-ip + , prettyprinter + -- , random + , safe + , serialise + -- , stm + -- , streaming + -- , saltine + , text + , typed-process + -- , transformers + , uniplate + -- , vector + -- , fast-logger + diff --git a/hbs2-tests/test/TopSortCommits.hs b/hbs2-tests/test/TopSortCommits.hs new file mode 100644 index 00000000..b4eeb952 --- /dev/null +++ b/hbs2-tests/test/TopSortCommits.hs @@ -0,0 +1,39 @@ +module Main where + +import Control.Monad +import Control.Monad (replicateM) +import Data.Graph +import Data.List.Split +import System.Random + +-- main = do +-- input <- getContents +-- let commitLines = lines input +-- let commitEdges = [(commit, parent) | line <- commitLines, let [commit, parent] = splitOn "|" line] +-- let (graph, nodeFromVertex, vertexFromKey) = graphFromEdges [(commit, commit, [parent]) | (commit, parent) <- commitEdges] +-- let sortedVertices = topSort graph +-- let sortedCommits = reverse [commit | vertex <- sortedVertices, let (commit, _, _) = nodeFromVertex vertex] +-- let ordered = zip sortedCommits [1..] +-- forM_ ordered \(s,n) -> putStrLn (s <> " " <> show n) + + + + +generateCommitGraph :: Int -> IO [(String, String)] +generateCommitGraph edgesCount = do + gen <- getStdGen + let commitIds = randomRs ('a','z') gen :: [Char] + let commitNames = take edgesCount $ map (\id -> "commit" ++ [id]) commitIds + let parentNames = "root" : init commitNames + return $ zip commitNames parentNames + +main :: IO () +main = do + let edgesCount = 1000000 -- Set the desired number of edges + commitEdges <- generateCommitGraph edgesCount + mapM_ print commitEdges + let (graph, nodeFromVertex, vertexFromKey) = graphFromEdges [(commit, commit, [parent]) | (commit, parent) <- commitEdges] + let sortedVertices = topSort graph + let sortedCommits = reverse [commit | vertex <- sortedVertices, let (commit, _, _) = nodeFromVertex vertex] + let ordered = zip sortedCommits [1..] + forM_ ordered \(s,n) -> putStrLn (s <> " " <> show n)