mirror of https://github.com/voidlizard/hbs2
new-repository-format
This commit is contained in:
Dmitry Zuikov
parent
456cdd9e01
commit
1b93659ef4
|
|
@ -1,3 +1,24 @@
|
|||
## 2023-06-23
|
||||
Странно, но всё еще новый формат репозитория.
|
||||
Вроде бы сегодня можно попробовать его смержить
|
||||
в мастер. Совместим со старым он не будет
|
||||
|
||||
## 2023-04-26
|
||||
|
||||
тестируем новый формат репозитория.
|
||||
получится ли запустить его одновременно
|
||||
со старым? вопрос.
|
||||
|
||||
Потенциально, можно делать инкрементальные добавления
|
||||
в файл лога гита + так же нужно добавить запись
|
||||
"последняя запись". Но тогда эту последнюю запись
|
||||
невозможно будет добавлять, так как лог append-only.
|
||||
|
||||
Можно её добавить только при передаче через TCP стрим,
|
||||
что бы как-то определять конец файла.
|
||||
|
||||
Тест.
|
||||
|
||||
|
||||
## 2023-04-18
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
@ -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}
|
||||
|
||||
|
||||
|
|
@ -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}
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
|
||||
FIXME: delete-refs-properly
|
||||
Сейчас мы помечаем удалённые бранчи 0000000000000000000000000000000000000000
|
||||
и если такой бранч был удалён однажды, то больше его мы не увидим. Тогда как
|
||||
реально они могут быть удалены, созданы, опять удалены.
|
||||
Для каждой операции в logrefval мы пишем хэш лога, в котором она определена.
|
||||
Так же у нас есть logobject в котором есть связь объектов и логов, и коммиты,
|
||||
для которых мы можем построить высоту (топологически).
|
||||
Таким образом, у лога можно определить "высоту", а значит, и для всех операций
|
||||
в логе можно определить высоту. Таким образом, у последовательности изменений
|
||||
значения ссылки возникает порядок.
|
||||
|
|
@ -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
|
||||
Поддержать теги, в т.ч. подписанные.
|
||||
Неподписанные возможно и так будут работать.
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
FIXME: hbs2-slow-import-export-1
|
||||
Сейчас полностью перечитывается весь лог при вызове importRefLogNew,
|
||||
если хотя бы одна из ссылок отсутствует. Например, всё будет пересканировано
|
||||
при добавлении новой ссылки (бранча).
|
||||
|
||||
Нужно: перечитывать только отсутствующие ссылки.
|
||||
|
||||
|
||||
TODO: use-fast-import-for-import
|
||||
Можно генерировать формат git fast-import при импорте, тогда
|
||||
ускорится импорт раз в десять.
|
||||
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 "<HASH-REF> | 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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
||||
|
||||
Loading…
Reference in New Issue