From 1b93659ef4a8adad2ac0e552130e949cb2b7bfbe Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Mon, 26 Jun 2023 18:02:57 +0300 Subject: [PATCH] new-repository-format --- docs/devlog.md | 21 + .../Makefile | 0 .../hbs2-git-problem.tex | 0 docs/papers/Makefile | 15 + docs/papers/hbs2-git-new-repo.tex | 537 +++++++++++++++ docs/papers/hbs2-git-problem.tex | 627 ++++++++++++++++++ docs/todo/delete-refs-properly.txt | 11 + docs/todo/hbs2-git-new-repo.txt | 33 + docs/todo/hbs2-slow-import-export.txt | 12 + hbs2-git/git-hbs2/GitRemoteMain.hs | 102 ++- hbs2-git/git-hbs2/GitRemotePush.hs | 55 +- hbs2-git/git-hbs2/GitRemoteTypes.hs | 2 + hbs2-git/git-hbs2/Main.hs | 16 + hbs2-git/git-hbs2/RunShow.hs | 18 +- hbs2-git/hbs2-git.cabal | 21 +- hbs2-git/lib/HBS2/Git/Local/CLI.hs | 155 ++++- hbs2-git/lib/HBS2/Git/Types.hs | 12 + hbs2-git/lib/HBS2Git/App.hs | 20 - hbs2-git/lib/HBS2Git/Export.hs | 344 ++++++---- hbs2-git/lib/HBS2Git/GitRepoLog.hs | 180 +++++ hbs2-git/lib/HBS2Git/Import.hs | 213 +++--- hbs2-git/lib/HBS2Git/ListRefs.hs | 23 + hbs2-git/lib/HBS2Git/State.hs | 388 ++++++----- hbs2-git/lib/HBS2Git/Types.hs | 51 +- hbs2-git/lib/HBS2Git/Update.hs | 56 -- 25 files changed, 2307 insertions(+), 605 deletions(-) rename docs/{hbs2-git-problem => hbs2-git-repo}/Makefile (100%) rename docs/{hbs2-git-problem => hbs2-git-repo}/hbs2-git-problem.tex (100%) create mode 100644 docs/papers/Makefile create mode 100644 docs/papers/hbs2-git-new-repo.tex create mode 100644 docs/papers/hbs2-git-problem.tex create mode 100644 docs/todo/delete-refs-properly.txt create mode 100644 docs/todo/hbs2-git-new-repo.txt create mode 100644 docs/todo/hbs2-slow-import-export.txt create mode 100644 hbs2-git/lib/HBS2Git/GitRepoLog.hs delete mode 100644 hbs2-git/lib/HBS2Git/Update.hs diff --git a/docs/devlog.md b/docs/devlog.md index 7fe555c5..f8a66ac7 100644 --- a/docs/devlog.md +++ b/docs/devlog.md @@ -1,3 +1,24 @@ +## 2023-06-23 + Странно, но всё еще новый формат репозитория. + Вроде бы сегодня можно попробовать его смержить + в мастер. Совместим со старым он не будет + +## 2023-04-26 + +тестируем новый формат репозитория. +получится ли запустить его одновременно +со старым? вопрос. + +Потенциально, можно делать инкрементальные добавления +в файл лога гита + так же нужно добавить запись +"последняя запись". Но тогда эту последнюю запись +невозможно будет добавлять, так как лог append-only. + +Можно её добавить только при передаче через TCP стрим, +что бы как-то определять конец файла. + +Тест. + ## 2023-04-18 diff --git a/docs/hbs2-git-problem/Makefile b/docs/hbs2-git-repo/Makefile similarity index 100% rename from docs/hbs2-git-problem/Makefile rename to docs/hbs2-git-repo/Makefile diff --git a/docs/hbs2-git-problem/hbs2-git-problem.tex b/docs/hbs2-git-repo/hbs2-git-problem.tex similarity index 100% rename from docs/hbs2-git-problem/hbs2-git-problem.tex rename to docs/hbs2-git-repo/hbs2-git-problem.tex diff --git a/docs/papers/Makefile b/docs/papers/Makefile new file mode 100644 index 00000000..b483ce40 --- /dev/null +++ b/docs/papers/Makefile @@ -0,0 +1,15 @@ +all: hbs2-git-problem hbs2-git-new-repo + +.PHONY: all clean + +%.pdf: %.tex + xelatex $< + xelatex $< + +hbs2-git-problem: hbs2-git-problem.pdf + +hbs2-git-new-repo: hbs2-git-new-repo.pdf + +clean: + rm -f *.aux *.log *.nav *.out *.snm *.vrb *.toc *.pdf + diff --git a/docs/papers/hbs2-git-new-repo.tex b/docs/papers/hbs2-git-new-repo.tex new file mode 100644 index 00000000..32b0089f --- /dev/null +++ b/docs/papers/hbs2-git-new-repo.tex @@ -0,0 +1,537 @@ +\documentclass[11pt,a4paper]{article} + +\usepackage{polyglossia} +\usepackage{xltxtra} +\usepackage[margin=2cm,a4paper]{geometry}% http://ctan.org/pkg/geometry +\usepackage{pdfpages} +\usepackage{graphicx} +\usepackage[ddmmyyyy]{datetime} +\usepackage{booktabs} +\usepackage{enumitem} +\usepackage{amssymb} +\usepackage{amsmath} +\usepackage{bm} +\usepackage[nomessages]{fp} +\usepackage{caption} +\usepackage{url} +\usepackage{indentfirst} +\usepackage[parfill]{parskip} +\usepackage[ colorlinks=true + , linkcolor=black + , anchorcolor=black + , citecolor=black + , filecolor=black + , menucolor=black + , runcolor=black + , urlcolor=blue]{hyperref} +\usepackage{tikz} +\usetikzlibrary{arrows,snakes,shapes,backgrounds,positioning,calc} +\usepackage{marvosym} +\usepackage{pifont} +\usepackage{fontspec} +\usepackage{fontawesome5} +\usepackage{listings} +\usepackage{verbatim} +\usepackage{xcolor} +\usepackage{float} % Needed for the floating environment + +\setmainlanguage{russian} +\defaultfontfeatures{Ligatures=TeX,Mapping=tex-text} +\setmainfont{Liberation Serif} +\newfontfamily\cyrillicfont{Liberation Serif}[Script=Cyrillic] +\newfontfamily{\cyrillicfonttt}{Liberation Mono}[Scale=0.8] + +\setlist{noitemsep} +\setlength{\intextsep}{2cm} + +\newcommand{\term}[2]{\textit{#2}} +\renewcommand{\dateseparator}{.} +\renewcommand*\contentsname{Содержание} + +\lstset{ + language=Haskell, + basicstyle=\ttfamily\small, + keywordstyle=\color{blue}, + commentstyle=\color{green}, + stringstyle=\color{red}, + % numberstyle=\tiny\color{gray}, + % numbers=left, + % stepnumber=1, + showstringspaces=false, + breaklines=true, + frame=single, +} + +\newfloat{Code}{t}{myc} + +\graphicspath{ {img/}} + +\title{Репозиторий hbs2-git} + +\begin{document} + +\maketitle + +\section{Идея} + +hbs2-git это адаптер, позволяющий git работать с HBS2 в качестве бекенда для сохранения и получения +объектов. HBS2 это распределённый P2P CAS, позволяющий обмениваться данными, синхронизировать их, +подписываться на специфические источники при помощи механизма \term{reflog}{ссылок}. + +Таким образом, hbs2-git позволяет производить децентрализованную синхронизацию репозиториев без +участия какого-то выделенного сервера/сервиса, используя вместо него множество пиров, которые +находят друг-друга при помощи механизма \term{pex}{PEX} (Peer Exchange) --- то есть находят друг +друга при помощи broadcast сообщений, DNS бутстрапа и списка известных пиров, то есть примерно теми +же способами, что используются в прочих децентрализованных сетях. + +Авторизация и аутентификация осуществляются при помощи криптографических механизмов: криптоподписи +и шифрования. + +Механизмы эти работают на уровне ссылок, блоков, протоколов и можно еще дополнительно шифровать +собственный контент, если будет такое желание и необходимость. + +Вместо того, что бы делать $git~push$ в remote на каком-то сервере с доменным именем, доступом и +прочее, $git~push$ происходит в \term{reflog}{ссылку/рефлог}, который поддерживается всеми пирами, +которые согласны поддерживать этот рефлог. + +Узел hbs2-peer может постить \term{transaction}{транзакции} обновления ссылок и получать их, а так же +получать журнал транзакций в виде дерева Меркля. + +Как было сказано выше, hbs2-git использует механизм \term{reflog}{рефлога} или же просто +\term{reflog}{ссылки} для своей работы. Рефлог представляет собой некий уникальный идентификатор, +ассоциированный с публичным ключом шифрования (фактически: публичный ключ и есть), а обладание +приватным ключом от этого публичного ключа является доказательством права записи в эту ссылку. + +Ссылки могут быть разных типов, рефлог --- это условное название ссылки определенного, конкретного +вида, который реализован, как примитив в HBS2 (hbs2-peer будет точнее). + +Рефлог есть список транзакций, упорядоченный по хэшам их контента, представленный в виде хэш-ссылки +на \term{ann-merkle-tree}{дерево Меркля} журнала (лога) транзакций. + +Предполагается, что у рефлога есть один писатель --- владелец приватного ключа. + +Никакого консенсуса с рефлогом не ассоциировано, однако, он может возникать на уровне данных +транзакций и стейта. + +Например, в случае git есть порядок объектов, определяемый DAG ссылки (в смысле git. т.е в основном +это бранч). Имея порядок объектов, можно вывести и порядок операций, т.к. в логе операции +упорядочены последовательно, а сами логи имеют ссылку на коммиты, для которых тоже есть порядок. + +Таким образом, даже имея несколько писателей в одну ссылку, которые, вроде бы, могут <<портить>> +ссылки git друг другу, мы можем добавить в стейт идентификатор пользователя в ключ для таблицы +ссылок, и, таким образом, каждый будет видеть только <<своё>> значение ссылки, кроме того, можно +генерировать уникальные ссылки из объединения ключа пользователя и названия бранча. + +На текущий момент это не реализовано (но возможно). + +Содержимое транзакций может быть произвольным, но есть специальные виды транзакций, +которые поддерживаются hbs2-peer и содержат ссылку на какое-то \term{ann-merkle-tree}{дерево +Меркля}. Смысл поддержки заключается в том, что если hbs2-peer получает транзакцию такого +типа, он заодно автоматически скачивает и дерево, на которое она ссылается. + +Транзакции содержат числовое поле, которое призвано их упорядочивать, однако оно может +использоваться или не использоваться, по усмотрению. Внутри списка они упорядочиваются по хэшам, а +приложение может их упорядочивать, как ему хочется или даже несколькими способами сразу. + +В нашем конкретном случае, каждая транзакция ссылается на \term{log}{лог} объектов git, +соответственно, лог содержит коммиты, каждый коммит может быть упорядочен относительно прочих, +значит, и логи могут быть упорядочены, например, по максимальной высоте (глубине?) коммита, +который в нём содержится. + +Теоретически, тут могут быть краевые случаи, но поскольку мы для создания этого лога +используем функциональность git, мы считаем, что содержимое лога разумно. + +Можно сказать, что порядок транзакций задаётся порядком логов, на которые они ссылаются, +который определяется порядком следования коммитов в git. + +При своей работе hbs2-git формирует логи git в виде файлов, содержащих заголовки секций +и секции, в которых содержатся объекты разного типа, и помещает их в HBS2 при помощи API hbs2-peer. + +Далее, полученные хэш-ссылки на деревья помещаются в транзакции, после чего транзакции подписываются +и публикуются. + +И обратно, что бы получить новые объекты при $git~fetch$ hbs2-git получает текущее значение +хэш-ссылки рефлога, скачивает данные рефлога, получает список транзакций, обрабатывает те, которые +до сих пор не обработаны, получает логи, сканирует логи и импортирует объекты в репозиторий git +и обновляет стейт. + +\section{Компоненты} + + +\begin{figure}[h!] +\centering +\begin{tikzpicture}[ every label/.style={font=\scriptsize}, + every node/.style={font=\scriptsize}, + handle/.style={ draw=black + , circle + , inner sep=2pt + }, + box/.style={ draw=black + , rounded corners, + , anchor=base + , font=\scriptsize + , minimum height=1.5cm + , text width=1.5cm + , align=center + }, + db/.style={ cylinder + , draw + , fill=gray!10 + , minimum height=1cm + , minimum width=1.5cm + , shape border rotate=90 + , aspect=0.5 + } + ] + + \node[box,minimum height=3cm] (peer) {hbs2-peer}; + + \node[ box + , minimum height=1cm + , text width=6em + , left=5cm of peer.north west + , anchor = north east + ] (git-remote-hbs2) {git-remote-hbs2}; + + \node[ box + , minimum height=1cm + , text width=6em + , below=1cm of git-remote-hbs2.south east, anchor = north east + ] (git-hbs2) {git-hbs2}; + + \node[ rectangle + , draw + , dashed + , above = 2mm of git-remote-hbs2.north west + , xshift = -2mm + , text width=2.8cm + , minimum height=3.6cm + , anchor=north west] (tools) {}; + + \node[box, minimum height=1cm, below=2cm of git-hbs2.south, anchor=north] (git) {git}; + + \node[db,below=1.6cm of git.north,anchor=north] (repo) {git repo}; + + \draw[->] (git.south) -- ($(repo.north) - (0,+2mm)$) ; + + \draw[->] (git.north) -- ($(tools.south west)!(git.north)!(tools.south east)$) + node[midway,right] {CLI/PIPE}; + + \node[ db + , left=1cm of git-remote-hbs2.north west, anchor=north east + , yshift=-1cm + ] (state) {State}; + + \draw[->] (git-remote-hbs2.west) -| ($(state.north) - (0,+2mm)$) ; + \draw[->] (git-hbs2.west) -| (state.south); + + \node[handle,left=3cm of peer.130] (catAPI) {}; + \node[handle,below=5mm of catAPI] (putAPI) {}; + \node[handle,below=5mm of putAPI] (refLogGetAPI) {}; + \node[handle,below=5mm of refLogGetAPI] (reflogSendRaw) {}; + + + \draw[->] (catAPI) -- ($(peer.north west)!(catAPI)!(peer.south west)$) node[above,midway] {HTTP: Cat}; + + \draw[->] (putAPI) -- ($(peer.north west)!(putAPI)!(peer.south west)$) node[above,midway] {HTTP: Put}; + + \draw[->] (refLogGetAPI) -- ($(peer.north west)!(refLogGetAPI)!(peer.south west)$) + node[above, midway] {HTTP: RefLogGet}; + + \draw[->] (reflogSendRaw) -- ($(peer.north west)!(reflogSendRaw)!(peer.south west)$) + node[above, midway] {CLI: RefLogSendRaw}; + + \draw[dashed] (catAPI) -- (putAPI) -- (refLogGetAPI) -- (reflogSendRaw) + node[circle,midway,yshift=0.7cm,inner sep=2pt] (m1) {}; + + \draw[->] (git-remote-hbs2.east) -- (m1); + + \draw[->] (git-hbs2.east) -- (m1); + + \node[ db + , below=1cm of peer.south + ] (store) {Store}; + + \draw[->] (peer.south) -- ($(store.north) - (0,+2mm)$) ; + +\end{tikzpicture} +\end{figure} + +\subsection*{git-remote-hbs2} + +Исполняемый файл, git-remote-helper, хэлпер git для протокола hbs2:// + +\subsection*{git-hbs2} + +Исполняемый файл, различные функции для работы с hbs2-git, например, +export для первоначальной инициализации \term{reflog}{рефлога}, или +scan для перестройки \term{state}{стейта}. + +\subsection*{git} + +Процесс git + +\subsection*{hbs2-peer} + +Процесс hbs2-peer + +\subsection*{Store} + +Хранилище объектов HBS2 (меркл-деревья, блоки, ссылки, ...) + +\subsection*{State} + +Вычисляемый \term{state}{стейт} для \term{reflog}{рефлога} репозитория. + +\section{Отсортированный по времени/высоте сегментированный лог} + +\begin{figure}[h!] +\centering + \begin{tikzpicture}[every node/.append style={font=\scriptsize}] + + \node[ rectangle split + , rectangle split parts=3 + , draw + , font=\scriptsize + , text width=3cm + , label={above:Reflog} + ] (reflog) + { + Transaction~N + \nodepart{two}... + \nodepart{three}Transaction~1 + }; + + + \node[ draw + , right = 2cm of reflog.north east, anchor=north west + , rectangle split, rectangle split horizontal, rectangle split parts=3 + , label={below:PUSH log} + ] (pushlog) + { \nodepart{one}$S_1$ + \nodepart{two}... + \nodepart{three}$S_n$ + }; + + \draw[-latex] (reflog.12) -- (pushlog) node[midway,above] {merkle~tree}; + +\end{tikzpicture} +\end{figure} + +Данный формат использует механизм \term{reflog}{reflog} hbs2, который является Merkle-деревом +списка транзакций. Каждая транзакция имеет стандартный вид, и содержит ссылку на +\term{log}{лог} (хэш \term{ann-merkle-tree}{аннотированного merkle-дерева} лога). + +Каждая секция $S_n$ \term{log}{лога} имеет вид: + +\begin{figure}[h!] +\centering + \begin{tikzpicture}[every node/.append style={font=\scriptsize}] + + \node[ rectangle split, rectangle split horizontal + , rectangle split parts=2 + , draw + , font=\scriptsize + , text width=3cm + , label={above:$S_n$} + ] (reflog) + { + HEAD(64) + \nodepart{two}DATA(LogEntrySize) + }; + + \node[ rectangle split + , rectangle split parts=3 + , draw + , font=\scriptsize + , text width=3cm + , label={above:HEAD} + , below=1cm of reflog.south west, anchor=north west + ] (head) + { + + \nodepart{one}LogEntryType + \nodepart{two}LogEntryHash + \nodepart{three}LogEntrySize : W32 + }; + + \draw[->] (reflog.186) -- ($(head.north west)!(reflog.186)!(head.north east)$); + +\end{tikzpicture} +\end{figure} + +Где HEAD это заголовок фиксированного размера 64~байта, DATA -- байтовая строка размера (LogEntrySize)~байт +произвольного формата, зависящего от LogEntryType. + +Формат HEAD: сериализованное в CBOR значение вида $(Type, GitHash?, Size)$, где GitHash -- +опционален (соответствует типу $Maybe GitHash$). + +Формат DATA: сжатая GZip произвольная строка, размером LogEntrySize \textbf{в сжатом виде}. + +Таким образом, данный формат может быть расширен добавлением новых конструкторов в тип +$LogEntryType$. + +Текущие основные типы секций: + +\begin{description} + \item[GitLogEntryCommit] объект git типа Commit + \item[GitLogEntryTree] объект git типа Tree + \item[GitLogEntryBlob] объект git типа Blob + \item[GitLogEntryHead] объект типа RepoHead, сериализованный в CBOR +\end{description} + +\textbf{RepoHead} + +\begin{lstlisting} +data RepoHead = + RepoHead + { _repoHEAD :: Maybe GitRef + , _repoHeads :: HashMap GitRef GitHash + } +\end{lstlisting} + + +\section{Операции} + +\subsection{EXPORT} + +\begin{enumerate} + \item Перечислить все объекты git в порядке следования коммитов, так, что после каждого коммита + идут его непосредственные зависимости (tree, blob) + \item Писать данные объекты в \term{log}{лог} + \item Писать лог в hbs2 как \term{ann-merkle-tree}{аннотированное дерево} + \item Порождать \term{reflog-tran}{транзакцию} для \term{reflog}{рефлога} со ссылкой на дерево из + предыдущего пункта +\end{enumerate} + +\subsection{PUSH} + +\begin{enumerate} + \item Перечислить все объекты git в порядке следования коммитов начиная с последнего известного + для данной ветки, аналогично EXPORT. + \item Далее аналогично 2--4 EXPORT +\end{enumerate} + +\subsection{FETCH} + +\begin{enumerate} + \item Получить \term{hashref}{значение HashRef} для \term{reflog}{рефлога} + \item Обойти все необработанные \term{transaction}{транзакции} \term{reflog}{рефлога} + \item Для каждой такой транзакции извлечь ссылку на \term{merkle-tree}{дерево} + \item Получить \term{log}{лог} для этого \term{merkle-tree}{дерева} + \item Обойти секции лога, импортировать объекты в репозиторий git, устанавливать + ссылки (в \term{state}{стейте}) + \item Обновлять \term{state}{стейт} +\end{enumerate} + +Поскольку одна операция $git~push$ устанавливает одну ссылку в заданное значение коммита, +у нас есть соответствие $refname \leftrightarrow commit$ для каждого лога. + +Поскольку для коммитов определен порядок, мы можем вычислить порядок логов в журнале транзакций +и порядок следования операций установления ссылки. +к +Таким образом, мы можем вычислить актуальные (последние) значения для каждой ссылки для +объединения логов. + +\subsection{DELETE} + +Удалять ссылку. Удаление ссылки производится путем установки её в значение +'0\{40\}' (хэш из сорока нулей) а не в пустую строку, как это происхоит в git, +что бы не рассматривать частный случай при разборе объектов типа RepoHead. + +В \term{state}{стейте} происходит фильтрация и ссылки, установленные в +данное значение --- не выводятся. + +\section{Стейт} + +Каждому \term{reflog}{рефлогу} соответствует \term{state}{стейт}, который вычисляется и +синхронизируется при операциях FETCH и PUSH. + +\term{state}{Стейт} представляет собой БД SQLite которая содержит необходимую для функционирования +hbs2-git информацию (объекты, отношения, логи, индексы). + +\term{state}{Стейт} может быть в любой момент пересоздан из рефлога. + +Операции из рефлога над \term{state}{стейтом} идемпотентны. + +Порядок существенных операций не играет роли, однако стейт содержит временные метки, +которые будут меняться в зависимости от времени. + +То есть, существенная часть стейта определяется только операциями из рефлога, причем, +порядок неважен, так как значимые сущности имеют порядок, определяемый репозиторием git +(топологический). + +\section{Замечания} + +\subsection*{Перечисление объектов репозитория} + +Перечисление объектов репозитория осуществляется при помощи команды + +\begin{verbatim} +git rev-list --objects --in-commit-order --reverse --date-order +\end{verbatim} + +и введение явной сортировки приводит к тому, что на больших репозиториях +данная команда сначала перечисляет все объекты, и потом их сортирует, что +происходит очень долго. + +Явно заданный порядок нужен для возможности повторного использования +частей логов для уменьшения оверхеда по данным, однако эффективность +данной меры пока не оценена, а замедление на больших репозиториях очень +значительное. + +Цель частичного повторного использования сегментов лога может быть +достигнута, если одному \term{PUSH}{PUSH} или \term{EXPORT}{EXPORT} будет +соответствовать не один лог, а некоторое количество логов, с ограничением +каждого или по размеру, или по количеству объектов. + +Это не создаёт никаких дополнительных расходов, следовательно, должно +быть реализовано. + +Тогда существует вероятность, что некоторые последовательности коммитов +будут повторно использоваться в системе, и кажется, это лучше, чем текущая +ситуация с попыткой переиспользования частей лога. + +Откуда берётся переиспользование вообще: так как лог сохраняется, как +\term{merkle}{дерево Меркля}, он разбивается на сегменты фиксированного +размера ($\approx{}256K$) и эти сегменты могут не скачиваться повторно, если они +уже есть, или же скачиваться у разных участников сети, если у них они +есть. + +\subsection*{Использование fast-export/fast-import} + +Хотя чтение и импорт объектов при помощи fast-export/fast-import +может быть быстрее, а сжатие такого лога полностью при помощи +gzip --- лучше, надо заметить следующее: + +\begin{enumerate} + \item Отсутствие хэшей в этом формате, + которые заменены короткими уникальными идентификаторами + \item Очень сильное замедление сжатия с ростом объема лога fast-export + \item Быстрое чтение объектов при помощи fast-export + \item Вероятно, более быстрый импорт объектов при помощи fast-import +\end{enumerate} + +\subsubsection*{Следствия} + +На больших логах будет работать очень медленно, так же медленно, как и сейчас. + +На маленьких логах всё работает достаточно быстро и сейчас, нет смысла утруждаться. + +Хэши нужны, что бы контролировать целостность логов, то есть придется парсить формат fast-import +и их считать, что еще больше замедлит. + +Если хэши объектов не считать, то есть опасность постинга по сути мусора в репозиторий git, т.к. +нет возможности контролировать и сопоставлять объекты. + +Текущий формат лога позволяет добавить секции, где будут логи формата fast-import. + +Это может привести к некоторому ускорению, если у нас не будет огромных логов, а логи будут нарезаны +по некоему разумному размеру. + +Выглядит так, что можно попробовать сделать это в дальнейшем, когда другие способы оптимизации +скорости будут исчерпаны. + +\end{document} + + diff --git a/docs/papers/hbs2-git-problem.tex b/docs/papers/hbs2-git-problem.tex new file mode 100644 index 00000000..9a41f6e1 --- /dev/null +++ b/docs/papers/hbs2-git-problem.tex @@ -0,0 +1,627 @@ +\documentclass[11pt,a4paper]{article} + +\usepackage{polyglossia} +\usepackage{xltxtra} +\usepackage[margin=2cm,a4paper]{geometry}% http://ctan.org/pkg/geometry +\usepackage{pdfpages} +\usepackage{graphicx} +\usepackage[ddmmyyyy]{datetime} +\usepackage{booktabs} +\usepackage{enumitem} +\usepackage{amssymb} +\usepackage{amsmath} +\usepackage{bm} +\usepackage[nomessages]{fp} +\usepackage{caption} +\usepackage{url} +\usepackage{indentfirst} +\usepackage[parfill]{parskip} +\usepackage[ colorlinks=true + , linkcolor=black + , anchorcolor=black + , citecolor=black + , filecolor=black + , menucolor=black + , runcolor=black + , urlcolor=blue]{hyperref} +\usepackage{tikz} +\usetikzlibrary{arrows,snakes,shapes,backgrounds,positioning,calc} +\usepackage{marvosym} +\usepackage{pifont} +\usepackage{fontspec} +\usepackage{fontawesome5} + +\setmainlanguage{russian} +\defaultfontfeatures{Ligatures=TeX,Mapping=tex-text} +\setmainfont{Liberation Serif} +\newfontfamily\cyrillicfont{Liberation Serif}[Script=Cyrillic] + +\setlist{noitemsep} +\setlength{\intextsep}{2cm} + +\renewcommand{\dateseparator}{.} +\renewcommand*\contentsname{Содержание} + +\graphicspath{ {img/}} + +\title{Проблема репозитория HBS2 GIT} + +\begin{document} + +\maketitle + +\section{Определения} + +\begin{description}[itemsep=10pt] + + \item[Объект] Любой объект, сохраняемый и передаваемый в системе. Файл, + структура данных и т.п. + + \item[Блок] Адресуемые (имеющие криптографический хэш) данные. Данные это последовательность байт. + Может быть любого размера, типичный размер: не более 256K. Зашифрованный блок может + быть больше, так как при шифровании в него добавятся данные алгоритма шифрования. + Блок может быть и меньше 256K, допустим блок это маленький объект. Тогда размер блока + будет равен размеру объекта. + \par \textbf{Note:} при шифровании данные можно предварительно сжимать. + + + \item[Чанк] Нумерованая часть \textit{блока}. Для каждого блока известного размера можно построить + единственное разбиение на чанки заданного размера. Размер чанка выбирается таким + образом, что бы его можно было поместить в UDP пакет безопасного размера. + Безопасного это такого, что можно не заботиться о фрагментации. Считается безопасным + размер UDP пакета 508 байт, на практике MTU всегда 1500 и либо фрагментацией + занимается сетевой стек и делает это хорошо, либо MTU других размеров уже не + встречаются, в любом случае практических проблем с размером чанка = 1400 не + встретилось. В системе размер чанка принят за 1200 --- 1400 байт. Чанк используется + в протоколе передачи блоков: так как по UDP мы не можем запросить блок целиком, мы + запрашиваем его по частям, каждая такая часть и есть чанк. В протоколе существует + возможность запрашивать не каждый чанк одельно, а последовательностями, именуемыми + burst. + + \item[BlockSize] Размер блока. Может быть любой, не должен быть слишком + маленьким, но и слишком большим. Типично в районе 256K. + + \item[ChunkSize] Максимальный рамер чанка. Должен иметь размер, не превышающий + максимального безопасного размера для UDP (1200 --- 1400 + байт) (с учетом заголовка пакета). + + \item[Burst] Последовательность чанков в протоколе. Клиент запрашивает не по каждому чанку + отдельно, а сериями по N чанков, начиная с k-го. Каждая такая последовательность + и есть burst. + + \item[Merkle~Tree] Любой крупный объект, данные или последовательность объектов + разбивается на блоки при помощи построения его Merkle дерева + (в нашей интерпретации). Дерево имеет два параметра: + количество элементов в каждом узле, и размер (в каком-то виде) каждого + элемента. Построение дерева происходит в два этапа: сначала мы производим + разбиение, учитывая эти два параметра, затем --- обходим получившееся дерево, + сериализуем каждый узел (пишем блоки в \textit{хранилище}), и из полученных + при сериализации хэшей строим уже дерево Меркля (Merkle~Tree). + Дерево может состоять из узлов типа (Merkle~Tree) либо Leaf + - указание на блок (данных). + + \item[Annotated~Merkle~Tree] Merkle~Tree с аннотацией в виде либо короткой + строки, либо ссылкой на блок с метаинформацией. + + \item[Peer] Пир. Участник сети, авторизованный своим криптографическим ключом + подписи, и поддерживающий протоколы системы. + + \item[RTT] Round trip time, время на посылку запроса и получение + ответа (в сети). Можно рассматривать на уровне прикладного протокола HBS2, + можно на уровне транспортного (TCP). Обычно имеется ввиду уровень протокола + HBS2. + + \item[Reflog] Механизм реализации изменяемой ссылки. Каждая ссылка + определяется неким публичным ключом. Для каждой ссылки можно опубликовать + транзакцию, короткий (ChunkSize) блок данных, который может либо содержать + произвольные данные, либо \textit{ссылку} на блок или Merkle~Tree. В случае, + если внутри ссылка -- то данные ссылки будут скачаны пиром автоматически + рекурсивно. Все транзакции Reflog упорядочиваются по их хэшам в виде списка, + который сохраняется в виде Merkle~Tree. Таким образом, значение ссылки типа + Reflog это хэш Merkle~Tree упорядоченного по хэшам списка транзакций. + +\end{description} + +\section{Проблема} + +Медленная передача большого количества маленьких объектов (блоков). +Приводит к очень медленному первоначальному скачиванию репозитория. +Обновления затем происходят с приемлемой скоростью. + +Связано с тем, что в текущем протоколе для каждого передаваемого адресуемого +блока нам нужно: + +\begin{enumerate} + \item Запросить размер (выяснить его наличие) + \item Запросить его чанки +\end{enumerate} + +Таким образом, скачивание одного маленького объекта занимает минимум: +\mbox{$ 2 \times RTT + C + T$}, где C - время обработки запроса на обеих +сторонах, T - время передачи самих данных. + +На практике это означает, что например при типичном $ RTT = 50ms $ мы доcтигаем +скорости 6 блоков (чанков) в секунду, что даём нам не более 9Kb/s, реально в +районе 6 --- 8. Каковая скорость и наблюдается экспериментально. + + +Текущее устройство репозитория hbs2-git: + +\begin{figure}[h!] +\centering + \begin{tikzpicture}[every node/.append style={font=\scriptsize}] + + \node[ rectangle split + , rectangle split parts=3 + , draw + , font=\scriptsize + , text width=3cm + , label={above:Reflog} + ] (reflog) + { + Transaction~N + \nodepart{two}... + \nodepart{three}Transaction~1 + }; + + + + \node[ rectangle split + , rectangle split parts=4 + , draw + , font=\scriptsize + , text width=3cm + , right=2cm of reflog.north east, anchor=north west + , label={above:Object~list} + ] (objlist) + { + \nodepart{one}HEAD~Object + \nodepart{two}Git Object~1 + \nodepart{three}... + \nodepart{four}Git object~N + }; + + \node[draw,rectangle,below=2cm of objlist,xshift=-3cm,minimum + height=1cm,label={below:Git Object}] + (merkle) {Annotated~Merkle~Tree}; + + \draw[-latex] (reflog.15) -- (objlist.155); + \draw[-latex] (objlist.205) to [bend right,looseness=1] (merkle.north); + + +\end{tikzpicture} +\end{figure} + + +\begin{description}[itemsep=10pt] + \item[Reflog] Это Merkle~Tree списка \textit{транзакций}. + \item[Транзакция] Это небольшой объект (размера не больше ChunkSize), + произвольного содержания, в случае HBS2 Git -- со ссылкой на Merkle~Tree + списка объектов. + \item[Object list] Список всех достижимых объектов репозитория (транзитивное + замыкание всех объектов для коммита) + HEAD (список ссылок в смысле git и их значений) + \item[Git Object] Сохраненный в виде Annotated~Merkle~Tree объект git. В + аннотации указан тип объекта (commit, blob, tree) +\end{description} + +Данное устройство было выбрано как + +\begin{enumerate} + \item Наиболее простое и очевидное + \item Минимизирующее оверхед по данным на уровне git объектов -- т.е уже + имеющиеся git объекты никогда не будут скачиваться повторно + \item Любая транзакция описывает полный, консистентный репозиторий, т.е можно + не иметь полного набора транзакций, но иметь, тем не менее, полный + репозиторий. + \item Каждый когда-либо созданный git object доступен в сети пиров по хэшу его + Merkle~Tree, что казалось довольно удобно (но практически бесполезно) +\end{enumerate} + +Несмотря на стремление к минимизации оверхеда по данным, данное устройство его, +тем не менее, создаёт в другом месте: + +Каждое Merkle~Tree это минимум один дополнительный блок -- т.е блок на +Merkle~Tree + блок на блок данных. + +Как можно видеть, данное устройство располагает к образованию большого +количества маленьких объектов: сами объекты git как правило маленькие, +транзакции = маленькие объекты (ChunkSize). + +Большое число: 10---20 тысяч для репозитория размером порядка 600 коммитов. + +Что, если взять скорость 5 блоков (чанков) в секунду (из оценки выше), приводит +к нас с показателю 4000 секунд на 20'000 блоков, что примерно соответствует +наблюдаемой картине (в реальности чуть лучше). + +Несмотря на то, что последующие скачивания будут выполняться быстро (объекты не +будут выкачиваться повторно, будут скачаны только недостающие объекты, их +немного), первоначальное развертывание репозитория происходит неприемлемо +медленно. + +Это и есть проблема. + +\section{Возможные решения} + +Что мы в принципе хотим добиться: + +\begin{enumerate} + \item Быстрое скачивание всего репозитория; + \item Минимизировать оверхед по данным, т.е что бы одни и те же объекты + (разбитые на блоки), по возможности, скачивались один раз. +\end{enumerate} + +\subsection{Большой лог} + +Основная идея --- не порождать большое число маленьких объектов, как в текущем +дизайне, вместо этого ввести \textit{лог}, куда будут упорядоченно +писаться объекты git, каждый объект только один раз. + +Такой лог представляет собой просто большой файл, который может передаваться +обычными механизмами с максимально высокой скоростью ( десятки Mb/s ). + +Данное решение имеет недостатки: + +\begin{itemize} + \item[-] Более нет соответствия $ git object \leftrightarrow merkle tree $ + + \item[-] При отсутствии выравнивания, логи разных форков репозиториев + не сойдутся никогда, следовательно, всегда будет перевыкачиваться + различающаяся часть и эта часть будет расти со временем + + \item[-] При наличии <<крупного>> (256K) выравнивания оверхед по данным возрастает + на порядки ( ~ 3Gb для числа объектов $ \approx 12000$ ) + + \item[-] При наличии <<мелкого>> выравнивания оверхед всё равно + существенный ( $ \approx 50\% $ для блока размером 1K ), + но растёт число мелких объектов и соответствующим падением скорости + передачи. +\end{itemize} + +\subsubsection{Большой лог всех объектов} + +В случае выровненной записи --- получаем описанные выше недостатки. + +В случае невыровненной записи --- получаем расхождение логов у разных писателей +(форков), соответствовать будет лишь начальная часть. + +Можно ввести специальную дисциплину работы с логом и мерж лога, тогда можно +будет их переупорядочивать у всех, и логи будут периодически сходиться. Высокая +сложность реализации и много неоднозначностей. + +Можно писать лог каждый раз при push, тогда для одинаковых git репозиториев +будут одинаковые логи. Очень медленно и время будет расти с ростом репозитория. + +\textbf{Плюсы:} + +простая реализация, быстрое первоначальное развертывание. + +\textbf{Минусы:} + +всё остальное. + +\subsubsection{Отсортированный по времени/высоте сегментированный лог} + +Как можно видеть, ситуация с большим логом объектов, даже отсортированных по +высоте/времени может приводить к перевыкачиванию значительной части лога в +ситуации, когда кто-то отредактировал историю так, что новые объекты появились в +начале лога, что допустимо в git. В случае больших репозиториев это приведёт к +скачиванию большого количества данных и хранению этих данных. Что бы реже +сталкиваться с подобной проблемой, будем строить стейт следующим образом: + +\begin{figure}[h!] +\centering + \begin{tikzpicture}[every node/.append style={font=\scriptsize}] + + \node[ rectangle split + , rectangle split parts=3 + , draw + , font=\scriptsize + , text width=3cm + , label={above:Reflog} + ] (reflog) + { + Transaction~N + \nodepart{two}... + \nodepart{three}Transaction~1 + }; + + + \node[ draw + , right = 2cm of reflog.north east, anchor=north west + , rectangle split, rectangle split horizontal, rectangle split parts=4 + , label={below:PUSH log} + ] (pushlog) + { \nodepart{one}$S_1$ + \nodepart{two}... + \nodepart{three}$S_n$ + \nodepart{four}HEAD + }; + + \draw[-latex] (reflog.12) -- (pushlog) node[midway,above] {merkle~tree}; + +\end{tikzpicture} +\end{figure} + + + +\begin{itemize} + \item[-] Каждая транзация $T_x$ содержит + отсортированные по времени (высоте) и по хэшу объекты репозитория + \item[-] $S(R_x) = \bigcup$ объектов из всех транзакций Reflog + \item[-] Берем объекты, отсутствующие в $S(R_x)$, сортируем по времени/высоте и затем хэшам + и пишем в лог в сжатом виде можно сжать весь лог) + \item[-] Объект HEAD пишем в тот же лог, начало или конец (TBD) + \item[-] Публикуем транзацию $T_y$, которая содержит ссылку на Merkle~Tree лога из предыдущего + пункта +\end{itemize} + +\textbf{Следствия:} + +\begin{itemize} + \item[-] Стейт $S(R_x)$ каждой ссылки $R_x$ обновляется инкрементально + \item[-] Каждое обновление (транзакция $T_x$) соответствует push в соответствующий + \textit{git~remote} + \item[-] Каждое обновление содержит объекты, отсутствующие в $S(R_x)$, отсортированные + детерменированным образом, зависимости только состояния репозитория git + \item[-] Каждый сегмент лога, кроме первого, как правило, сравнительно небольшой -- содержит + только новые объекты, созданные пользователем (commit, tree, blob) + \item[-] В рамках одной ссылки логи перевыкачиваться не будут, как логи (содержимое + Merkle~Tree транзаций $T_x$ создаются детерменированным образом в завимости только + содержимого репозитория git + \item[-] Частичные логи могут иногда совпадать, так что они не всегда будут дублироваться между + ссылками. Различные кейсы рассмотрим далее отдельно +\end{itemize} + +\textbf{Ситуация 1:} + +\begin{itemize} + \item[-] Алиса делает \textit{EXPORT} существующего репозитория в свою ссылку $R_a$ + \item[-] Боб делает \textit{git~clone} данного репозитория (ссылки $R_a$) + \item[-] Боб создаёт новую ссылку $R_b$ + \item[-] Боб делает \textit{EXPORT} репозитория в эту ссылку + и сообщает ссылку $R_b$ Алисе + \item[-] Боб делает изменения и делает \textit{git~push} в ссылку $R_b$ +\end{itemize} + +В этом случае: + + +\begin{enumerate} + \item Создаётся лог, содержащий объекты $S(R_a)$ --- все объекты репозитория, + в порядке создания/высоты и далее в порядке хэшей + \item Публикуется транзация $T_x$ со ссылкой на Merkle~Tree лога объектов + \item Боб принимает данную транзацию, объектов $S(R_a)$ --- данных объектов + у него еще нет, следовательно дублирования нет + \item Объекты $S(R_a)$ распаковываются в репозиторий git + \item Создаётся новая ссылка $R_b$. При \textit{EXPORT} создаётся + первоначальная транзакция, которая ровно такая же, как и $T_x$, + так как содержимое лога определяется только объектами репозитория git, + а они все из $S(R_a)$ + \item Боб делает свои изменения и делает \textit{git~push} + \item Создается $T_{b1}$, содержащая объекты $S(R_{b1})$, отсутствующие в + $S(R_a)$ + \item Алиса получает $T_{b1}$, содержащая объекты $S(R_{b1})$ и импортирует + эти объекты в свой репозиторий git. +\end{enumerate} + +На шаге (5) мог не выполниться \textit{EXPORT}, так как его выполнение зависит +от пользователя. В этом случае на шаге (7) будет создана $T_{b1}$ содержащая все +объекты репозитория, включая те, что были созданы Бобом на шаге (6). В этом +случае, какое-то количество объектов в зависимости от гранулярности разбиения +(BlockSize), попадут в те блоки, что уже есть у Алисы в $S(R_a)$. И чем больше +был размер лога $S(R_a)$, тем больше объектов Алиса не будет скачивать повторно, +так как порядок следования определяется только объектами в репозитории, Боб не +переписывал историю и его объекты будут следовать за объектами Алисы. + +Если же Боб переписал историю, что, в целом, возможно, то Алиса не будет +повторно выкачивать только часть лога до изменений Боба. + +Таким образом видно, что при создании ссылки $R_b$ нужно форсировать операцию +EXPORT. + +Как можно её форсировать, ведь Боб может и не создавать ссылку, или создавать +её в любой момент времени. + +Например, при операции PUSH нужно каким-то образом получить все объекты, +которые шли раньше изменений Боба и создать транзакцию $T_{b0}$ в которой +будут эти объекты. + +Как система должна понять, что этот \textit{git~push} --- не первоначальная +инициация репозитория, а апдейт? Например, так: при \textit{FETCH} +в случае отсутствия транзакций создаётся (и публикуется) первая транзакция. +Тогда в большей части случаев она будет соответствовать инициации репозитория, +и при последующем \textit{PUSH} или \textit{EXPORT} в создаваемую транзакцию +попадут только те объекты, которые создал владелец новой ссылки (Боб в нашем +случае). + + + +\subsubsection{Merkle~Tree+лог с переменным разбиением} + +\begin{figure}[h!] +\centering + \begin{tikzpicture}[every node/.append style={font=\scriptsize}] + + \node[ rectangle split + , rectangle split parts=3 + , draw + , font=\scriptsize + , text width=3cm + , label={above:Reflog} + ] (reflog) + { + Transaction~N + \nodepart{two}... + \nodepart{three}Transaction~1 + }; + + + \node[ rectangle split + , rectangle split parts=5 + , draw + , font=\scriptsize + , text width=3cm + , right=2cm of reflog.north east, anchor=north west + , label={above:Object~list} + ] (objlist) + { + \nodepart{one}HEAD~Object + \nodepart{two}SmallObjectLog + \nodepart{three}... + \nodepart{four}BigGitObject + \nodepart{five}... + }; + + + \node[draw,rectangle,below=1cm of objlist.north east,xshift=2cm,minimum + height=1cm,label={[xshift=1.2cm]above:Small~Object~Log}] + (smallmerkle) {Merkle~Tree}; + + \node[right=0.1cm of smallmerkle,text width=4.2cm,font=\scriptsize] + (smallmerklenote) {С переменным шагом разбиения:\\один объект=один лист}; + + \node[ rectangle split + , rectangle split parts=4 + , draw + , font=\scriptsize + , text width=3cm + , below=1cm of smallmerkle + , label={below:SmallObjectLog} + ] (objlog) + { + \nodepart{one}SmallObject~1 + \nodepart{two}... + \nodepart{three}SmallObject~N + \nodepart{four}... + }; + + \node[draw,rectangle,below=2cm of objlist,xshift=-3cm,minimum + height=1cm,label={below:Git Object}] + (merkle) {Annotated~Merkle~Tree}; + + \draw[-latex] (reflog.15) -- (objlist.155); + + \draw[-latex] (objlist.200) to [bend right,looseness=1] (merkle.north); + + \draw[-latex] (objlist.12) -| (smallmerkle.north); + + \draw[-latex] (smallmerkle.south) -- (objlog.north); + +\end{tikzpicture} +\end{figure} + + + +Несмотря на то, что сейчас дерево разбивается на блоки фиксированного размера, +необходимости в этом нет. Это означает, что мы можем генерировать Merkle~Tree +таким образом, что каждому маленькому объекту будет соответствовать один объект +(лист) Merkle~Tree (т.е они не будут разбиваться: мы сначала генерируем лог +<<маленьких>> объектов, затем разбиваем его, принимая во внимание размер каждой +секции (заголовок+объект), так что каждая секция --- ровно один лист (хэш) +Merkle~Tree. + +\textbf{Требование:} Каждый <<маленький>> объект должен быть достаточно +маленьким для того, что бы можно было его безопасно читать в память. + +<<Большие>> объекты передаются ровно так, как сейчас, то есть каждый отдельно. +<<Большие>> это, допустим, от 1Mb. + + +\textbf{Плюсы:} + +\begin{itemize} + \item[+] Выполняется требование отсутствия оверхеда по данным + \item[+] Нет множества <<мелких>> объектов: лог <<большой>>, + отдельные объекты тоже <<большие>>. +\end{itemize} + +\textbf{Минусы:} + +\begin{itemize} + \item[-] Передаваться будет дольше, чем <<большой>> лог + \item[-] Средняя сложность реализации + \item[-] <<Переменное разбиение>> $ => $ объекты git маленькие $ => $ много + маленьких объектов $ => $ \textbf{не работает} +\end{itemize} + +\subsection{Ускорение скачивания мелких объектов} + +Невредно сделать в любом случае, однако полезность данного механизма может +варьироваться, а сложность может быть велика. Мы рассматриваем в первую очередь +ограничения UDP, так как в настоящий момент по TCP ходят в точности такие же +протоколы, как и по UDP. Это может быть изменено, но потребуется поддержка +механизмов, которые будут динамически разрешать или запрещать протоколы в +зависимости от типов транспорта. Это возможно, сложность --- ниже средней. + +\subsubsection{Пакетные запросы} + +Поскольку мы можем передать по UDP 1200 --- 1400 байт в одной датаграмме, +мы можем запросить $ 1200 / 32 \approx 32 $ объекта за один раз. + +Но если речь идёт о UDP, то ответ, очевидно, не может быть получен в одной +датаграмме, значит, нужен какой-то механизм стриминга/сборки ответа из кусков, +и уже имеющийся механизм не подходит, так как ответ создаётся динамически и +отсутствует в хранилище. Таким образом, его надо или создавать в хранилище (и +увеличивать число данных, причём, мусора), либо как-то создавать временный +ответ и скачивать его текущими механизмами. + +Это возможно, но неизящно: + +\begin{enumerate} + \item Получить запрос + \item Сформировать ответ (записать данные на /tmp допустим) + \item Посчитать хэш ответа ( как блока(!) ) + \item Добавить хэш в специальную таблицу <<временные объекты>> + \item Сообщить хэш и размер запрашивающей стороне + \item Запрашивающая сторона получает блок обычным способом + \item При обработке запроса сервер смотрит, не является ли блок временным + объектом и читает его, а не хранилище +\end{enumerate} + +Кроме того, ускорение может получиться не столь значительным, так как +мы можем не знать все объекты заранее, и что бы их узнать, надо сначала +скачать другие объекты. + +Из наблюдаемых явлений видно, что в какой-то момент времени очередь запросов +становится весьма большой ( $ \approx 10K $ объектов ), следовательно, можно +запрашивать объекты пачками, следовательно, будет иметь место ускорение в $ +\approx 32 $ раза, что приведёт к скорости отдачи мелких объектов в районе +160Kb/s. Что не бог весть что, на самом деле. Текущие скорости отдачи +"нормальных" объектов составляют около ширины канала, десятки мегабайт в +секунду. + +\subsubsection{Стриминг Merkle~Tree} + +Специальная команда, в ответ на которую передаются все блоки Merkle~Tree, не +дожидаясь запросов. + +Проблематичная реализация на UDP, в виду возможного реордеринга и потери +пакетов, а имеющийся текущий механизм, устойчивый к реордерингу и потерям, +неприменим. + +Вернее, он применим, если мы создадим механизм <<временного>> хранилища -- +аналогичного обычному, но существующему лишь некоторое время. Тогда +любые промежуточные объекты могут быть созданы, существовать в +течение сессии или некоторого времени и впоследствии удалены. + +Можно и не создавать временное хранилище, а помечать объекты, как временные +и рекурсивно удалять через некоторое время. + +Можно создавать временный объект <<транзитивного замыкания>> для дерева, +сообщать его хэш, и давать клиенту скачивать его обычным образом. + +Можно видеть, что любые варианты пакетного скачивания объектов ведут к +работе <<сервера>> и расходованию его ресурсов, т.е при незначительном +усилии со строны клиента (один запрос) сервер вынужден сканировать десятки +тысяч объектов и создавать временные объекты потенциально любых размеров, +что открывает путь для намеренных и ненамеренных атак на пира. + +Если у нас есть надёжный транспортный протокол (TCP) то можно стримить данные, +не создавая временных структур, тогда затраты локальных ресурсов будут ниже, +но тем ме менее, возможность DoS остаётся: одна команда со стороны <<клиента>> +приводит к несопоставимо большой вычислительной работе <<сервера>> и передачи +большого объема данных (много больше исходного запроса). + +\end{document} + + diff --git a/docs/todo/delete-refs-properly.txt b/docs/todo/delete-refs-properly.txt new file mode 100644 index 00000000..082c8bc0 --- /dev/null +++ b/docs/todo/delete-refs-properly.txt @@ -0,0 +1,11 @@ + +FIXME: delete-refs-properly + Сейчас мы помечаем удалённые бранчи 0000000000000000000000000000000000000000 + и если такой бранч был удалён однажды, то больше его мы не увидим. Тогда как + реально они могут быть удалены, созданы, опять удалены. + Для каждой операции в logrefval мы пишем хэш лога, в котором она определена. + Так же у нас есть logobject в котором есть связь объектов и логов, и коммиты, + для которых мы можем построить высоту (топологически). + Таким образом, у лога можно определить "высоту", а значит, и для всех операций + в логе можно определить высоту. Таким образом, у последовательности изменений + значения ссылки возникает порядок. diff --git a/docs/todo/hbs2-git-new-repo.txt b/docs/todo/hbs2-git-new-repo.txt new file mode 100644 index 00000000..2a4e9ab7 --- /dev/null +++ b/docs/todo/hbs2-git-new-repo.txt @@ -0,0 +1,33 @@ +FIXME: filter-existed-objects-from-log + Сейчас если коммит ссылается на уже существующие в стейте + объекты, они всё попадут в лог. Нужно отфильтровывать их + оттуда + +TODO: faster-git-clone + Медленное клонирование. + Можно попытаться оптимизировать, можно + попытаться сделать через fast-import -- т.е + дампить объекты в формате fast-import-stream, + должно быть намного быстрее + +FIXME: faster-export + Сейчас обходятся вообще все коммиты в git rev-list, + а можно только те, которых нет в стейте - т.е начиная + с какого-то. Ну например, для данной ссылке брать коммит + с максимальной высотой (глубиной) и rev-list делать до него. + Пример: + ``` + [dmz@minipig:~/w/hbs2]$ git rev-list --objects 640c447e9dca6a32ecb80f85f2d3ab9ad45dc91e.. + 0e887a87e30005a8ebdb43aa5bf0ed78383cf52a + 5509c970621a75c9f82b4d2743fd211c1165e61f + 7f0c4c0659367ae10bd3eb84b7bc26f09dd26282 hbs2-git + 6d38123f72101aa6a66c35ced40f5dd156a722c4 hbs2-git/lib + 1aadc3441288d6d4f9fddb00342dd296242ded1a hbs2-git/lib/HBS2Git + bb270a54495fdf44e831b53c63b5814a44d354af hbs2-git/lib/HBS2Git/State.hs + ``` + +TODO: git-tags-support + Поддержать теги, в т.ч. подписанные. + Неподписанные возможно и так будут работать. + + diff --git a/docs/todo/hbs2-slow-import-export.txt b/docs/todo/hbs2-slow-import-export.txt new file mode 100644 index 00000000..af69a97a --- /dev/null +++ b/docs/todo/hbs2-slow-import-export.txt @@ -0,0 +1,12 @@ +FIXME: hbs2-slow-import-export-1 + Сейчас полностью перечитывается весь лог при вызове importRefLogNew, + если хотя бы одна из ссылок отсутствует. Например, всё будет пересканировано + при добавлении новой ссылки (бранча). + + Нужно: перечитывать только отсутствующие ссылки. + + +TODO: use-fast-import-for-import + Можно генерировать формат git fast-import при импорте, тогда + ускорится импорт раз в десять. + diff --git a/hbs2-git/git-hbs2/GitRemoteMain.hs b/hbs2-git/git-hbs2/GitRemoteMain.hs index 957e676c..8940127f 100644 --- a/hbs2-git/git-hbs2/GitRemoteMain.hs +++ b/hbs2-git/git-hbs2/GitRemoteMain.hs @@ -1,46 +1,44 @@ module Main where -import HBS2.Prelude +import HBS2.Prelude.Plated import HBS2.Data.Types.Refs import HBS2.Base58 import HBS2.OrDie import HBS2.Git.Types -import HBS2.Git.Local.CLI -import HBS2.Clock import HBS2.System.Logger.Simple -import HBS2Git.Types() -import HBS2Git.Types qualified as G +import HBS2Git.Types(traceTime) import HBS2Git.App import HBS2Git.State -import HBS2Git.Update -import HBS2Git.Export -import HBS2Git.Config as Config +import HBS2Git.Import +import HBS2.Git.Local.CLI + +import HBS2Git.Export (runExport) import GitRemoteTypes import GitRemotePush -import Control.Concurrent.Async import Control.Concurrent.STM import Control.Monad.Reader -import Data.Attoparsec.Text +import Data.Attoparsec.Text hiding (try) import Data.Attoparsec.Text qualified as Atto import Data.ByteString.Char8 qualified as BS import Data.ByteString.Lazy.Char8 qualified as LBS import Data.Foldable import Data.Functor -import Data.HashSet qualified as HashSet +import Data.Function ((&)) +import Data.HashMap.Strict qualified as HashMap import Data.Maybe import Data.Text qualified as Text +import Data.List qualified as List import System.Environment -import System.Exit qualified as Exit import System.Posix.Signals -import System.ProgressBar import Text.InterpolatedString.Perl6 (qc) import UnliftIO.IO as UIO -import Control.Monad.Trans.Maybe import Control.Monad.Catch +import Control.Monad.Trans.Resource + send :: MonadIO m => BS.ByteString -> m () send = liftIO . BS.hPutStr stdout @@ -73,14 +71,16 @@ parseRepoURL url' = either (const Nothing) Just (parseOnly p url) capabilities :: BS.ByteString capabilities = BS.unlines ["push","fetch"] -readHeadDef :: HasCatAPI m => DBEnv -> m LBS.ByteString -readHeadDef db = - withDB db stateGetHead >>= - \r' -> maybe1 r' (pure "\n") \r -> do - readObject r <&> fromMaybe "\n" + +guessHead :: GitRef -> Integer +guessHead = \case + "refs/heads/master" -> 0 + "refs/heads/main" -> 0 + _ -> 1 loop :: forall m . ( MonadIO m , MonadCatch m + , MonadUnliftIO m , HasProgress (RunWithConfig (GitRemoteApp m)) ) => [String] -> GitRemoteApp m () loop args = do @@ -104,8 +104,7 @@ loop args = do db <- dbEnv dbPath - --FIXME: git-fetch-second-time - -- Разобраться, почему git fetch срабатывает со второго раза + -- TODO: hbs2-peer-fetch-reference-and-wait checkRef <- readRef ref <&> isJust @@ -114,30 +113,27 @@ loop args = do warn "trying to init reference --- may be it's ours" liftIO $ runApp NoLog (runExport Nothing ref) - hdRefOld <- readHeadDef db + refs <- withDB db stateGetActualRefs - updateLocalState ref + let heads = [ h | h@GitHash{} <- universeBi refs ] - hd <- readHeadDef db + missed <- try (mapM (gitReadObject Nothing) heads) <&> either (\(_::SomeException) -> True) (const False) - hashes <- withDB db stateGetAllObjects + let force = missed || List.null heads - -- FIXME: asap-get-all-existing-objects-or-all-if-clone - -- если clone - доставать всё - -- если fetch - брать список объектов и импортировать - -- только те, которых нет в репо + debug $ "THIS MIGHT BE CLONE!" <+> pretty force - existed <- gitListAllObjects <&> HashSet.fromList + -- sync state first + traceTime "TIMING: importRefLogNew" $ importRefLogNew force ref - jobz <- liftIO newTQueueIO + refsNew <- withDB db stateGetActualRefs + let possibleHead = listToMaybe $ List.take 1 $ List.sortOn guessHead (fmap fst refsNew) - jobNumT <- liftIO $ newTVarIO 0 - liftIO $ atomically $ for_ hashes $ \o@(_,gh,_) -> do - unless (HashSet.member gh existed) do - modifyTVar' jobNumT succ - writeTQueue jobz o - - env <- ask + let hd = refsNew & LBS.pack . show + . pretty + . AsGitRefsFile + . RepoHead possibleHead + . HashMap.fromList batch <- liftIO $ newTVarIO False @@ -153,10 +149,6 @@ loop args = do let str = BS.unwords (BS.words s) let cmd = BS.words str - -- trace $ pretty (fmap BS.unpack cmd) - -- hPrint stderr $ show $ pretty (fmap BS.unpack cmd) - -- - isBatch <- liftIO $ readTVarIO batch case cmd of @@ -172,26 +164,6 @@ loop args = do next ["list"] -> do - - hl <- liftIO $ readTVarIO jobNumT - pb <- newProgressMonitor "storing git objects" hl - - -- FIXME: thread-num-hardcoded - liftIO $ replicateConcurrently_ 4 $ fix \nl -> do - atomically (tryReadTQueue jobz) >>= \case - Nothing -> pure () - Just (h,_,t) -> do - runRemoteM env do - -- FIXME: proper-error-handling - o <- readObject h `orDie` [qc|unable to fetch object {pretty t} {pretty h}|] - r <- gitStoreObject (GitObject t o) - - when (isNothing r) do - err $ "can't write object to git" <+> pretty h - - G.updateProgress pb 1 - nl - for_ (LBS.lines hd) (sendLn . LBS.toStrict) sendEol next @@ -211,16 +183,16 @@ loop args = do let bra = BS.split ':' rr let pu = fmap (fromString' . BS.unpack) bra liftIO $ atomically $ writeTVar batch True + -- debug $ "FUCKING PUSH" <> viaShow rr <+> pretty pu + -- shutUp pushed <- push ref pu case pushed of - Nothing -> hPrint stderr "fucked!" >> sendEol + Nothing -> hPrint stderr "oopsie!" >> sendEol >> shutUp Just re -> sendLn [qc|ok {pretty re}|] next other -> die $ show other - -- updateLocalState ref - where fromString' "" = Nothing fromString' x = Just $ fromString x diff --git a/hbs2-git/git-hbs2/GitRemotePush.hs b/hbs2-git/git-hbs2/GitRemotePush.hs index 4abed369..d016f776 100644 --- a/hbs2-git/git-hbs2/GitRemotePush.hs +++ b/hbs2-git/git-hbs2/GitRemotePush.hs @@ -6,8 +6,6 @@ import HBS2.Data.Types.Refs import HBS2.OrDie import HBS2.System.Logger.Simple import HBS2.Net.Auth.Credentials hiding (getCredentials) --- import HBS2.Merkle --- import HBS2.Hash import HBS2.Git.Local import HBS2.Git.Local.CLI @@ -16,22 +14,17 @@ import HBS2Git.Config as Config import HBS2Git.Types import HBS2Git.State import HBS2Git.App -import HBS2Git.Export (export) +import HBS2Git.Export (exportRefOnly,exportRefDeleted) +import HBS2Git.Import (importRefLogNew) import GitRemoteTypes -import Data.Maybe import Control.Monad.Reader import Data.Functor import Data.Set (Set) -import Data.Set qualified as Set -import Lens.Micro.Platform -import Data.HashMap.Strict qualified as HashMap import Text.InterpolatedString.Perl6 (qc) -import Data.ByteString qualified as BS -import Control.Concurrent.STM.TVar -import Control.Concurrent.STM import Control.Monad.Catch +import Control.Monad.Trans.Resource newtype RunWithConfig m a = WithConfig { fromWithConf :: ReaderT [Syntax C] m a } @@ -43,6 +36,8 @@ newtype RunWithConfig m a = , MonadTrans , MonadThrow , MonadCatch + -- , MonadMask + , MonadUnliftIO ) @@ -65,43 +60,37 @@ instance MonadIO m => HasRefCredentials (RunWithConfig (GitRemoteApp m)) where push :: forall m . ( MonadIO m , MonadCatch m , HasProgress (RunWithConfig (GitRemoteApp m)) + , MonadUnliftIO m ) => RepoRef -> [Maybe GitRef] -> GitRemoteApp m (Maybe GitRef) -push remote [bFrom , Just br] = do + +push remote what@[Just bFrom , Just br] = do (_, syn) <- Config.configInit dbPath <- makeDbPath remote db <- dbEnv dbPath runWithConfig syn do - - brCfg <- cfgValue @ConfBranch @(Set GitRef) <&> transformBi normalizeRef - + _ <- cfgValue @ConfBranch @(Set GitRef) <&> transformBi normalizeRef loadCredentials mempty + 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 + pure (Just br) - oldHead <- readHead db <&> fromMaybe mempty +push remote [Nothing, Just br] = do + (_, syn) <- Config.configInit - newHead <- case bFrom of - Just newBr -> do - gh <- gitGetHash (normalizeRef newBr) `orDie` [qc|can't read hash for ref {pretty newBr}|] - pure $ over repoHeads (HashMap.insert br gh) oldHead - - Nothing -> do - warn $ "about to delete branch" <+> pretty br <+> pretty "in" <+> pretty remote - - when ( br `Set.member` brCfg ) do - err $ "remove" <+> pretty br <+> "from config first" - exitFailure - - pure $ over repoHeads (HashMap.delete br) oldHead - - (root, hh) <- export remote newHead - - info $ "head:" <+> pretty hh - info $ "merkle:" <+> pretty root + runWithConfig syn do + _ <- cfgValue @ConfBranch @(Set GitRef) <&> transformBi normalizeRef + loadCredentials mempty + trace $ "deleting remote reference" <+> pretty br + exportRefDeleted () remote br + 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 f8871447..8be51961 100644 --- a/hbs2-git/git-hbs2/GitRemoteTypes.hs +++ b/hbs2-git/git-hbs2/GitRemoteTypes.hs @@ -14,6 +14,7 @@ import Data.HashMap.Strict qualified as HashMap import Data.HashMap.Strict (HashMap) import Control.Concurrent.STM import Control.Monad.Catch +import Control.Monad.Trans.Resource data RemoteEnv = RemoteEnv @@ -35,6 +36,7 @@ newtype GitRemoteApp m a = , MonadReader RemoteEnv , MonadThrow , MonadCatch + , MonadUnliftIO ) runRemoteM :: MonadIO m => RemoteEnv -> GitRemoteApp m a -> m a diff --git a/hbs2-git/git-hbs2/Main.hs b/hbs2-git/git-hbs2/Main.hs index a1d4a59e..47dbcf9a 100644 --- a/hbs2-git/git-hbs2/Main.hs +++ b/hbs2-git/git-hbs2/Main.hs @@ -23,6 +23,7 @@ main = join . customExecParser (prefs showHelpOnError) $ parser = hsubparser ( command "export" (info pExport (progDesc "export repo")) <> command "list-refs" (info pListRefs (progDesc "list refs")) <> command "show" (info pShow (progDesc "show various types of objects")) + <> command "tools" (info pTools (progDesc "misc tools")) ) pExport = do @@ -40,4 +41,19 @@ main = join . customExecParser (prefs showHelpOnError) $ pShow = do object <- optional $ argument (maybeReader showReader) (metavar "object" <> help " | config") + pure $ runApp NoLog (runShow object) + + pTools = hsubparser ( command "scan" (info pToolsScan (progDesc "scan reference")) + <> command "refs" (info pToolsGetRefs (progDesc "list references")) + + ) + + pToolsScan = do + ref <- strArgument (metavar "HASH-REF") + pure $ runApp WithLog (runToolsScan ref) + + pToolsGetRefs = do + ref <- strArgument (metavar "HASH-REF") + pure $ runApp WithLog (runToolsGetRefs ref) + diff --git a/hbs2-git/git-hbs2/RunShow.hs b/hbs2-git/git-hbs2/RunShow.hs index 84df6d75..ef8a553d 100644 --- a/hbs2-git/git-hbs2/RunShow.hs +++ b/hbs2-git/git-hbs2/RunShow.hs @@ -16,14 +16,16 @@ data ShowObject = ShowRef RepoRef | ShowConfig showRef :: MonadIO m => RepoRef -> App m () showRef h = do db <- makeDbPath h >>= dbEnv - withDB db do - hd <- stateGetHead - imported <- stateGetLastImported 10 - liftIO $ do - print $ "current state for" <+> pretty (AsBase58 h) - print $ "head:" <+> pretty hd - print $ pretty "last operations:" - for_ imported (\(t,h1,h2) -> print $ pretty t <+> pretty h1 <+> pretty h2) + -- FIXME: re-implement-showRef + pure () + -- withDB db do + -- hd <- stateGetHead + -- imported <- stateGetLastImported 10 + -- liftIO $ do + -- print $ "current state for" <+> pretty (AsBase58 h) + -- print $ "head:" <+> pretty hd + -- print $ pretty "last operations:" + -- for_ imported (\(t,h1,h2) -> print $ pretty t <+> pretty h1 <+> pretty h2) showRefs :: MonadIO m => App m () showRefs = do diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index 7d291ca8..7547a9bc 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/hbs2-git/hbs2-git.cabal @@ -63,27 +63,33 @@ common shared-properties , containers , cryptonite , directory + , exceptions + , filelock , filepath + , hashable + , http-conduit , interpolatedstring-perl6 , memory , microlens-platform , mtl , prettyprinter , prettyprinter-ansi-terminal + , resourcet , safe , serialise + , sqlite-simple + , stm , suckless-conf + , temporary , text + , time + , timeit , transformers , typed-process , uniplate - , hashable - , sqlite-simple - , stm + , unliftio + , unliftio-core , unordered-containers - , filelock - , http-conduit - , exceptions library import: shared-properties @@ -99,7 +105,7 @@ library HBS2Git.Config HBS2Git.App HBS2Git.State - HBS2Git.Update + HBS2Git.GitRepoLog -- other-modules: -- other-extensions: @@ -108,6 +114,7 @@ library , terminal-progress-bar , http-types , uuid + , zlib hs-source-dirs: lib default-language: Haskell2010 diff --git a/hbs2-git/lib/HBS2/Git/Local/CLI.hs b/hbs2-git/lib/HBS2/Git/Local/CLI.hs index 236764fd..929f932d 100644 --- a/hbs2-git/lib/HBS2/Git/Local/CLI.hs +++ b/hbs2-git/lib/HBS2/Git/Local/CLI.hs @@ -1,13 +1,17 @@ {-# Language AllowAmbiguousTypes #-} -module HBS2.Git.Local.CLI where +module HBS2.Git.Local.CLI + ( module HBS2.Git.Local.CLI + , getStdin + , stopProcess + ) where +import HBS2.Prelude.Plated import HBS2.Git.Types import HBS2.System.Logger.Simple import Control.Concurrent.Async import Control.Concurrent.STM -import Control.Monad.IO.Class import Control.Monad.Writer import Data.HashSet (HashSet) import Data.HashSet qualified as HashSet @@ -21,15 +25,13 @@ import Data.Function import Data.Maybe import Data.Set qualified as Set import Data.Set (Set) -import Data.String +import Data.List qualified as List import Data.Text.Encoding qualified as Text import Data.Text.Encoding (decodeLatin1) import Data.Text qualified as Text -import Data.Text (Text) -import Prettyprinter -import Safe import System.Process.Typed import Text.InterpolatedString.Perl6 (qc) +import System.IO -- FIXME: specify-git-dir @@ -68,9 +70,31 @@ gitGetDepsPure (GitObject Commit bs) = Set.fromList (recurse ls) gitGetDepsPure _ = mempty +gitCommitGetParentsPure :: LBS.ByteString -> [GitHash] +gitCommitGetParentsPure bs = foldMap seek pairs + where + pairs = take 2 . LBS.words <$> LBS.lines bs + seek = \case + ["parent", x] -> [fromString (LBS.unpack x)] + _ -> mempty +data GitParsedRef = GitCommitRef GitHash + | GitTreeRef GitHash + deriving stock (Data,Eq,Ord) +gitGetParsedCommit :: MonadIO m => GitObject -> m [GitParsedRef] +gitGetParsedCommit (GitObject Commit bs) = do + let ws = fmap LBS.words (LBS.lines bs) + oo <- forM ws $ \case + ["tree", s] -> pure [GitTreeRef (fromString (LBS.unpack s))] + ["commit", s] -> pure [GitCommitRef (fromString (LBS.unpack s))] + _ -> pure mempty + pure $ mconcat oo + +gitGetParsedCommit _ = pure mempty + +-- FIXME: use-fromStringMay gitGetObjectType :: MonadIO m => GitHash -> m (Maybe GitObjectType) gitGetObjectType hash = do (_, out, _) <- readProcess (shell [qc|git cat-file -t {pretty hash}|]) @@ -105,11 +129,13 @@ gitGetDependencies hash = do _ -> pure mempty +-- | calculates all dependencies of given list +-- of git objects gitGetAllDependencies :: MonadIO m - => Int - -> [ GitHash ] - -> ( GitHash -> IO [GitHash] ) - -> ( GitHash -> IO () ) + => Int -- ^ number of threads + -> [ GitHash ] -- ^ initial list of objects to calculate deps + -> ( GitHash -> IO [GitHash] ) -- ^ lookup function + -> ( GitHash -> IO () ) -- ^ progress update function -> m [(GitHash, GitHash)] gitGetAllDependencies n objects lookup progress = liftIO do @@ -182,6 +208,24 @@ gitGetTransitiveClosure cache exclude hash = do pure res +-- gitGetAllDepsByCommit :: GitHash -> IO [GitHash] +-- gitGetAllDepsByCommit h = do +-- -- FIXME: error-handling +-- (_, out, _) <- liftIO $ readProcess (shell [qc|git rev-list {pretty h}|]) +-- let ls = LBS.lines out & fmap ( fromString . LBS.unpack ) + +-- forM ls $ \l -> do +-- o <- liftIO $ gitReadObject (Just Commit) l +-- let tree = gitGetDepsPure (GitObject Commit o) +-- (_, out, _) <- liftIO $ readProcess (shell [qc|git rev-list {pretty h}|]) + +-- print tree + +-- -- mapM_ (print.pretty) ls +-- pure [] + -- deps <- mapM gitGetDependencies ls <&> mconcat + -- pure $ List.nub $ ls <> deps + -- FIXME: inject-git-working-dir-via-typeclass gitConfigGet :: MonadIO m => Text -> m (Maybe Text) @@ -277,8 +321,16 @@ gitStoreObject (GitObject t s) = do ExitSuccess -> pure $ Just (parseHashLazy out) ExitFailure{} -> pure Nothing +gitCheckObject :: MonadIO m => GitHash -> m Bool +gitCheckObject gh = do + let cmd = [qc|git cat-file -e {pretty gh}|] + let procCfg = setStderr closed (shell cmd) + (code, _, _) <- readProcess procCfg + case code of + ExitSuccess -> pure True + ExitFailure{} -> pure False -gitListAllObjects :: MonadIO m => m [GitHash] +gitListAllObjects :: MonadIO m => m [(GitObjectType, GitHash)] gitListAllObjects = do let cmd = [qc|git cat-file --batch-check --batch-all-objects|] let procCfg = setStdin closed $ setStderr closed (shell cmd) @@ -288,7 +340,7 @@ gitListAllObjects = do where fromLine = \case - [ha, _, _] -> [fromString (LBS.unpack ha)] + [ha, tp, _] -> [(fromString (LBS.unpack tp), fromString (LBS.unpack ha))] _ -> [] -- FIXME: better error handling @@ -330,3 +382,82 @@ gitListLocalBranches = do _ -> [] +gitListAllCommits :: MonadIO m => m [GitHash] +gitListAllCommits = do + let cmd = [qc|git log --all --pretty=format:'%H'|] + let procCfg = setStdin closed $ setStderr closed (shell cmd) + (_, out, _) <- readProcess procCfg + pure $ fmap (fromString . LBS.unpack) (LBS.lines out) + +gitRunCommand :: MonadIO m => String -> m (Either ExitCode ByteString) +gitRunCommand cmd = do + let procCfg = setStdin closed $ setStderr closed (shell cmd) + (code, out, _) <- readProcess procCfg + case code of + ExitSuccess -> pure (Right out) + e -> pure (Left e) + +-- | list all commits from the given one in order of date +gitListAllCommitsExceptBy :: MonadIO m => Set GitHash -> Maybe GitHash -> GitHash -> m [GitHash] +gitListAllCommitsExceptBy excl l h = do + let from = maybe mempty (\r -> [qc|{pretty r}..|] ) l + let cmd = [qc|git rev-list --reverse --date-order {from}{pretty h}|] + let procCfg = setStdin closed $ setStderr closed (shell cmd) + (_, out, _) <- readProcess procCfg + let res = fmap (fromString . LBS.unpack) (LBS.lines out) + pure $ List.reverse $ filter ( not . flip Set.member excl) res + +-- | list all objects for the given commit range in order of date +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 procCfg = setStdin closed $ setStderr closed (shell cmd) + (_, out, _) <- readProcess procCfg + pure $ mapMaybe (fmap (fromString . LBS.unpack) . headMay . LBS.words) (LBS.lines out) + +-- TODO: handle-invalid-input-somehow +gitGetObjectTypeMany :: MonadIO m => [GitHash] -> m [(GitHash, GitObjectType)] +gitGetObjectTypeMany hashes = do + let hss = LBS.unlines $ fmap (LBS.pack.show.pretty) hashes + let cmd = [qc|git cat-file --batch-check='%(objectname) %(objecttype)'|] + let procCfg = setStdin (byteStringInput hss) $ setStderr closed (shell cmd) + (_, out, _) <- readProcess procCfg + pure $ mapMaybe (parse . fmap LBS.unpack . LBS.words) (LBS.lines out) + where + parse [h,tp] = (,) <$> fromStringMay h <*> fromStringMay tp + parse _ = Nothing + +gitGetCommitImmediateDeps :: MonadIO m => GitHash -> m [GitHash] +gitGetCommitImmediateDeps h = do + o <- gitReadObject (Just Commit) h + let lws = LBS.lines o & fmap LBS.words + + t <- forM lws $ \case + ["tree", hs] -> pure (Just ( fromString @GitHash (LBS.unpack hs) )) + _ -> pure Nothing + + let tree = take 1 $ catMaybes t + + deps <- gitRunCommand [qc|git rev-list --objects {pretty (headMay tree)}|] + >>= either (const $ pure mempty) + (pure . mapMaybe withLine . LBS.lines) + + pure $ List.nub $ tree <> deps + where + withLine :: LBS.ByteString -> Maybe GitHash + withLine l = do + let wordsInLine = LBS.words l + firstWord <- listToMaybe wordsInLine + pure $ fromString @GitHash $ LBS.unpack firstWord + + +startGitHashObject :: GitObjectType -> IO (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 + + diff --git a/hbs2-git/lib/HBS2/Git/Types.hs b/hbs2-git/lib/HBS2/Git/Types.hs index 35bd05a8..7918da37 100644 --- a/hbs2-git/lib/HBS2/Git/Types.hs +++ b/hbs2-git/lib/HBS2/Git/Types.hs @@ -41,6 +41,11 @@ instance Serialise GitHash instance IsString GitHash where fromString s = GitHash (B16.decodeLenient (BS.pack s)) +instance FromStringMaybe GitHash where + fromStringMay s = either (const Nothing) pure (GitHash <$> B16.decode bs) + where + bs = BS.pack s + instance Pretty GitHash where pretty (GitHash s) = pretty @String [qc|{B16.encode s}|] @@ -58,6 +63,13 @@ instance IsString GitObjectType where "blob" -> Blob x -> error [qc|invalid git object type {x}|] +instance FromStringMaybe GitObjectType where + fromStringMay = \case + "commit" -> Just Commit + "tree" -> Just Tree + "blob" -> Just Blob + _ -> Nothing + instance Pretty GitObjectType where pretty = \case Commit -> pretty @String "commit" diff --git a/hbs2-git/lib/HBS2Git/App.hs b/hbs2-git/lib/HBS2Git/App.hs index c8bf68c5..a5d0563f 100644 --- a/hbs2-git/lib/HBS2Git/App.hs +++ b/hbs2-git/lib/HBS2Git/App.hs @@ -432,26 +432,6 @@ makeDbPath h = do liftIO $ createDirectoryIfMissing True state pure $ state show (pretty (AsBase58 h)) - -readHead :: (MonadIO m, HasCatAPI m) => DBEnv -> m (Maybe RepoHead) -readHead db = runMaybeT do - href <- MaybeT $ withDB db stateGetHead - trace $ "repoHead" <+> pretty href - bs <- MaybeT $ readObject href - - let toParse = fmap LBS.words ( LBS.lines bs ) - - let fromSymb = Just . fromString . LBS.unpack . LBS.dropWhile (=='@') - let fromBS :: forall a . IsString a => LBS.ByteString -> a - fromBS = fromString . LBS.unpack - - let parsed = flip foldMap toParse $ \case - [a,"HEAD"] -> [RepoHead (fromSymb a) mempty] - [h,r] -> [RepoHead Nothing (HashMap.singleton (fromBS r) (fromBS h))] - _ -> mempty - - pure $ mconcat parsed - loadCredentials :: ( MonadIO m , HasConf m , HasRefCredentials m diff --git a/hbs2-git/lib/HBS2Git/Export.hs b/hbs2-git/lib/HBS2Git/Export.hs index e2fe7ee6..ddb9e6ad 100644 --- a/hbs2-git/lib/HBS2Git/Export.hs +++ b/hbs2-git/lib/HBS2Git/Export.hs @@ -2,11 +2,9 @@ module HBS2Git.Export where import HBS2.Prelude.Plated -import HBS2.Clock import HBS2.Data.Types.Refs import HBS2.OrDie import HBS2.System.Logger.Simple -import HBS2.Merkle import HBS2.Net.Proto.Definition() import HBS2.Base58 @@ -15,203 +13,258 @@ import HBS2.Git.Local.CLI import HBS2Git.App import HBS2Git.State -import HBS2Git.Update import HBS2Git.Config +import HBS2Git.GitRepoLog -import Data.Functor -import Data.List (sortBy) 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.Cache as Cache import Data.Foldable (for_) +import Data.Functor import Data.HashMap.Strict qualified as HashMap import Data.HashSet qualified as HashSet +import Data.HashSet (HashSet) import Data.Maybe import Data.Set qualified as Set -import Data.Set (Set) +import Data.Map qualified as Map +import Data.List qualified as List import Lens.Micro.Platform -import Control.Concurrent.STM -import Control.Concurrent.Async -import Control.Monad.Catch -import Text.InterpolatedString.Perl6 (qc) +import Prettyprinter.Render.Terminal import System.Directory import System.FilePath -import Prettyprinter.Render.Terminal +import Text.InterpolatedString.Perl6 (qc) +import UnliftIO.IO +import System.IO hiding (hClose,hPrint) +import System.IO.Temp +import Control.Monad.Trans.Resource -data HashCache = - HashCache - { hCache :: Cache GitHash (Set GitHash) - , hDb :: DBEnv - } +class ExportRepoOps a where -instance Hashable GitHash => HasCache HashCache GitHash (Set GitHash) IO where - cacheInsert (HashCache cache _) = Cache.insert cache +instance ExportRepoOps () - cacheLookup (HashCache cache db) k = do - refs <- withDB db (stateGetDeps k) - case refs of - [] -> Cache.lookup' cache k - xs -> pure $ Just $ Set.fromList xs +exportRefDeleted :: forall o m . ( MonadIO m + , MonadCatch m + -- , MonadMask m + , MonadUnliftIO m + , HasCatAPI m + , HasConf m + , HasRefCredentials m + , HasProgress m + , ExportRepoOps o + ) + => o + -> RepoRef + -> GitRef + -> m HashRef +exportRefDeleted _ repo ref = do + trace $ "exportRefDeleted" <+> pretty repo <+> pretty ref -newHashCache :: MonadIO m => DBEnv -> m HashCache -newHashCache db = do - ca <- liftIO $ Cache.newCache Nothing - pure $ HashCache ca db + dbPath <- makeDbPath repo + db <- dbEnv dbPath + -- это "ненормальный" лог, т.е удаление ссылки в текущем контексте + -- мы удаляем ссылку "там", то есть нам нужно "то" значение ссылки + -- удалить её локально мы можем и так, просто гитом. + -- NOTE: empty-log-post + -- мы тут постим пустой лог (не содержащий коммитов) + -- нам нужно будет найти его позицию относитеьлно прочих логов. + -- его контекст = текущее значение ссылки, которое мы удаляем + -- но вот если мы удаляем уже удаленную ссылку, то для ссылки 00..0 + -- будет ошибка где-то. -export :: forall m . ( MonadIO m - , MonadCatch m - , HasCatAPI m - , HasConf m - , HasRefCredentials m - , HasProgress m - ) => RepoRef -> RepoHead -> m (HashRef, HashRef) -export h repoHead = do + vals <- withDB db $ stateGetActualRefs <&> List.nub . fmap snd - let refs = HashMap.toList (view repoHeads repoHead) + let (ctxHead, ctxBs) = makeContextEntry vals + + trace $ "DELETING REF CONTEXT" <+> pretty vals + + let repoHead = RepoHead Nothing (HashMap.fromList [(ref,"0000000000000000000000000000000000000000")]) + let repoHeadStr = (LBS.pack . show . pretty . AsGitRefsFile) repoHead + let ha = gitHashObject (GitObject Blob repoHeadStr) + let headEntry = GitLogEntry GitLogEntryHead (Just ha) ( fromIntegral $ LBS.length repoHeadStr ) + + let content = gitRepoLogMakeEntry ctxHead ctxBs + <> gitRepoLogMakeEntry headEntry repoHeadStr + + -- FIXME: remove-code-dup + let meta = fromString $ show + $ "hbs2-git" <> line + <> "type:" <+> "hbs2-git-push-log" + <> line + + logMerkle <- storeObject meta content `orDie` [qc|Can't store push log|] + postRefUpdate repo 0 logMerkle + pure logMerkle + +makeContextEntry :: [GitHash] -> (GitLogEntry, LBS.ByteString) +makeContextEntry hashes = (entryHead, payload) + where + ha = Nothing + payload = GitLogContextCommits (HashSet.fromList hashes) & serialise + entryHead = GitLogEntry GitLogContext ha undefined + +-- | Exports only one ref to the repo. +-- Corresponds to a single ```git push``` operation +exportRefOnly :: forall o m . ( MonadIO m + , MonadCatch m + -- , MonadMask m + , MonadUnliftIO m + , HasCatAPI m + , HasConf m + , HasRefCredentials m + , HasProgress m + , ExportRepoOps o + ) + => o + -> RepoRef + -> Maybe GitRef + -> GitRef + -> GitHash + -> m HashRef + +exportRefOnly _ remote rfrom ref val = do + + let repoHead = RepoHead Nothing (HashMap.fromList [(ref,val)]) let repoHeadStr = (LBS.pack . show . pretty . AsGitRefsFile) repoHead - dbPath <- makeDbPath h - - trace $ "dbPath" <+> pretty dbPath - + dbPath <- makeDbPath remote db <- dbEnv dbPath - sp <- withDB db savepointNew + trace $ "exportRefOnly" <+> pretty remote <+> pretty ref <+> pretty val - withDB db $ savepointBegin sp + -- 1. get max ref value for known REMOTE branch + -- 2. if unkwnown - get max branch ref value for known LOCAL branch (known from the state) + -- 3. if unkwnown - then Nothing + -- therefore, we export only the delta for the objects for push between known state and current + -- git repot state + -- if it's a new branch push without any objects commited -- then empty log + -- only with HEAD section should be created + lastKnownRev <- withDB db do + rThat <- stateGetActualRefValue ref + rThis <- maybe1 rfrom (pure Nothing) stateGetActualRefValue + pure $ rThat <|> rThis - rr <- try $ do + trace $ "LAST_KNOWN_REV" <+> braces (pretty rfrom) <+> braces (pretty ref) <+> braces (pretty lastKnownRev) - skip <- withDB db stateGetExported <&> HashSet.fromList + entries <- gitRevList lastKnownRev val - -- TODO: process-only-commits-to-make-first-run-faster - ooo <- gitListAllObjects <&> filter (not . (`HashSet.member` skip)) + -- NOTE: just-for-test-new-non-empty-push-to-another-branch-112 - cached0 <- withDB db stateGetAllDeps - let cached = HashMap.fromListWith (<>) [ (k, [v]) | (k,v) <- cached0 ] - let lookup h = pure $ HashMap.lookup h cached & fromMaybe mempty + -- FIXME: may-blow-on-huge-repo-export + types <- gitGetObjectTypeMany entries <&> Map.fromList - monDep <- newProgressMonitor "calculate dependencies" (length ooo) + let lookupType t = Map.lookup t types + let justOrDie msg x = pure x `orDie` msg - allDeps <- gitGetAllDependencies 4 ooo lookup (const $ updateProgress monDep 1) + trace $ "ENTRIES:" <+> pretty (length entries) - let sz = length allDeps - mon1 <- newProgressMonitor "storing dependencies" sz + trace "MAKING OBJECTS LOG" - withDB db $ transactional do - for_ allDeps $ \(obj,dep) -> do - updateProgress mon1 1 - stateAddDep dep obj + let fname = [qc|{pretty val}.data|] - deps <- withDB db $ do - x <- forM refs $ stateGetDepsRec . snd - pure $ mconcat x + runResourceT $ do - withDB db $ transactional do -- to speedup inserts + written <- liftIO $ newTVarIO (HashSet.empty :: HashSet GitHash) - let metaApp = "application:" <+> "hbs2-git" <> line + let myTempDir = "hbs-git" + temp <- liftIO getCanonicalTemporaryDirectory + (_,dir) <- allocate (createTempDirectory temp myTempDir) removeDirectoryRecursive - let metaHead = fromString $ show - $ metaApp <> "type:" <+> "head" <> line + let fpath = dir fname + fh <- liftIO $ openBinaryFile fpath AppendMode - -- let gha = gitHashObject (GitObject Blob repoHead) - hh <- lift $ storeObject metaHead repoHeadStr `orDie` "cant save repo head" + expMon <- newProgressMonitor "export objects" (length entries) - mon3 <- newProgressMonitor "export objects from repo" (length deps) + enq <- liftIO newTQueueIO - for_ deps $ \d -> do - here <- stateGetHash d <&> isJust - -- FIXME: asap-check-if-objects-is-in-hbs2 - unless here do - lbs <- gitReadObject Nothing d + -- FIXME: export-wtf? - -- TODO: why-not-default-blob - -- anything is blob - tp <- gitGetObjectType d <&> fromMaybe Blob -- + 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)) - let metaO = fromString $ show - $ metaApp - <> "type:" <+> pretty tp <+> pretty d - <> line + liftIO $ atomically $ writeTQueue enq Nothing - hr' <- lift $ storeObject metaO lbs + 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 - maybe1 hr' (pure ()) $ \hr -> do - statePutHash tp d hr + mapM_ wait [aread] - updateProgress mon3 1 + -- FIXME: problem-log-is-not-assotiated-with-commit + -- Если так получилось, что в журнале подъехала только ссылка, + -- и больше нет никакой информации -- мы не можем определить + -- глубину(высоту?) этой ссылки, и, соответственно, вычислить + -- её depth в стейте. + -- Решение: в этом (или иных) случаях добавлять информацию о контексте, + -- например, состояние других известных ссылок в моменте. Список ссылок + -- берём из state, полагая, что раз ссылка в стейте, значит, она является + -- важной. Имея эту информацию, мы можем хоть как-то вычислять depth + -- этого лога. Похоже на векторные часы, кстати. - hashes <- (hh : ) <$> stateGetAllHashes + -- это "нормальный" лог. даже если хвост его приедет пустым (не будет коммитов) + -- тут мы запомним, что его контекст = коммит, на который он устанавливает ссылку + -- и этот коммит должен быть в секциях лога, которые приехали перед ним. + -- следствие: у предыдущего лога будет такая же глубина, как и у этого. - let pt = toPTree (MaxSize 512) (MaxNum 512) hashes -- FIXME: settings + vals <- withDB db $ stateGetActualRefs <&> List.nub . fmap snd + let (e, bs) = makeContextEntry (val:vals) + trace $ "writing context entry" <+> pretty [val] + gitRepoLogWriteEntry fh e bs - tobj <- liftIO newTQueueIO - -- FIXME: progress-indicator - root <- makeMerkle 0 pt $ \(ha,_,bss) -> do - liftIO $ atomically $ writeTQueue tobj (ha,bss) + let ha = gitHashObject (GitObject Blob repoHeadStr) + let headEntry = GitLogEntry GitLogEntryHead (Just ha) ( fromIntegral $ LBS.length repoHeadStr ) + gitRepoLogWriteEntry fh headEntry repoHeadStr - objs <- liftIO $ atomically $ flushTQueue tobj + -- TODO: find-prev-push-log-and-make-ref + gitRepoLogWriteHead fh (GitLogHeadEntry Nothing) - mon2 <- newProgressMonitor "store objects" (length objs) + hClose fh - for_ objs $ \(ha,bss) -> do - updateProgress mon2 1 - here <- lift $ getBlockSize (HashRef ha) <&> isJust - unless here do - void $ lift $ storeObject (fromString (show metaApp)) bss + trace "STORING PUSH LOG" - trace "generate update transaction" + let meta = fromString $ show + $ "hbs2-git" <> line + <> "type:" <+> "hbs2-git-push-log" + <> line - trace $ "objects:" <+> pretty (length hashes) + content <- liftIO $ LBS.readFile fpath + logMerkle <- lift $ storeObject meta content `orDie` [qc|Can't store push log|] - seqno <- stateGetSequence <&> succ - -- FIXME: same-transaction-different-seqno + trace $ "PUSH LOG HASH: " <+> pretty logMerkle + trace $ "POSTING REFERENCE UPDATE TRANSACTION" <+> pretty remote <+> pretty logMerkle - postRefUpdate h seqno (HashRef root) + -- FIXME: calculate-seqno-as-topsort-order + lift $ postRefUpdate remote 0 logMerkle - let noRef = do - pause @'Seconds 20 - shutUp - die $ show $ pretty "No reference appeared for" <+> pretty h + pure logMerkle - wmon <- newProgressMonitor "waiting for ref" 20 - void $ liftIO $ race noRef $ do - runApp NoLog do - fix \next -> do - v <- readRefHttp h - updateProgress wmon 1 - case v of - Nothing -> pause @'Seconds 1 >> next - Just{} -> pure () - - - withDB db $ transactional $ mapM_ statePutExported ooo - - pure (HashRef root, hh) - - case rr of - Left ( e :: SomeException ) -> do - withDB db (savepointRollback sp) - err $ viaShow e - shutUp - die "aborted" - - Right r -> do - withDB db (savepointRelease sp) - pure r - - -runExport :: forall m . (MonadIO m, MonadCatch m, HasProgress (App m)) +runExport :: forall m . (MonadIO m, MonadUnliftIO m, MonadCatch m, HasProgress (App m)) => Maybe FilePath -> RepoRef -> App m () -runExport fp h = do +runExport fp repo = do liftIO $ putDoc $ line - <> green "Exporting to reflog" <+> pretty (AsBase58 h) + <> green "Exporting to reflog" <+> pretty (AsBase58 repo) <> section <> "it may take some time on the first run" <> section @@ -234,16 +287,20 @@ runExport fp h = do fullHead <- gitHeadFullName headBranch - debug $ "HEAD" <+> pretty fullHead + -- debug $ "HEAD" <+> pretty fullHead - let repoHead = RepoHead (Just fullHead) - (HashMap.fromList refs) + -- let repoHead = RepoHead (Just fullHead) + -- (HashMap.fromList refs) - trace $ "NEW REPO HEAD" <+> pretty (AsGitRefsFile repoHead) + -- trace $ "NEW REPO HEAD" <+> pretty (AsGitRefsFile repoHead) - (root, hhh) <- export h repoHead + val <- gitGetHash fullHead `orDie` [qc|Can't resolve ref {pretty fullHead}|] - updateLocalState h + -- _ <- exportRefOnly () remote br gh + hhh <- exportRefOnly () repo Nothing fullHead val + + -- NOTE: ??? + -- traceTime "importRefLogNew (export)" $ importRefLogNew False repo shutUp @@ -251,7 +308,6 @@ runExport fp h = do cfgPath <- configPath cwd let krf = fromMaybe "keyring-file" fp & takeFileName - liftIO $ putStrLn "" liftIO $ putDoc $ "exported" <+> pretty hhh @@ -269,7 +325,7 @@ runExport fp h = do <> section <> green "Add git remote:" <> section - <> pretty [qc|git remote add remotename hbs2://{pretty h}|] + <> pretty [qc|git remote add remotename hbs2://{pretty repo}|] <> section <> green "Work with git as usual:" <> section diff --git a/hbs2-git/lib/HBS2Git/GitRepoLog.hs b/hbs2-git/lib/HBS2Git/GitRepoLog.hs new file mode 100644 index 00000000..0df8dee8 --- /dev/null +++ b/hbs2-git/lib/HBS2Git/GitRepoLog.hs @@ -0,0 +1,180 @@ +{-# Language TemplateHaskell #-} +module HBS2Git.GitRepoLog where + +import HBS2.Prelude.Plated +import HBS2.Git.Types +import HBS2.Data.Types.Refs + +import HBS2.System.Logger.Simple + +import Data.Word +import Data.Function +import Lens.Micro.Platform +import Codec.Serialise +import Data.ByteString.Lazy qualified as LBS +import Data.ByteString.Lazy (ByteString) +-- import System.IO +import UnliftIO.IO +import Control.Monad.IO.Unlift +import Codec.Compression.GZip +import System.Directory +import Data.HashSet (HashSet) +import Data.HashSet qualified as HashSet +import Control.Concurrent.STM +import Data.Maybe + +data GitLogEntryType = GitLogEntryCommit + | GitLogEntryBlob + | GitLogEntryTree + | GitLogEntryHead + | GitLogHead + | GitLogDeps + | GitLogHeadDel + | GitLogContext + deriving stock (Eq,Ord,Enum,Generic,Show) + + +newtype GitLogTimeStamp = GitLogTimeStamp Int + deriving stock (Eq,Ord,Show,Data,Generic) + +instance Serialise GitLogTimeStamp + +newtype GitLogHeadEntry = + GitLogHeadEntry + { _gitLogHeadAfter :: Maybe HashRef + } + deriving stock (Eq,Generic) + +instance Serialise GitLogHeadEntry + +makeLenses ''GitLogHeadEntry + + +newtype GitLogDepsEntry = + GitLogDepsEntry + { _gitLogDeps :: [HashRef] + } + deriving stock (Eq,Generic) + +makeLenses ''GitLogDepsEntry + +instance Serialise GitLogDepsEntry + +-- deletion is handled by special way. +-- we need a context WHEN the reference is deleted +-- because it may be deleted, created again, deleted again, etc. +-- Having current repository context via collecting all reference states +-- we may calculate an actual current state of the reference. +-- Or, we may use a special code to mark object as deleted +data GitLogHeadDelEntry = + GitLogHeadDelEntry + { _gitHeadContext :: [(GitRef, GitHash)] -- this gives us context to order this delete operation + , _gitHeadDeleted :: GitRef -- this is a reference to delete + } + deriving stock (Eq,Generic) + +makeLenses ''GitLogHeadDelEntry + +instance Serialise GitLogHeadDelEntry + +data GitLogContextEntry = + GitLogNoContext + | GitLogContextCommits (HashSet GitHash) + deriving stock (Eq,Data,Generic) + +commitsOfGitLogContextEntry :: GitLogContextEntry -> [GitHash] +commitsOfGitLogContextEntry = \case + GitLogNoContext -> mempty + GitLogContextCommits co -> HashSet.toList co + +instance Serialise GitLogContextEntry + +data GitLogEntry = + GitLogEntry + { _gitLogEntryType :: GitLogEntryType + , _gitLogEntryHash :: Maybe GitHash + , _gitLogEntrySize :: Word32 + } + deriving stock (Eq,Ord,Generic,Show) + +makeLenses 'GitLogEntry + +entryHeadSize :: Integral a => a +entryHeadSize = 64 + +instance Serialise GitLogEntryType +instance Serialise GitLogEntry + +gitLogEntryTypeOf :: GitObjectType -> GitLogEntryType +gitLogEntryTypeOf = \case + Commit -> GitLogEntryCommit + Tree -> GitLogEntryTree + Blob -> GitLogEntryBlob + +-- | scans hbs2-git repo log +gitRepoLogScan :: forall m . MonadUnliftIO m + => Bool -- ^ do read log section content + -> FilePath -- ^ log file path + -> (GitLogEntry -> Maybe ByteString -> m ()) -- ^ log section callback + -> m () + +gitRepoLogScan r fn cb = do + + trace $ "gitRepoLogScan" <+> pretty fn + withBinaryFile fn ReadMode $ \h -> do + sz <- liftIO $ getFileSize fn + go h sz + + where + go _ 0 = pure () + go h size = do + es <- liftIO $ LBS.hGet h entryHeadSize <&> deserialise @GitLogEntry + let esize = es ^. gitLogEntrySize + let consumed = entryHeadSize + fromIntegral esize + if r then do + o <- liftIO $ LBS.hGet h (fromIntegral esize) <&> decompress + cb es (Just o) + else do + liftIO $ hSeek h RelativeSeek (fromIntegral esize) + cb es Nothing + go h ( max 0 (size - consumed) ) + +gitRepoLogWriteHead :: forall m . MonadIO m => Handle -> GitLogHeadEntry -> m () +gitRepoLogWriteHead fh e = do + let s = serialise e + let entry = GitLogEntry GitLogHead Nothing (fromIntegral $ LBS.length s) + gitRepoLogWriteEntry fh entry s + +gitRepoLogMakeEntry :: GitLogEntry -> ByteString -> ByteString +gitRepoLogMakeEntry entry' o = bs <> ss + where + bs = LBS.take entryHeadSize $ serialise entry <> LBS.replicate entryHeadSize 0 + ss = compressWith co o + entry = entry' & set gitLogEntrySize (fromIntegral $ LBS.length ss) + co = defaultCompressParams { compressLevel = bestSpeed } + +-- TODO: use-gitRepoLogMakeEntry-in-body +gitRepoLogWriteEntry :: forall m . MonadIO m => Handle -> GitLogEntry -> ByteString -> m () +gitRepoLogWriteEntry fh entry' o = do + let ss = compressWith co o + let entry = entry' & set gitLogEntrySize (fromIntegral $ LBS.length ss) + let bs = LBS.take entryHeadSize $ serialise entry <> LBS.replicate entryHeadSize 0 + liftIO $ LBS.hPutStr fh bs + liftIO $ LBS.hPutStr fh ss + where + co = defaultCompressParams { compressLevel = bestSpeed } + +gitRepoMakeIndex :: FilePath -> IO (HashSet GitHash) +gitRepoMakeIndex fp = do + here <- doesFileExist fp + if not here then do + pure mempty + else do + out <- newTQueueIO + + gitRepoLogScan False fp $ \e _ -> do + atomically $ writeTQueue out ( e ^. gitLogEntryHash ) + + atomically $ flushTQueue out <&> HashSet.fromList . catMaybes + + diff --git a/hbs2-git/lib/HBS2Git/Import.hs b/hbs2-git/lib/HBS2Git/Import.hs index 1f7f8330..ea788fc0 100644 --- a/hbs2-git/lib/HBS2Git/Import.hs +++ b/hbs2-git/lib/HBS2Git/Import.hs @@ -11,25 +11,30 @@ import HBS2.Net.Proto.RefLog import Text.InterpolatedString.Perl6 (qc) import HBS2.Data.Detect hiding (Blob) -import Data.Config.Suckless - import HBS2.Git.Local - +import HBS2Git.GitRepoLog import HBS2Git.App import HBS2Git.State +import HBS2.Git.Local.CLI +import Data.Fixed import Control.Monad.Trans.Maybe import Control.Concurrent.STM import Control.Concurrent.STM.TQueue qualified as Q import Control.Monad.Reader -import Data.Foldable (for_) import Data.Maybe -import Data.Text qualified as Text -import Data.ByteString.Lazy qualified as LBS +import Data.ByteString.Lazy.Char8 qualified as LBS import Lens.Micro.Platform --- import System.Exit +import Data.Set qualified as Set import Codec.Serialise import Control.Monad.Catch +import Control.Monad.Trans.Resource +import System.Directory +import System.IO.Temp +import UnliftIO.IO +import System.IO (openBinaryFile) +import System.FilePath.Posix +import Data.HashMap.Strict qualified as HashMap data RunImportOpts = RunImportOpts @@ -42,123 +47,177 @@ makeLenses 'RunImportOpts isRunImportDry :: RunImportOpts -> Bool isRunImportDry o = view runImportDry o == Just True - +walkHashes :: HasCatAPI m => TQueue HashRef -> Hash HbSync -> m () walkHashes q h = walkMerkle h (readBlock . HashRef) $ \(hr :: Either (Hash HbSync) [HashRef]) -> do case hr of Left hx -> die $ show $ pretty "missed block:" <+> pretty hx Right (hrr :: [HashRef]) -> do forM_ hrr $ liftIO . atomically . Q.writeTQueue q -importRefLog :: (MonadIO m, HasCatAPI m) => DBEnv -> RepoRef -> m () -importRefLog db ref = do - logRoot <- readRef ref `orDie` [qc|can't read ref {pretty ref}|] +data ImportCmd = ImportCmd GitObjectType FilePath + | ImportStop + deriving (Show) - trace $ pretty logRoot +importRefLogNew :: ( MonadIO m + , MonadUnliftIO m + , MonadCatch m + , HasCatAPI m + ) + => Bool -> RepoRef -> m () - logQ <- liftIO newTQueueIO - walkHashes logQ (fromHashRef logRoot) +importRefLogNew force ref = runResourceT do + let myTempDir = "hbs-git" + temp <- liftIO getCanonicalTemporaryDirectory + (_,dir) <- allocate (createTempDirectory temp myTempDir) removeDirectoryRecursive - entries <- liftIO $ atomically $ flushTQueue logQ + db <- makeDbPath ref >>= dbEnv - forM_ entries $ \e -> do + do + trace $ "importRefLogNew" <+> pretty ref + logRoot <- lift $ readRef ref `orDie` [qc|can't read ref {pretty ref}|] + trace $ "ROOT" <+> pretty logRoot - missed <- readBlock e <&> isNothing + trans <- withDB db $ stateGetAllTranImported <&> Set.fromList + done <- withDB db $ stateGetRefImported logRoot - when missed do - debug $ "MISSED BLOCK" <+> pretty e + when (not done || force) do - runMaybeT $ do - bs <- MaybeT $ readBlock e - refupd <- MaybeT $ pure $ deserialiseOrFail @(RefLogUpdate HBS2L4Proto) bs & either (const Nothing) Just - e <- MaybeT $ pure $ deserialiseOrFail (LBS.fromStrict $ view refLogUpdData refupd) & either (const Nothing) Just - let (SequentialRef n (AnnotatedHashRef _ h)) = e - withDB db $ stateUpdateRefLog n h + logQ <- liftIO newTQueueIO - new <- withDB db stateGetHead <&> isNothing + lift $ walkHashes logQ (fromHashRef logRoot) - when new do - pure () + let notSkip n = force || not (Set.member n trans) + entries <- liftIO $ atomically $ flushTQueue logQ <&> filter notSkip -importObjects :: (MonadIO m, MonadCatch m, HasCatAPI m) => DBEnv -> HashRef -> m () -importObjects db root = do + pCommit <- liftIO $ startGitHashObject Commit + pTree <- liftIO $ startGitHashObject Tree + pBlob <- liftIO $ startGitHashObject Blob - q <- liftIO newTQueueIO + let hCommits = getStdin pCommit + let hTrees = getStdin pTree + let hBlobs = getStdin pBlob - walkHashes q (fromHashRef root) + let handles = [hCommits, hTrees, hBlobs] - entries <- liftIO $ atomically $ Q.flushTQueue q + sp0 <- withDB db savepointNew + withDB db $ savepointBegin sp0 - hd <- pure (headMay entries) `orDie` "no head block found" + forM_ entries $ \e -> do - -- TODO: what-if-metadata-is-really-big? - hdData <- readBlock hd `orDie` "empty head block" + missed <- lift $ readBlock e <&> isNothing - let hdBlk = tryDetect (fromHashRef hd) hdData + when missed do + debug $ "MISSED BLOCK" <+> pretty e - let meta = headDef "" [ Text.unpack s | ShortMetadata s <- universeBi hdBlk ] + let fname = show (pretty e) + let fpath = dir fname - syn <- liftIO $ parseTop meta & either (const $ die "invalid head block meta") pure + (keyFh, fh) <- allocate (openBinaryFile fpath AppendMode) hClose - let app sy = headDef False - [ True - | ListVal @C (Key "application:" [SymbolVal "hbs2-git"]) <- sy - ] + runMaybeT $ do + bs <- MaybeT $ lift $ readBlock e + refupd <- MaybeT $ pure $ deserialiseOrFail @(RefLogUpdate HBS2L4Proto) bs & either (const Nothing) Just + payload <- MaybeT $ pure $ deserialiseOrFail (LBS.fromStrict $ view refLogUpdData refupd) & either (const Nothing) Just + let (SequentialRef _ (AnnotatedHashRef _ h)) = payload + trace $ "PUSH LOG HASH" <+> pretty h - let hdd = headDef False - [ True - | ListVal @C (Key "type:" [SymbolVal "head"]) <- syn - ] + here <- withDB db $ stateGetLogImported h - unless ( app syn && hdd ) do - liftIO $ die "invalid head block meta" + unless (here && not force) do - let rest = drop 1 entries + lift $ deepScan ScanDeep (const none) (fromHashRef h) (lift . readBlock . HashRef) $ \ha -> do + sec <- lift $ readBlock (HashRef ha) `orDie` [qc|missed block {pretty ha}|] + -- skip merkle tree head block, write only the data + when (h /= HashRef ha) do + liftIO $ LBS.hPutStr fh sec + release keyFh - withDB db $ transactional $ do + tnum <- liftIO $ newTVarIO 0 + liftIO $ gitRepoLogScan True fpath $ \_ _ -> do + liftIO $ atomically $ modifyTVar tnum succ - trace "ABOUT TO UPDATE HEAD" + num <- liftIO $ readTVarIO tnum + trace $ "LOG ENTRY COUNT" <+> pretty num - statePutHead hd - statePutImported root hd + let pref = take 16 (show (pretty e)) + sz <- liftIO $ getFileSize fpath <&> realToFrac + let name = [qc|import {pref}... {sz / (1024*1024) :: Fixed E3}|] - mon <- newProgressMonitor "importing objects" (length rest) + oMon <- newProgressMonitor name num - for_ rest $ \r -> do + lift $ gitRepoLogScan True fpath $ \entry s -> do + updateProgress oMon 1 - updateProgress mon 1 + lbs <- pure s `orDie` [qc|git object not read from log|] - gh <- stateGetGitHash r <&> isJust + withDB db do - unless gh do + case view gitLogEntryType entry of + GitLogEntryCommit -> do + bss <- lift (pure s) `orDie` [qc|git object not read from log|] + let co = view gitLogEntryHash entry + hx <- pure (view gitLogEntryHash entry) `orDie` [qc|empty git hash|] - blk <- lift $ readBlock r `orDie` "empty data block" + trace $ "logobject" <+> pretty h <+> "commit" <+> pretty (view gitLogEntryHash entry) - let what = tryDetect (fromHashRef r) blk + writeIfNew hCommits dir hx (GitObject Commit lbs) + statePutLogObject (h, Commit, hx) - let short = headDef "" [ s | ShortMetadata s <- universeBi what ] + let parents = gitCommitGetParentsPure bss - let fields = Text.lines short & fmap Text.words + forM_ parents $ \p -> do + trace $ "fact" <+> "commit-parent" <+> pretty co <+> pretty p + statePutLogCommitParent (hx,p) - let fromTxt = fromString . Text.unpack - let fromRec t = Just . (t,) . fromTxt + GitLogEntryBlob -> do + trace $ "logobject" <+> pretty h <+> "blob" <+> pretty (view gitLogEntryHash entry) + hx <- pure (view gitLogEntryHash entry) `orDie` [qc|empty git hash|] + writeIfNew hBlobs dir hx (GitObject Blob lbs) + statePutLogObject (h, Blob, hx) - hm <- forM fields $ \case - ["type:", "blob", x] -> pure $ fromRec Blob x - ["type:", "commit", x] -> pure $ fromRec Commit x - ["type:", "tree", x] -> pure $ fromRec Tree x - _ -> pure Nothing + GitLogEntryTree -> do + trace $ "logobject" <+> pretty h <+> "tree" <+> pretty (view gitLogEntryHash entry) + hx <- pure (view gitLogEntryHash entry) `orDie` [qc|empty git hash|] + writeIfNew hTrees dir hx (GitObject Tree lbs) + statePutLogObject (h, Tree, hx) - case catMaybes hm of - [(t,sha1)] -> do - trace $ "statePutHash" <+> pretty t <+> pretty sha1 + GitLogContext -> do + trace $ "logobject" <+> pretty h <+> "context" <+> pretty (view gitLogEntryHash entry) - -- FIXME: return-dry? - statePutHash t sha1 r + let co = fromMaybe mempty $ deserialiseOrFail @GitLogContextEntry + <$> s >>= either (const Nothing) Just <&> commitsOfGitLogContextEntry - _ -> err $ "skipping bad object" <+> pretty r + forM_ co (statePutLogContextCommit h) - pure () + GitLogEntryHead -> do + trace $ "HEAD ENTRY" <+> viaShow s + let mbrh = fromStringMay @RepoHead (maybe mempty LBS.unpack s) + rh <- pure mbrh `orDie` [qc|invalid log header in {pretty h} {s}|] + forM_ (HashMap.toList $ view repoHeads rh) $ \(re,ha) -> do + trace $ "logrefval" <+> pretty h <+> pretty re <+> pretty ha + statePutLogRefVal (h,re,ha) + + _ -> pure () + + statePutLogImported h + statePutTranImported e + + withDB db $ do + statePutRefImported logRoot + stateUpdateCommitDepths + savepointRelease sp0 + + mapM_ hClose handles + + where + + writeIfNew gitHandle dir h (GitObject tp s) = do + let nf = dir show (pretty h) + liftIO $ LBS.writeFile nf s + hPutStrLn gitHandle nf + hFlush gitHandle + trace $ "WRITTEN OBJECT" <+> pretty tp <+> pretty h <+> pretty nf diff --git a/hbs2-git/lib/HBS2Git/ListRefs.hs b/hbs2-git/lib/HBS2Git/ListRefs.hs index 9ac1c41c..6a29e268 100644 --- a/hbs2-git/lib/HBS2Git/ListRefs.hs +++ b/hbs2-git/lib/HBS2Git/ListRefs.hs @@ -5,12 +5,20 @@ import HBS2.Prelude import HBS2Git.App import HBS2.Data.Types.Refs (HashRef) +import HBS2.System.Logger.Simple import HBS2.Git.Local.CLI +import HBS2.Git.Types +import HBS2Git.Import (importRefLogNew) +import HBS2Git.State +import Data.HashMap.Strict qualified as HashMap import Data.Functor import Data.Text qualified as Text import Data.Traversable import Prettyprinter.Render.Terminal +import Control.Monad.IO.Unlift +import Control.Monad.Catch +import System.IO (stdout) data AsRemoteEntry = AsRemoteEntry { remoteName :: Text, @@ -65,6 +73,21 @@ runListRefs = do where isHbs2 (_, b) = Text.isPrefixOf hbs2Prefix b +runToolsScan :: (MonadUnliftIO m,MonadCatch m) => RepoRef -> App m () +runToolsScan ref = do + trace $ "runToolsScan" <+> pretty ref + importRefLogNew False ref + shutUp + pure () + +runToolsGetRefs :: (MonadUnliftIO m,MonadCatch m) => RepoRef -> App m () +runToolsGetRefs ref = do + db <- makeDbPath ref >>= dbEnv + refs <- withDB db stateGetActualRefs + let rh = RepoHead Nothing (HashMap.fromList refs) + hPrint stdout $ pretty (AsGitRefsFile rh) + shutUp + getRefVal :: (MonadIO m, HasCatAPI m) => Text -> m (Maybe HashRef) getRefVal url = case Text.stripPrefix hbs2Prefix url of diff --git a/hbs2-git/lib/HBS2Git/State.hs b/hbs2-git/lib/HBS2Git/State.hs index b2dcaf71..08155a0b 100644 --- a/hbs2-git/lib/HBS2Git/State.hs +++ b/hbs2-git/lib/HBS2Git/State.hs @@ -27,9 +27,17 @@ import Control.Monad.Catch import Control.Concurrent.STM import System.IO.Unsafe +-- FIXME: move-orphans-to-separate-module + instance ToField GitHash where toField h = toField (show $ pretty h) +instance ToField GitRef where + toField h = toField (show $ pretty h) + +instance FromField GitRef where + fromField = fmap fromString . fromField @String + instance FromField GitHash where fromField = fmap fromString . fromField @String @@ -39,7 +47,6 @@ instance FromField GitObjectType where instance ToField HashRef where toField h = toField (show $ pretty h) - instance ToField GitObjectType where toField h = toField (show $ pretty h) @@ -90,54 +97,97 @@ stateInit :: MonadIO m => DB m () stateInit = do conn <- ask liftIO $ execute_ conn [qc| - create table if not exists dep - ( object text not null - , parent text not null - , primary key (object, parent) + create table if not exists logrefval + ( loghash text not null + , refname text not null + , refval text not null + , primary key (loghash, refname) ) |] liftIO $ execute_ conn [qc| - create table if not exists object - ( githash text not null - , hash text not null unique + create table if not exists logobject + ( loghash text not null , type text not null - , primary key (githash,hash) + , githash text not null + , primary key (loghash, githash) ) |] liftIO $ execute_ conn [qc| - create table if not exists head - ( key text not null primary key - , hash text not null unique + create table if not exists logcommitparent + ( kommit text not null + , parent text not null + , primary key (kommit,parent) ) |] liftIO $ execute_ conn [qc| - create table if not exists imported - ( seq integer primary key autoincrement - , ts DATE DEFAULT (datetime('now','localtime')) - , merkle text not null - , head text not null - , unique (merkle,head) + create table if not exists logimported + ( hash text not null + , primary key (hash) ) |] liftIO $ execute_ conn [qc| - create table if not exists reflog - ( seq integer primary key - , ts DATE DEFAULT (datetime('now','localtime')) - , merkle text not null - , unique (merkle) + create table if not exists refimported + ( hash text not null + , timestamp DATETIME DEFAULT CURRENT_TIMESTAMP + , primary key (hash) ) |] liftIO $ execute_ conn [qc| - create table if not exists exported - ( githash text not null primary key + create table if not exists tranimported + ( hash text not null + , timestamp DATETIME DEFAULT CURRENT_TIMESTAMP + , primary key (hash) ) |] + liftIO $ execute_ conn [qc| + DROP VIEW IF EXISTS v_refval_actual; + |] + + liftIO $ execute_ conn [qc| + CREATE view v_refval_actual AS + WITH a1 as ( + SELECT + l.refname + , l.refval + , vd.depth + + FROM logrefval l + JOIN v_log_depth vd on vd.loghash = l.loghash ) + + SELECT a1.refname, a1.refval, MAX(a1.depth) from a1 + GROUP by a1.refname + HAVING a1.refval <> '0000000000000000000000000000000000000000' ; + |] + + liftIO $ execute_ conn [qc| + CREATE TABLE IF NOT EXISTS logcommitdepth + ( kommit text not null + , depth integer not null + , primary key (kommit) + ); + |] + + liftIO $ execute_ conn [qc| + DROP VIEW IF EXISTS v_log_depth; + |] + + liftIO $ execute_ conn [qc| + CREATE VIEW v_log_depth AS + SELECT + lo.loghash, + MAX(ld.depth) AS depth + FROM logobject lo + JOIN logcommitdepth ld ON lo.githash = ld.kommit + WHERE lo.type in ( 'commit', 'context' ) + GROUP BY lo.loghash; + |] + newtype Savepoint = Savepoint String @@ -189,179 +239,157 @@ transactional action = do -- состояние репозитория -statePutExported :: MonadIO m => GitHash -> DB m () -statePutExported h = do +statePutLogRefVal :: MonadIO m => (HashRef, GitRef, GitHash) -> DB m () +statePutLogRefVal row = do conn <- ask liftIO $ execute conn [qc| - insert into exported (githash) values(?) - on conflict (githash) do nothing + insert into logrefval (loghash,refname,refval) values(?,?,?) + on conflict (loghash,refname) do nothing + |] row + + +statePutLogObject :: MonadIO m => (HashRef, GitObjectType, GitHash) -> DB m () +statePutLogObject row = do + conn <- ask + liftIO $ execute conn [qc| + insert into logobject (loghash,type,githash) values(?,?,?) + on conflict (loghash,githash) do nothing + |] row + +stateIsLogObjectExists :: MonadIO m => GitHash -> DB m Bool +stateIsLogObjectExists h = do + conn <- ask + liftIO $ query conn [qc| + SELECT NULL FROM logobject WHERE githash = ? LIMIT 1 + |] (Only h) <&> isJust . listToMaybe . fmap (fromOnly @(Maybe Int)) + +statePutLogContextCommit :: MonadIO m => HashRef -> GitHash -> DB m () +statePutLogContextCommit loghash ctx = do + conn <- ask + liftIO $ execute conn [qc| + insert into logobject (loghash,type,githash) values(?,'context',?) + on conflict (loghash,githash) do nothing + |] (loghash,ctx) + +statePutLogCommitParent :: MonadIO m => (GitHash, GitHash) -> DB m () +statePutLogCommitParent row = do + conn <- ask + liftIO $ execute conn [qc| + insert into logcommitparent (kommit,parent) values(?,?) + on conflict (kommit,parent) do nothing + |] row + + +statePutLogImported :: MonadIO m => HashRef -> DB m () +statePutLogImported h = do + conn <- ask + liftIO $ execute conn [qc| + insert into logimported (hash) values(?) + on conflict (hash) do nothing |] (Only h) -stateGetExported :: MonadIO m => DB m [GitHash] -stateGetExported = do + +stateGetLogImported :: MonadIO m => HashRef -> DB m Bool +stateGetLogImported h = do + conn <- ask + r <- liftIO $ query @_ @(Only Int) conn [qc| + select 1 from logimported where hash = ? limit 1 + |] (Only h) + pure $ not $ null r + + +statePutRefImported :: MonadIO m => HashRef -> DB m () +statePutRefImported h = do + conn <- ask + liftIO $ execute conn [qc| + insert into refimported (hash) values(?) + on conflict (hash) do nothing + |] (Only h) + +stateGetRefImported :: MonadIO m => HashRef -> DB m Bool +stateGetRefImported h = do + conn <- ask + r <- liftIO $ query @_ @(Only Int) conn [qc| + select 1 from refimported where hash = ? limit 1 + |] (Only h) + pure $ not $ null r + +statePutTranImported :: MonadIO m => HashRef -> DB m () +statePutTranImported h = do + conn <- ask + liftIO $ execute conn [qc| + insert into tranimported (hash) values(?) + on conflict (hash) do nothing + |] (Only h) + +stateGetTranImported :: MonadIO m => HashRef -> DB m Bool +stateGetTranImported h = do + conn <- ask + r <- liftIO $ query @_ @(Only Int) conn [qc| + select 1 from tranimported where hash = ? limit 1 + |] (Only h) + pure $ not $ null r + +stateGetAllTranImported :: MonadIO m => DB m [HashRef] +stateGetAllTranImported = do + conn <- ask + results <- liftIO $ query_ conn [qc| + select hash from tranimported + |] + pure $ map fromOnly results + +stateGetImportedCommits :: MonadIO m => DB m [GitHash] +stateGetImportedCommits = do conn <- ask liftIO $ query_ conn [qc| - select githash from exported + select distinct(githash) from logobject where type = 'commit' |] <&> fmap fromOnly -statePutImported :: MonadIO m => HashRef -> HashRef -> DB m () -statePutImported merkle hd = do - conn <- ask - liftIO $ execute conn [qc| - insert into imported (merkle,head) values(?,?) - on conflict (merkle,head) do nothing - |] (merkle,hd) - -stateUpdateRefLog :: MonadIO m => Integer -> HashRef -> DB m () -stateUpdateRefLog seqno merkle = do - conn <- ask - liftIO $ execute conn [qc| - insert into reflog (seq,merkle) values(?,?) - on conflict (merkle) do nothing - on conflict (seq) do nothing - |] (seqno,merkle) - -stateGetRefLogLast :: MonadIO m => DB m (Maybe (Integer, HashRef)) -stateGetRefLogLast = do +stateGetActualRefs :: MonadIO m => DB m [(GitRef, GitHash)] +stateGetActualRefs = do conn <- ask liftIO $ query_ conn [qc| - select seq, merkle from reflog - order by seq desc - limit 1 - |] <&> listToMaybe - -statePutHead :: MonadIO m => HashRef -> DB m () -statePutHead h = do - conn <- ask - liftIO $ execute conn [qc| - insert into head (key,hash) values('head',?) - on conflict (key) do update set hash = ? - |] (h,h) - -stateGetHead :: MonadIO m => DB m (Maybe HashRef) -stateGetHead = do - conn <- ask - liftIO $ query_ conn [qc| - select hash from head where key = 'head' - limit 1 - |] <&> listToMaybe . fmap fromOnly - -stateAddDep :: MonadIO m => GitHash -> GitHash -> DB m () -stateAddDep h1 h2 = do - conn <- ask - void $ liftIO $ execute conn [qc| - insert into dep (object,parent) values(?,?) - on conflict (object,parent) do nothing - |] (h1,h2) - - -stateGetDepsRec :: MonadIO m => GitHash -> DB m [GitHash] -stateGetDepsRec h = do - conn <- ask - liftIO $ query conn [qc| - -WITH RECURSIVE find_children(object, parent) AS ( - SELECT object, parent FROM dep WHERE parent = ? - UNION - SELECT d.object, d.parent FROM dep d INNER JOIN find_children fc - ON d.parent = fc.object -) -SELECT object FROM find_children group by object; - - |] (Only h) <&> mappend [h] . fmap fromOnly - -stateGetAllDeps :: MonadIO m => DB m [(GitHash,GitHash)] -stateGetAllDeps = do - conn <- ask - liftIO $ query_ conn [qc| - select parent, object from dep where parent = ? + select refname,refval from v_refval_actual |] - -stateDepFilterAll :: MonadIO m => DB m [GitHash] -stateDepFilterAll = do - conn <- ask - liftIO $ query_ conn [qc| - select distinct(parent) from dep - union - select githash from object o where o.type = 'blob' - |] <&> fmap fromOnly - -stateDepFilter :: MonadIO m => GitHash -> DB m Bool -stateDepFilter h = do - conn <- ask - liftIO $ query @_ @[Int] conn [qc| - select 1 from dep - where parent = ? - or exists (select null from object where githash = ? and type = 'blob') - limit 1 - |] (h,h) <&> isJust . listToMaybe - -stateGetDeps :: MonadIO m => GitHash -> DB m [GitHash] -stateGetDeps h = do +stateGetActualRefValue :: MonadIO m => GitRef -> DB m (Maybe GitHash) +stateGetActualRefValue ref = do conn <- ask liftIO $ query conn [qc| - select object from dep where parent = ? - |] (Only h) <&> fmap fromOnly + select refval from v_refval_actual + where refname = ? + |] (Only ref) <&> fmap fromOnly . listToMaybe - -statePutHash :: MonadIO m => GitObjectType -> GitHash -> HashRef -> DB m () -statePutHash t g h = do +stateUpdateCommitDepths :: MonadIO m => DB m () +stateUpdateCommitDepths = do conn <- ask - liftIO $ execute conn [qc| - insert into object (githash,hash,type) values(?,?,?) - on conflict (githash,hash) do nothing - |] (g,h,t) + sp <- savepointNew + 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 -stateGetHash :: MonadIO m => GitHash -> DB m (Maybe HashRef) -stateGetHash h = do - conn <- ask - liftIO $ query conn [qc| - select hash from object where githash = ? - limit 1 - |] (Only h) <&> fmap fromOnly <&> listToMaybe + UNION ALL - -stateGetGitHash :: MonadIO m => HashRef -> DB m (Maybe GitHash) -stateGetGitHash h = do - conn <- ask - liftIO $ query conn [qc| - select githash from object where hash = ? - limit 1 - |] (Only h) <&> fmap fromOnly <&> listToMaybe - -stateGetAllHashes :: MonadIO m => DB m [HashRef] -stateGetAllHashes = do - conn <- ask - liftIO $ query_ conn [qc| - select distinct(hash) from object - |] <&> fmap fromOnly - -stateGetAllObjects:: MonadIO m => DB m [(HashRef,GitHash,GitObjectType)] -stateGetAllObjects = do - conn <- ask - liftIO $ query_ conn [qc| - select hash, githash, type from object + 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; |] - -stateGetLastImported :: MonadIO m => Int -> DB m [(Text,HashRef,HashRef)] -stateGetLastImported n = do - conn <- ask - liftIO $ query conn [qc| - select ts, merkle, head from imported - order by seq desc - limit ? - |] (Only n) - -stateGetSequence :: MonadIO m => DB m Integer -stateGetSequence = do - conn <- ask - liftIO $ query_ conn [qc| - select coalesce(max(seq),0) from reflog; - |] <&> fmap fromOnly - <&> listToMaybe - <&> fromMaybe 0 - - + savepointRelease sp diff --git a/hbs2-git/lib/HBS2Git/Types.hs b/hbs2-git/lib/HBS2Git/Types.hs index 75d183de..b783aedc 100644 --- a/hbs2-git/lib/HBS2Git/Types.hs +++ b/hbs2-git/lib/HBS2Git/Types.hs @@ -15,6 +15,8 @@ import HBS2.Data.Types.Refs import HBS2.Net.Proto.Types import HBS2.Net.Auth.Credentials +import HBS2.System.Logger.Simple + import Data.Config.Suckless import System.ProgressBar @@ -24,8 +26,11 @@ import Control.Applicative import Control.Monad.IO.Class import Control.Monad.Reader import Database.SQLite.Simple (Connection) +import Data.Char (isSpace) import Data.Set qualified as Set import Data.Set (Set) +import Data.List qualified as List +import Data.Maybe import Lens.Micro.Platform import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HashMap @@ -35,6 +40,9 @@ import System.IO qualified as IO import System.IO (Handle) import Data.Kind import Control.Monad.Catch +import Control.Monad.IO.Unlift + +import System.TimeIt -- FIXME: remove-udp-hardcode-asap type Schema = HBS2Basic @@ -77,7 +85,7 @@ data RepoHead = { _repoHEAD :: Maybe GitRef , _repoHeads :: HashMap GitRef GitHash } - deriving stock (Generic) + deriving stock (Generic,Show) makeLenses 'RepoHead @@ -90,17 +98,40 @@ instance Semigroup RepoHead where & set repoHeads ( view repoHeads a <> view repoHeads b ) instance Pretty (AsGitRefsFile RepoHead) where - pretty (AsGitRefsFile h) = vcat (hhead : fmap fmt els) + pretty (AsGitRefsFile h) = hhead <> vcat (fmap fmt els) where hhead = case view repoHEAD h of Nothing -> mempty - Just r -> "@" <> pretty r <+> "HEAD" + Just r -> "@" <> pretty r <+> "HEAD" <> line els = HashMap.toList (view repoHeads h) fmt (r,hx) = pretty hx <+> pretty (normalizeRef r) + instance Serialise RepoHead +-- FIXME: test-for-from-string-maybe-repohead +-- Нужно написать или сгенерировать тест +instance FromStringMaybe RepoHead where + fromStringMay "" = Nothing + fromStringMay s = + case traverse decodePair (take 2 . words <$> lines trimmed) of + Right xs -> Just $ mconcat xs + _ -> Nothing + where + trimmed = dropWhile isSpace s + hbranch x = fromString <$> List.stripPrefix "@" x + decodePair :: [String] -> Either [String] RepoHead + decodePair [x, "HEAD"] | "@" `List.isPrefixOf` x = Right $ RepoHead (hbranch x) mempty + + -- special case: deleted branch. should be handled somehow + decodePair [_] = Right $ RepoHead Nothing mempty + + decodePair [x,r] = case fromStringMay x of + Just h -> Right $ RepoHead Nothing (HashMap.singleton (fromString r) h) + Nothing -> Left [r,x] + decodePair other = Left other + pattern Key :: forall {c}. Id -> [Syntax c] -> [Syntax c] pattern Key n ns <- SymbolVal n : ns @@ -136,6 +167,12 @@ instance (HasCatAPI m, MonadIO m) => HasCatAPI (MaybeT m) where getHttpPutAPI = lift getHttpPutAPI getHttpRefLogGetAPI = lift getHttpRefLogGetAPI +-- instance (HasCatAPI (App m), MonadIO m) => HasCatAPI (ResourceT (App m)) where +-- getHttpCatAPI = lift getHttpCatAPI +-- getHttpSizeAPI = lift getHttpSizeAPI +-- getHttpPutAPI = lift getHttpPutAPI +-- getHttpRefLogGetAPI = lift getHttpRefLogGetAPI + class Monad m => HasCfgKey a b m where -- type family CfgValue a :: Type key :: Id @@ -155,6 +192,8 @@ newtype App m a = , MonadReader AppEnv , MonadThrow , MonadCatch + , MonadUnliftIO + , MonadTrans ) instance MonadIO m => HasConf (App m) where @@ -194,3 +233,9 @@ die :: MonadIO m => String -> m a die s = do liftIO $ Exit.die s +traceTime :: MonadIO m => String -> m a -> m a +traceTime s action = do + (t, x) <- timeItT action + trace $ "time" <+> pretty s <+> pretty t + pure x + diff --git a/hbs2-git/lib/HBS2Git/Update.hs b/hbs2-git/lib/HBS2Git/Update.hs deleted file mode 100644 index 4d19c8de..00000000 --- a/hbs2-git/lib/HBS2Git/Update.hs +++ /dev/null @@ -1,56 +0,0 @@ -module HBS2Git.Update where - -import HBS2.Prelude.Plated -import HBS2.OrDie - -import HBS2.System.Logger.Simple - -import HBS2.Git.Types -import HBS2Git.Types -import HBS2Git.App -import HBS2Git.State -import HBS2Git.Import - -import Control.Monad.Catch - - -updateLocalState :: (MonadIO m, HasCatAPI m, MonadCatch m) => RepoRef -> m () -updateLocalState ref = do - - dbPath <- makeDbPath ref - - trace $ "dbPath:" <+> pretty dbPath - - db <- dbEnv dbPath - - withDB db stateInit - - trace $ "updateLocalState" <+> pretty ref - - sp <- withDB db savepointNew - - withDB db $ savepointBegin sp - - r <- try $ do - - -- TODO: read-reflog - -- TODO: update-reflog - importRefLog db ref - - (n,hash) <- withDB db $ stateGetRefLogLast `orDie` "empty reflog" - - trace $ "got reflog" <+> pretty (n,hash) - - importObjects db hash - - withDB db (savepointRelease sp) - - case r of - Left (e :: SomeException) -> do - withDB db $ savepointRollback sp - err (viaShow e) - err "error happened. state rolled back" - - Right{} -> pure () - -