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
|
## 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
|
module Main where
|
||||||
|
|
||||||
import HBS2.Prelude
|
import HBS2.Prelude.Plated
|
||||||
import HBS2.Data.Types.Refs
|
import HBS2.Data.Types.Refs
|
||||||
import HBS2.Base58
|
import HBS2.Base58
|
||||||
import HBS2.OrDie
|
import HBS2.OrDie
|
||||||
import HBS2.Git.Types
|
import HBS2.Git.Types
|
||||||
import HBS2.Git.Local.CLI
|
|
||||||
import HBS2.Clock
|
|
||||||
|
|
||||||
import HBS2.System.Logger.Simple
|
import HBS2.System.Logger.Simple
|
||||||
|
|
||||||
import HBS2Git.Types()
|
import HBS2Git.Types(traceTime)
|
||||||
import HBS2Git.Types qualified as G
|
|
||||||
import HBS2Git.App
|
import HBS2Git.App
|
||||||
import HBS2Git.State
|
import HBS2Git.State
|
||||||
import HBS2Git.Update
|
import HBS2Git.Import
|
||||||
import HBS2Git.Export
|
import HBS2.Git.Local.CLI
|
||||||
import HBS2Git.Config as Config
|
|
||||||
|
import HBS2Git.Export (runExport)
|
||||||
|
|
||||||
import GitRemoteTypes
|
import GitRemoteTypes
|
||||||
import GitRemotePush
|
import GitRemotePush
|
||||||
|
|
||||||
import Control.Concurrent.Async
|
|
||||||
import Control.Concurrent.STM
|
import Control.Concurrent.STM
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import Data.Attoparsec.Text
|
import Data.Attoparsec.Text hiding (try)
|
||||||
import Data.Attoparsec.Text qualified as Atto
|
import Data.Attoparsec.Text qualified as Atto
|
||||||
import Data.ByteString.Char8 qualified as BS
|
import Data.ByteString.Char8 qualified as BS
|
||||||
import Data.ByteString.Lazy.Char8 qualified as LBS
|
import Data.ByteString.Lazy.Char8 qualified as LBS
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
import Data.Functor
|
import Data.Functor
|
||||||
import Data.HashSet qualified as HashSet
|
import Data.Function ((&))
|
||||||
|
import Data.HashMap.Strict qualified as HashMap
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.Text qualified as Text
|
import Data.Text qualified as Text
|
||||||
|
import Data.List qualified as List
|
||||||
import System.Environment
|
import System.Environment
|
||||||
import System.Exit qualified as Exit
|
|
||||||
import System.Posix.Signals
|
import System.Posix.Signals
|
||||||
import System.ProgressBar
|
|
||||||
import Text.InterpolatedString.Perl6 (qc)
|
import Text.InterpolatedString.Perl6 (qc)
|
||||||
import UnliftIO.IO as UIO
|
import UnliftIO.IO as UIO
|
||||||
import Control.Monad.Trans.Maybe
|
|
||||||
import Control.Monad.Catch
|
import Control.Monad.Catch
|
||||||
|
import Control.Monad.Trans.Resource
|
||||||
|
|
||||||
|
|
||||||
send :: MonadIO m => BS.ByteString -> m ()
|
send :: MonadIO m => BS.ByteString -> m ()
|
||||||
send = liftIO . BS.hPutStr stdout
|
send = liftIO . BS.hPutStr stdout
|
||||||
|
|
@ -73,14 +71,16 @@ parseRepoURL url' = either (const Nothing) Just (parseOnly p url)
|
||||||
capabilities :: BS.ByteString
|
capabilities :: BS.ByteString
|
||||||
capabilities = BS.unlines ["push","fetch"]
|
capabilities = BS.unlines ["push","fetch"]
|
||||||
|
|
||||||
readHeadDef :: HasCatAPI m => DBEnv -> m LBS.ByteString
|
|
||||||
readHeadDef db =
|
guessHead :: GitRef -> Integer
|
||||||
withDB db stateGetHead >>=
|
guessHead = \case
|
||||||
\r' -> maybe1 r' (pure "\n") \r -> do
|
"refs/heads/master" -> 0
|
||||||
readObject r <&> fromMaybe "\n"
|
"refs/heads/main" -> 0
|
||||||
|
_ -> 1
|
||||||
|
|
||||||
loop :: forall m . ( MonadIO m
|
loop :: forall m . ( MonadIO m
|
||||||
, MonadCatch m
|
, MonadCatch m
|
||||||
|
, MonadUnliftIO m
|
||||||
, HasProgress (RunWithConfig (GitRemoteApp m))
|
, HasProgress (RunWithConfig (GitRemoteApp m))
|
||||||
) => [String] -> GitRemoteApp m ()
|
) => [String] -> GitRemoteApp m ()
|
||||||
loop args = do
|
loop args = do
|
||||||
|
|
@ -104,8 +104,7 @@ loop args = do
|
||||||
|
|
||||||
db <- dbEnv dbPath
|
db <- dbEnv dbPath
|
||||||
|
|
||||||
--FIXME: git-fetch-second-time
|
-- TODO: hbs2-peer-fetch-reference-and-wait
|
||||||
-- Разобраться, почему git fetch срабатывает со второго раза
|
|
||||||
|
|
||||||
checkRef <- readRef ref <&> isJust
|
checkRef <- readRef ref <&> isJust
|
||||||
|
|
||||||
|
|
@ -114,30 +113,27 @@ loop args = do
|
||||||
warn "trying to init reference --- may be it's ours"
|
warn "trying to init reference --- may be it's ours"
|
||||||
liftIO $ runApp NoLog (runExport Nothing ref)
|
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
|
debug $ "THIS MIGHT BE CLONE!" <+> pretty force
|
||||||
-- если clone - доставать всё
|
|
||||||
-- если fetch - брать список объектов и импортировать
|
|
||||||
-- только те, которых нет в репо
|
|
||||||
|
|
||||||
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
|
let hd = refsNew & LBS.pack . show
|
||||||
liftIO $ atomically $ for_ hashes $ \o@(_,gh,_) -> do
|
. pretty
|
||||||
unless (HashSet.member gh existed) do
|
. AsGitRefsFile
|
||||||
modifyTVar' jobNumT succ
|
. RepoHead possibleHead
|
||||||
writeTQueue jobz o
|
. HashMap.fromList
|
||||||
|
|
||||||
env <- ask
|
|
||||||
|
|
||||||
batch <- liftIO $ newTVarIO False
|
batch <- liftIO $ newTVarIO False
|
||||||
|
|
||||||
|
|
@ -153,10 +149,6 @@ loop args = do
|
||||||
let str = BS.unwords (BS.words s)
|
let str = BS.unwords (BS.words s)
|
||||||
let cmd = BS.words str
|
let cmd = BS.words str
|
||||||
|
|
||||||
-- trace $ pretty (fmap BS.unpack cmd)
|
|
||||||
-- hPrint stderr $ show $ pretty (fmap BS.unpack cmd)
|
|
||||||
--
|
|
||||||
|
|
||||||
isBatch <- liftIO $ readTVarIO batch
|
isBatch <- liftIO $ readTVarIO batch
|
||||||
|
|
||||||
case cmd of
|
case cmd of
|
||||||
|
|
@ -172,26 +164,6 @@ loop args = do
|
||||||
next
|
next
|
||||||
|
|
||||||
["list"] -> do
|
["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)
|
for_ (LBS.lines hd) (sendLn . LBS.toStrict)
|
||||||
sendEol
|
sendEol
|
||||||
next
|
next
|
||||||
|
|
@ -211,16 +183,16 @@ loop args = do
|
||||||
let bra = BS.split ':' rr
|
let bra = BS.split ':' rr
|
||||||
let pu = fmap (fromString' . BS.unpack) bra
|
let pu = fmap (fromString' . BS.unpack) bra
|
||||||
liftIO $ atomically $ writeTVar batch True
|
liftIO $ atomically $ writeTVar batch True
|
||||||
|
-- debug $ "FUCKING PUSH" <> viaShow rr <+> pretty pu
|
||||||
|
-- shutUp
|
||||||
pushed <- push ref pu
|
pushed <- push ref pu
|
||||||
case pushed of
|
case pushed of
|
||||||
Nothing -> hPrint stderr "fucked!" >> sendEol
|
Nothing -> hPrint stderr "oopsie!" >> sendEol >> shutUp
|
||||||
Just re -> sendLn [qc|ok {pretty re}|]
|
Just re -> sendLn [qc|ok {pretty re}|]
|
||||||
next
|
next
|
||||||
|
|
||||||
other -> die $ show other
|
other -> die $ show other
|
||||||
|
|
||||||
-- updateLocalState ref
|
|
||||||
|
|
||||||
where
|
where
|
||||||
fromString' "" = Nothing
|
fromString' "" = Nothing
|
||||||
fromString' x = Just $ fromString x
|
fromString' x = Just $ fromString x
|
||||||
|
|
|
||||||
|
|
@ -6,8 +6,6 @@ import HBS2.Data.Types.Refs
|
||||||
import HBS2.OrDie
|
import HBS2.OrDie
|
||||||
import HBS2.System.Logger.Simple
|
import HBS2.System.Logger.Simple
|
||||||
import HBS2.Net.Auth.Credentials hiding (getCredentials)
|
import HBS2.Net.Auth.Credentials hiding (getCredentials)
|
||||||
-- import HBS2.Merkle
|
|
||||||
-- import HBS2.Hash
|
|
||||||
|
|
||||||
import HBS2.Git.Local
|
import HBS2.Git.Local
|
||||||
import HBS2.Git.Local.CLI
|
import HBS2.Git.Local.CLI
|
||||||
|
|
@ -16,22 +14,17 @@ import HBS2Git.Config as Config
|
||||||
import HBS2Git.Types
|
import HBS2Git.Types
|
||||||
import HBS2Git.State
|
import HBS2Git.State
|
||||||
import HBS2Git.App
|
import HBS2Git.App
|
||||||
import HBS2Git.Export (export)
|
import HBS2Git.Export (exportRefOnly,exportRefDeleted)
|
||||||
|
import HBS2Git.Import (importRefLogNew)
|
||||||
|
|
||||||
import GitRemoteTypes
|
import GitRemoteTypes
|
||||||
|
|
||||||
import Data.Maybe
|
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import Data.Functor
|
import Data.Functor
|
||||||
import Data.Set (Set)
|
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 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.Catch
|
||||||
|
import Control.Monad.Trans.Resource
|
||||||
|
|
||||||
newtype RunWithConfig m a =
|
newtype RunWithConfig m a =
|
||||||
WithConfig { fromWithConf :: ReaderT [Syntax C] m a }
|
WithConfig { fromWithConf :: ReaderT [Syntax C] m a }
|
||||||
|
|
@ -43,6 +36,8 @@ newtype RunWithConfig m a =
|
||||||
, MonadTrans
|
, MonadTrans
|
||||||
, MonadThrow
|
, MonadThrow
|
||||||
, MonadCatch
|
, MonadCatch
|
||||||
|
-- , MonadMask
|
||||||
|
, MonadUnliftIO
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -65,43 +60,37 @@ instance MonadIO m => HasRefCredentials (RunWithConfig (GitRemoteApp m)) where
|
||||||
push :: forall m . ( MonadIO m
|
push :: forall m . ( MonadIO m
|
||||||
, MonadCatch m
|
, MonadCatch m
|
||||||
, HasProgress (RunWithConfig (GitRemoteApp m))
|
, HasProgress (RunWithConfig (GitRemoteApp m))
|
||||||
|
, MonadUnliftIO m
|
||||||
)
|
)
|
||||||
|
|
||||||
=> RepoRef -> [Maybe GitRef] -> GitRemoteApp m (Maybe GitRef)
|
=> RepoRef -> [Maybe GitRef] -> GitRemoteApp m (Maybe GitRef)
|
||||||
|
|
||||||
push remote [bFrom , Just br] = do
|
|
||||||
|
|
||||||
|
|
||||||
|
push remote what@[Just bFrom , Just br] = do
|
||||||
(_, syn) <- Config.configInit
|
(_, syn) <- Config.configInit
|
||||||
|
|
||||||
dbPath <- makeDbPath remote
|
dbPath <- makeDbPath remote
|
||||||
db <- dbEnv dbPath
|
db <- dbEnv dbPath
|
||||||
|
|
||||||
runWithConfig syn do
|
runWithConfig syn do
|
||||||
|
_ <- cfgValue @ConfBranch @(Set GitRef) <&> transformBi normalizeRef
|
||||||
brCfg <- cfgValue @ConfBranch @(Set GitRef) <&> transformBi normalizeRef
|
|
||||||
|
|
||||||
loadCredentials mempty
|
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
|
runWithConfig syn do
|
||||||
Just newBr -> do
|
_ <- cfgValue @ConfBranch @(Set GitRef) <&> transformBi normalizeRef
|
||||||
gh <- gitGetHash (normalizeRef newBr) `orDie` [qc|can't read hash for ref {pretty newBr}|]
|
loadCredentials mempty
|
||||||
pure $ over repoHeads (HashMap.insert br gh) oldHead
|
trace $ "deleting remote reference" <+> pretty br
|
||||||
|
exportRefDeleted () remote br
|
||||||
Nothing -> do
|
importRefLogNew False remote
|
||||||
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
|
|
||||||
pure (Just br)
|
pure (Just br)
|
||||||
|
|
||||||
push r w = do
|
push r w = do
|
||||||
|
|
|
||||||
|
|
@ -14,6 +14,7 @@ import Data.HashMap.Strict qualified as HashMap
|
||||||
import Data.HashMap.Strict (HashMap)
|
import Data.HashMap.Strict (HashMap)
|
||||||
import Control.Concurrent.STM
|
import Control.Concurrent.STM
|
||||||
import Control.Monad.Catch
|
import Control.Monad.Catch
|
||||||
|
import Control.Monad.Trans.Resource
|
||||||
|
|
||||||
data RemoteEnv =
|
data RemoteEnv =
|
||||||
RemoteEnv
|
RemoteEnv
|
||||||
|
|
@ -35,6 +36,7 @@ newtype GitRemoteApp m a =
|
||||||
, MonadReader RemoteEnv
|
, MonadReader RemoteEnv
|
||||||
, MonadThrow
|
, MonadThrow
|
||||||
, MonadCatch
|
, MonadCatch
|
||||||
|
, MonadUnliftIO
|
||||||
)
|
)
|
||||||
|
|
||||||
runRemoteM :: MonadIO m => RemoteEnv -> GitRemoteApp m a -> m a
|
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"))
|
parser = hsubparser ( command "export" (info pExport (progDesc "export repo"))
|
||||||
<> command "list-refs" (info pListRefs (progDesc "list refs"))
|
<> command "list-refs" (info pListRefs (progDesc "list refs"))
|
||||||
<> command "show" (info pShow (progDesc "show various types of objects"))
|
<> command "show" (info pShow (progDesc "show various types of objects"))
|
||||||
|
<> command "tools" (info pTools (progDesc "misc tools"))
|
||||||
)
|
)
|
||||||
|
|
||||||
pExport = do
|
pExport = do
|
||||||
|
|
@ -40,4 +41,19 @@ main = join . customExecParser (prefs showHelpOnError) $
|
||||||
pShow = do
|
pShow = do
|
||||||
object <- optional $
|
object <- optional $
|
||||||
argument (maybeReader showReader) (metavar "object" <> help "<HASH-REF> | config")
|
argument (maybeReader showReader) (metavar "object" <> help "<HASH-REF> | config")
|
||||||
|
|
||||||
pure $ runApp NoLog (runShow object)
|
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 :: MonadIO m => RepoRef -> App m ()
|
||||||
showRef h = do
|
showRef h = do
|
||||||
db <- makeDbPath h >>= dbEnv
|
db <- makeDbPath h >>= dbEnv
|
||||||
withDB db do
|
-- FIXME: re-implement-showRef
|
||||||
hd <- stateGetHead
|
pure ()
|
||||||
imported <- stateGetLastImported 10
|
-- withDB db do
|
||||||
liftIO $ do
|
-- hd <- stateGetHead
|
||||||
print $ "current state for" <+> pretty (AsBase58 h)
|
-- imported <- stateGetLastImported 10
|
||||||
print $ "head:" <+> pretty hd
|
-- liftIO $ do
|
||||||
print $ pretty "last operations:"
|
-- print $ "current state for" <+> pretty (AsBase58 h)
|
||||||
for_ imported (\(t,h1,h2) -> print $ pretty t <+> pretty h1 <+> pretty h2)
|
-- 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 :: MonadIO m => App m ()
|
||||||
showRefs = do
|
showRefs = do
|
||||||
|
|
|
||||||
|
|
@ -63,27 +63,33 @@ common shared-properties
|
||||||
, containers
|
, containers
|
||||||
, cryptonite
|
, cryptonite
|
||||||
, directory
|
, directory
|
||||||
|
, exceptions
|
||||||
|
, filelock
|
||||||
, filepath
|
, filepath
|
||||||
|
, hashable
|
||||||
|
, http-conduit
|
||||||
, interpolatedstring-perl6
|
, interpolatedstring-perl6
|
||||||
, memory
|
, memory
|
||||||
, microlens-platform
|
, microlens-platform
|
||||||
, mtl
|
, mtl
|
||||||
, prettyprinter
|
, prettyprinter
|
||||||
, prettyprinter-ansi-terminal
|
, prettyprinter-ansi-terminal
|
||||||
|
, resourcet
|
||||||
, safe
|
, safe
|
||||||
, serialise
|
, serialise
|
||||||
|
, sqlite-simple
|
||||||
|
, stm
|
||||||
, suckless-conf
|
, suckless-conf
|
||||||
|
, temporary
|
||||||
, text
|
, text
|
||||||
|
, time
|
||||||
|
, timeit
|
||||||
, transformers
|
, transformers
|
||||||
, typed-process
|
, typed-process
|
||||||
, uniplate
|
, uniplate
|
||||||
, hashable
|
, unliftio
|
||||||
, sqlite-simple
|
, unliftio-core
|
||||||
, stm
|
|
||||||
, unordered-containers
|
, unordered-containers
|
||||||
, filelock
|
|
||||||
, http-conduit
|
|
||||||
, exceptions
|
|
||||||
|
|
||||||
library
|
library
|
||||||
import: shared-properties
|
import: shared-properties
|
||||||
|
|
@ -99,7 +105,7 @@ library
|
||||||
HBS2Git.Config
|
HBS2Git.Config
|
||||||
HBS2Git.App
|
HBS2Git.App
|
||||||
HBS2Git.State
|
HBS2Git.State
|
||||||
HBS2Git.Update
|
HBS2Git.GitRepoLog
|
||||||
|
|
||||||
-- other-modules:
|
-- other-modules:
|
||||||
-- other-extensions:
|
-- other-extensions:
|
||||||
|
|
@ -108,6 +114,7 @@ library
|
||||||
, terminal-progress-bar
|
, terminal-progress-bar
|
||||||
, http-types
|
, http-types
|
||||||
, uuid
|
, uuid
|
||||||
|
, zlib
|
||||||
|
|
||||||
hs-source-dirs: lib
|
hs-source-dirs: lib
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
|
||||||
|
|
@ -1,13 +1,17 @@
|
||||||
{-# Language AllowAmbiguousTypes #-}
|
{-# 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.Git.Types
|
||||||
|
|
||||||
import HBS2.System.Logger.Simple
|
import HBS2.System.Logger.Simple
|
||||||
|
|
||||||
import Control.Concurrent.Async
|
import Control.Concurrent.Async
|
||||||
import Control.Concurrent.STM
|
import Control.Concurrent.STM
|
||||||
import Control.Monad.IO.Class
|
|
||||||
import Control.Monad.Writer
|
import Control.Monad.Writer
|
||||||
import Data.HashSet (HashSet)
|
import Data.HashSet (HashSet)
|
||||||
import Data.HashSet qualified as HashSet
|
import Data.HashSet qualified as HashSet
|
||||||
|
|
@ -21,15 +25,13 @@ import Data.Function
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.Set qualified as Set
|
import Data.Set qualified as Set
|
||||||
import Data.Set (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 qualified as Text
|
||||||
import Data.Text.Encoding (decodeLatin1)
|
import Data.Text.Encoding (decodeLatin1)
|
||||||
import Data.Text qualified as Text
|
import Data.Text qualified as Text
|
||||||
import Data.Text (Text)
|
|
||||||
import Prettyprinter
|
|
||||||
import Safe
|
|
||||||
import System.Process.Typed
|
import System.Process.Typed
|
||||||
import Text.InterpolatedString.Perl6 (qc)
|
import Text.InterpolatedString.Perl6 (qc)
|
||||||
|
import System.IO
|
||||||
|
|
||||||
-- FIXME: specify-git-dir
|
-- FIXME: specify-git-dir
|
||||||
|
|
||||||
|
|
@ -68,9 +70,31 @@ gitGetDepsPure (GitObject Commit bs) = Set.fromList (recurse ls)
|
||||||
|
|
||||||
gitGetDepsPure _ = mempty
|
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 :: MonadIO m => GitHash -> m (Maybe GitObjectType)
|
||||||
gitGetObjectType hash = do
|
gitGetObjectType hash = do
|
||||||
(_, out, _) <- readProcess (shell [qc|git cat-file -t {pretty hash}|])
|
(_, out, _) <- readProcess (shell [qc|git cat-file -t {pretty hash}|])
|
||||||
|
|
@ -105,11 +129,13 @@ gitGetDependencies hash = do
|
||||||
_ -> pure mempty
|
_ -> pure mempty
|
||||||
|
|
||||||
|
|
||||||
|
-- | calculates all dependencies of given list
|
||||||
|
-- of git objects
|
||||||
gitGetAllDependencies :: MonadIO m
|
gitGetAllDependencies :: MonadIO m
|
||||||
=> Int
|
=> Int -- ^ number of threads
|
||||||
-> [ GitHash ]
|
-> [ GitHash ] -- ^ initial list of objects to calculate deps
|
||||||
-> ( GitHash -> IO [GitHash] )
|
-> ( GitHash -> IO [GitHash] ) -- ^ lookup function
|
||||||
-> ( GitHash -> IO () )
|
-> ( GitHash -> IO () ) -- ^ progress update function
|
||||||
-> m [(GitHash, GitHash)]
|
-> m [(GitHash, GitHash)]
|
||||||
|
|
||||||
gitGetAllDependencies n objects lookup progress = liftIO do
|
gitGetAllDependencies n objects lookup progress = liftIO do
|
||||||
|
|
@ -182,6 +208,24 @@ gitGetTransitiveClosure cache exclude hash = do
|
||||||
pure res
|
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
|
-- FIXME: inject-git-working-dir-via-typeclass
|
||||||
|
|
||||||
gitConfigGet :: MonadIO m => Text -> m (Maybe Text)
|
gitConfigGet :: MonadIO m => Text -> m (Maybe Text)
|
||||||
|
|
@ -277,8 +321,16 @@ gitStoreObject (GitObject t s) = do
|
||||||
ExitSuccess -> pure $ Just (parseHashLazy out)
|
ExitSuccess -> pure $ Just (parseHashLazy out)
|
||||||
ExitFailure{} -> pure Nothing
|
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
|
gitListAllObjects = do
|
||||||
let cmd = [qc|git cat-file --batch-check --batch-all-objects|]
|
let cmd = [qc|git cat-file --batch-check --batch-all-objects|]
|
||||||
let procCfg = setStdin closed $ setStderr closed (shell cmd)
|
let procCfg = setStdin closed $ setStderr closed (shell cmd)
|
||||||
|
|
@ -288,7 +340,7 @@ gitListAllObjects = do
|
||||||
|
|
||||||
where
|
where
|
||||||
fromLine = \case
|
fromLine = \case
|
||||||
[ha, _, _] -> [fromString (LBS.unpack ha)]
|
[ha, tp, _] -> [(fromString (LBS.unpack tp), fromString (LBS.unpack ha))]
|
||||||
_ -> []
|
_ -> []
|
||||||
|
|
||||||
-- FIXME: better error handling
|
-- 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
|
instance IsString GitHash where
|
||||||
fromString s = GitHash (B16.decodeLenient (BS.pack s))
|
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
|
instance Pretty GitHash where
|
||||||
pretty (GitHash s) = pretty @String [qc|{B16.encode s}|]
|
pretty (GitHash s) = pretty @String [qc|{B16.encode s}|]
|
||||||
|
|
||||||
|
|
@ -58,6 +63,13 @@ instance IsString GitObjectType where
|
||||||
"blob" -> Blob
|
"blob" -> Blob
|
||||||
x -> error [qc|invalid git object type {x}|]
|
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
|
instance Pretty GitObjectType where
|
||||||
pretty = \case
|
pretty = \case
|
||||||
Commit -> pretty @String "commit"
|
Commit -> pretty @String "commit"
|
||||||
|
|
|
||||||
|
|
@ -432,26 +432,6 @@ makeDbPath h = do
|
||||||
liftIO $ createDirectoryIfMissing True state
|
liftIO $ createDirectoryIfMissing True state
|
||||||
pure $ state </> show (pretty (AsBase58 h))
|
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
|
loadCredentials :: ( MonadIO m
|
||||||
, HasConf m
|
, HasConf m
|
||||||
, HasRefCredentials m
|
, HasRefCredentials m
|
||||||
|
|
|
||||||
|
|
@ -2,11 +2,9 @@
|
||||||
module HBS2Git.Export where
|
module HBS2Git.Export where
|
||||||
|
|
||||||
import HBS2.Prelude.Plated
|
import HBS2.Prelude.Plated
|
||||||
import HBS2.Clock
|
|
||||||
import HBS2.Data.Types.Refs
|
import HBS2.Data.Types.Refs
|
||||||
import HBS2.OrDie
|
import HBS2.OrDie
|
||||||
import HBS2.System.Logger.Simple
|
import HBS2.System.Logger.Simple
|
||||||
import HBS2.Merkle
|
|
||||||
import HBS2.Net.Proto.Definition()
|
import HBS2.Net.Proto.Definition()
|
||||||
import HBS2.Base58
|
import HBS2.Base58
|
||||||
|
|
||||||
|
|
@ -15,203 +13,258 @@ import HBS2.Git.Local.CLI
|
||||||
|
|
||||||
import HBS2Git.App
|
import HBS2Git.App
|
||||||
import HBS2Git.State
|
import HBS2Git.State
|
||||||
import HBS2Git.Update
|
|
||||||
import HBS2Git.Config
|
import HBS2Git.Config
|
||||||
|
import HBS2Git.GitRepoLog
|
||||||
|
|
||||||
import Data.Functor
|
|
||||||
import Data.List (sortBy)
|
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
|
import Control.Monad.Catch
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
|
import UnliftIO.Async
|
||||||
|
import Control.Concurrent.STM
|
||||||
import Data.ByteString.Lazy.Char8 qualified as LBS
|
import Data.ByteString.Lazy.Char8 qualified as LBS
|
||||||
import Data.Cache as Cache
|
|
||||||
import Data.Foldable (for_)
|
import Data.Foldable (for_)
|
||||||
|
import Data.Functor
|
||||||
import Data.HashMap.Strict qualified as HashMap
|
import Data.HashMap.Strict qualified as HashMap
|
||||||
import Data.HashSet qualified as HashSet
|
import Data.HashSet qualified as HashSet
|
||||||
|
import Data.HashSet (HashSet)
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.Set qualified as Set
|
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 Lens.Micro.Platform
|
||||||
import Control.Concurrent.STM
|
import Prettyprinter.Render.Terminal
|
||||||
import Control.Concurrent.Async
|
|
||||||
import Control.Monad.Catch
|
|
||||||
import Text.InterpolatedString.Perl6 (qc)
|
|
||||||
import System.Directory
|
import System.Directory
|
||||||
import System.FilePath
|
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 =
|
class ExportRepoOps a where
|
||||||
HashCache
|
|
||||||
{ hCache :: Cache GitHash (Set GitHash)
|
|
||||||
, hDb :: DBEnv
|
|
||||||
}
|
|
||||||
|
|
||||||
instance Hashable GitHash => HasCache HashCache GitHash (Set GitHash) IO where
|
instance ExportRepoOps ()
|
||||||
cacheInsert (HashCache cache _) = Cache.insert cache
|
|
||||||
|
|
||||||
cacheLookup (HashCache cache db) k = do
|
exportRefDeleted :: forall o m . ( MonadIO m
|
||||||
refs <- withDB db (stateGetDeps k)
|
, MonadCatch m
|
||||||
case refs of
|
-- , MonadMask m
|
||||||
[] -> Cache.lookup' cache k
|
, MonadUnliftIO m
|
||||||
xs -> pure $ Just $ Set.fromList xs
|
, 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
|
dbPath <- makeDbPath repo
|
||||||
newHashCache db = do
|
db <- dbEnv dbPath
|
||||||
ca <- liftIO $ Cache.newCache Nothing
|
|
||||||
pure $ HashCache ca db
|
|
||||||
|
|
||||||
|
-- это "ненормальный" лог, т.е удаление ссылки в текущем контексте
|
||||||
|
-- мы удаляем ссылку "там", то есть нам нужно "то" значение ссылки
|
||||||
|
-- удалить её локально мы можем и так, просто гитом.
|
||||||
|
-- NOTE: empty-log-post
|
||||||
|
-- мы тут постим пустой лог (не содержащий коммитов)
|
||||||
|
-- нам нужно будет найти его позицию относитеьлно прочих логов.
|
||||||
|
-- его контекст = текущее значение ссылки, которое мы удаляем
|
||||||
|
-- но вот если мы удаляем уже удаленную ссылку, то для ссылки 00..0
|
||||||
|
-- будет ошибка где-то.
|
||||||
|
|
||||||
export :: forall m . ( MonadIO m
|
vals <- withDB db $ stateGetActualRefs <&> List.nub . fmap snd
|
||||||
, MonadCatch m
|
|
||||||
, HasCatAPI m
|
|
||||||
, HasConf m
|
|
||||||
, HasRefCredentials m
|
|
||||||
, HasProgress m
|
|
||||||
) => RepoRef -> RepoHead -> m (HashRef, HashRef)
|
|
||||||
export h repoHead = do
|
|
||||||
|
|
||||||
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
|
let repoHeadStr = (LBS.pack . show . pretty . AsGitRefsFile) repoHead
|
||||||
|
|
||||||
dbPath <- makeDbPath h
|
dbPath <- makeDbPath remote
|
||||||
|
|
||||||
trace $ "dbPath" <+> pretty dbPath
|
|
||||||
|
|
||||||
db <- dbEnv dbPath
|
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
|
-- NOTE: just-for-test-new-non-empty-push-to-another-branch-112
|
||||||
ooo <- gitListAllObjects <&> filter (not . (`HashSet.member` skip))
|
|
||||||
|
|
||||||
cached0 <- withDB db stateGetAllDeps
|
-- FIXME: may-blow-on-huge-repo-export
|
||||||
let cached = HashMap.fromListWith (<>) [ (k, [v]) | (k,v) <- cached0 ]
|
types <- gitGetObjectTypeMany entries <&> Map.fromList
|
||||||
let lookup h = pure $ HashMap.lookup h cached & fromMaybe mempty
|
|
||||||
|
|
||||||
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
|
trace "MAKING OBJECTS LOG"
|
||||||
mon1 <- newProgressMonitor "storing dependencies" sz
|
|
||||||
|
|
||||||
withDB db $ transactional do
|
let fname = [qc|{pretty val}.data|]
|
||||||
for_ allDeps $ \(obj,dep) -> do
|
|
||||||
updateProgress mon1 1
|
|
||||||
stateAddDep dep obj
|
|
||||||
|
|
||||||
deps <- withDB db $ do
|
runResourceT $ do
|
||||||
x <- forM refs $ stateGetDepsRec . snd
|
|
||||||
pure $ mconcat x
|
|
||||||
|
|
||||||
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
|
let fpath = dir </> fname
|
||||||
$ metaApp <> "type:" <+> "head" <> line
|
fh <- liftIO $ openBinaryFile fpath AppendMode
|
||||||
|
|
||||||
-- let gha = gitHashObject (GitObject Blob repoHead)
|
expMon <- newProgressMonitor "export objects" (length entries)
|
||||||
hh <- lift $ storeObject metaHead repoHeadStr `orDie` "cant save repo head"
|
|
||||||
|
|
||||||
mon3 <- newProgressMonitor "export objects from repo" (length deps)
|
enq <- liftIO newTQueueIO
|
||||||
|
|
||||||
for_ deps $ \d -> do
|
-- FIXME: export-wtf?
|
||||||
here <- stateGetHash d <&> isJust
|
|
||||||
-- FIXME: asap-check-if-objects-is-in-hbs2
|
|
||||||
unless here do
|
|
||||||
lbs <- gitReadObject Nothing d
|
|
||||||
|
|
||||||
-- TODO: why-not-default-blob
|
aread <- async $ do
|
||||||
-- anything is blob
|
for_ entries $ \d -> do
|
||||||
tp <- gitGetObjectType d <&> fromMaybe Blob --
|
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
|
liftIO $ atomically $ writeTQueue enq Nothing
|
||||||
$ metaApp
|
|
||||||
<> "type:" <+> pretty tp <+> pretty d
|
|
||||||
<> line
|
|
||||||
|
|
||||||
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
|
mapM_ wait [aread]
|
||||||
statePutHash tp d hr
|
|
||||||
|
|
||||||
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
|
let ha = gitHashObject (GitObject Blob repoHeadStr)
|
||||||
-- FIXME: progress-indicator
|
let headEntry = GitLogEntry GitLogEntryHead (Just ha) ( fromIntegral $ LBS.length repoHeadStr )
|
||||||
root <- makeMerkle 0 pt $ \(ha,_,bss) -> do
|
gitRepoLogWriteEntry fh headEntry repoHeadStr
|
||||||
liftIO $ atomically $ writeTQueue tobj (ha,bss)
|
|
||||||
|
|
||||||
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
|
trace "STORING PUSH LOG"
|
||||||
updateProgress mon2 1
|
|
||||||
here <- lift $ getBlockSize (HashRef ha) <&> isJust
|
|
||||||
unless here do
|
|
||||||
void $ lift $ storeObject (fromString (show metaApp)) bss
|
|
||||||
|
|
||||||
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
|
trace $ "PUSH LOG HASH: " <+> pretty logMerkle
|
||||||
-- FIXME: same-transaction-different-seqno
|
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
|
pure logMerkle
|
||||||
pause @'Seconds 20
|
|
||||||
shutUp
|
|
||||||
die $ show $ pretty "No reference appeared for" <+> pretty h
|
|
||||||
|
|
||||||
wmon <- newProgressMonitor "waiting for ref" 20
|
runExport :: forall m . (MonadIO m, MonadUnliftIO m, MonadCatch m, HasProgress (App m))
|
||||||
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))
|
|
||||||
=> Maybe FilePath -> RepoRef -> App m ()
|
=> Maybe FilePath -> RepoRef -> App m ()
|
||||||
runExport fp h = do
|
runExport fp repo = do
|
||||||
|
|
||||||
|
|
||||||
liftIO $ putDoc $
|
liftIO $ putDoc $
|
||||||
line
|
line
|
||||||
<> green "Exporting to reflog" <+> pretty (AsBase58 h)
|
<> green "Exporting to reflog" <+> pretty (AsBase58 repo)
|
||||||
<> section
|
<> section
|
||||||
<> "it may take some time on the first run"
|
<> "it may take some time on the first run"
|
||||||
<> section
|
<> section
|
||||||
|
|
@ -234,16 +287,20 @@ runExport fp h = do
|
||||||
|
|
||||||
fullHead <- gitHeadFullName headBranch
|
fullHead <- gitHeadFullName headBranch
|
||||||
|
|
||||||
debug $ "HEAD" <+> pretty fullHead
|
-- debug $ "HEAD" <+> pretty fullHead
|
||||||
|
|
||||||
let repoHead = RepoHead (Just fullHead)
|
-- let repoHead = RepoHead (Just fullHead)
|
||||||
(HashMap.fromList refs)
|
-- (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
|
shutUp
|
||||||
|
|
||||||
|
|
@ -251,7 +308,6 @@ runExport fp h = do
|
||||||
cfgPath <- configPath cwd
|
cfgPath <- configPath cwd
|
||||||
let krf = fromMaybe "keyring-file" fp & takeFileName
|
let krf = fromMaybe "keyring-file" fp & takeFileName
|
||||||
|
|
||||||
|
|
||||||
liftIO $ putStrLn ""
|
liftIO $ putStrLn ""
|
||||||
liftIO $ putDoc $
|
liftIO $ putDoc $
|
||||||
"exported" <+> pretty hhh
|
"exported" <+> pretty hhh
|
||||||
|
|
@ -269,7 +325,7 @@ runExport fp h = do
|
||||||
<> section
|
<> section
|
||||||
<> green "Add git remote:"
|
<> green "Add git remote:"
|
||||||
<> section
|
<> section
|
||||||
<> pretty [qc|git remote add remotename hbs2://{pretty h}|]
|
<> pretty [qc|git remote add remotename hbs2://{pretty repo}|]
|
||||||
<> section
|
<> section
|
||||||
<> green "Work with git as usual:"
|
<> green "Work with git as usual:"
|
||||||
<> section
|
<> 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 Text.InterpolatedString.Perl6 (qc)
|
||||||
import HBS2.Data.Detect hiding (Blob)
|
import HBS2.Data.Detect hiding (Blob)
|
||||||
|
|
||||||
import Data.Config.Suckless
|
|
||||||
|
|
||||||
import HBS2.Git.Local
|
import HBS2.Git.Local
|
||||||
|
import HBS2Git.GitRepoLog
|
||||||
import HBS2Git.App
|
import HBS2Git.App
|
||||||
import HBS2Git.State
|
import HBS2Git.State
|
||||||
|
import HBS2.Git.Local.CLI
|
||||||
|
|
||||||
|
import Data.Fixed
|
||||||
import Control.Monad.Trans.Maybe
|
import Control.Monad.Trans.Maybe
|
||||||
import Control.Concurrent.STM
|
import Control.Concurrent.STM
|
||||||
import Control.Concurrent.STM.TQueue qualified as Q
|
import Control.Concurrent.STM.TQueue qualified as Q
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import Data.Foldable (for_)
|
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.Text qualified as Text
|
import Data.ByteString.Lazy.Char8 qualified as LBS
|
||||||
import Data.ByteString.Lazy qualified as LBS
|
|
||||||
import Lens.Micro.Platform
|
import Lens.Micro.Platform
|
||||||
-- import System.Exit
|
import Data.Set qualified as Set
|
||||||
import Codec.Serialise
|
import Codec.Serialise
|
||||||
import Control.Monad.Catch
|
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 =
|
data RunImportOpts =
|
||||||
RunImportOpts
|
RunImportOpts
|
||||||
|
|
@ -42,123 +47,177 @@ makeLenses 'RunImportOpts
|
||||||
isRunImportDry :: RunImportOpts -> Bool
|
isRunImportDry :: RunImportOpts -> Bool
|
||||||
isRunImportDry o = view runImportDry o == Just True
|
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
|
walkHashes q h = walkMerkle h (readBlock . HashRef) $ \(hr :: Either (Hash HbSync) [HashRef]) -> do
|
||||||
case hr of
|
case hr of
|
||||||
Left hx -> die $ show $ pretty "missed block:" <+> pretty hx
|
Left hx -> die $ show $ pretty "missed block:" <+> pretty hx
|
||||||
Right (hrr :: [HashRef]) -> do
|
Right (hrr :: [HashRef]) -> do
|
||||||
forM_ hrr $ liftIO . atomically . Q.writeTQueue q
|
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
|
importRefLogNew force ref = runResourceT do
|
||||||
walkHashes logQ (fromHashRef logRoot)
|
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
|
when (not done || force) do
|
||||||
debug $ "MISSED BLOCK" <+> pretty e
|
|
||||||
|
|
||||||
runMaybeT $ do
|
logQ <- liftIO newTQueueIO
|
||||||
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
|
|
||||||
|
|
||||||
new <- withDB db stateGetHead <&> isNothing
|
lift $ walkHashes logQ (fromHashRef logRoot)
|
||||||
|
|
||||||
when new do
|
let notSkip n = force || not (Set.member n trans)
|
||||||
pure ()
|
entries <- liftIO $ atomically $ flushTQueue logQ <&> filter notSkip
|
||||||
|
|
||||||
importObjects :: (MonadIO m, MonadCatch m, HasCatAPI m) => DBEnv -> HashRef -> m ()
|
pCommit <- liftIO $ startGitHashObject Commit
|
||||||
importObjects db root = do
|
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?
|
missed <- lift $ readBlock e <&> isNothing
|
||||||
hdData <- readBlock hd `orDie` "empty head block"
|
|
||||||
|
|
||||||
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
|
runMaybeT $ do
|
||||||
[ True
|
bs <- MaybeT $ lift $ readBlock e
|
||||||
| ListVal @C (Key "application:" [SymbolVal "hbs2-git"]) <- sy
|
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
|
here <- withDB db $ stateGetLogImported h
|
||||||
[ True
|
|
||||||
| ListVal @C (Key "type:" [SymbolVal "head"]) <- syn
|
|
||||||
]
|
|
||||||
|
|
||||||
unless ( app syn && hdd ) do
|
unless (here && not force) do
|
||||||
liftIO $ die "invalid head block meta"
|
|
||||||
|
|
||||||
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
|
let pref = take 16 (show (pretty e))
|
||||||
statePutImported root hd
|
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
|
GitLogEntryBlob -> do
|
||||||
let fromRec t = Just . (t,) . fromTxt
|
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
|
GitLogEntryTree -> do
|
||||||
["type:", "blob", x] -> pure $ fromRec Blob x
|
trace $ "logobject" <+> pretty h <+> "tree" <+> pretty (view gitLogEntryHash entry)
|
||||||
["type:", "commit", x] -> pure $ fromRec Commit x
|
hx <- pure (view gitLogEntryHash entry) `orDie` [qc|empty git hash|]
|
||||||
["type:", "tree", x] -> pure $ fromRec Tree x
|
writeIfNew hTrees dir hx (GitObject Tree lbs)
|
||||||
_ -> pure Nothing
|
statePutLogObject (h, Tree, hx)
|
||||||
|
|
||||||
case catMaybes hm of
|
GitLogContext -> do
|
||||||
[(t,sha1)] -> do
|
trace $ "logobject" <+> pretty h <+> "context" <+> pretty (view gitLogEntryHash entry)
|
||||||
trace $ "statePutHash" <+> pretty t <+> pretty sha1
|
|
||||||
|
|
||||||
-- FIXME: return-dry?
|
let co = fromMaybe mempty $ deserialiseOrFail @GitLogContextEntry
|
||||||
statePutHash t sha1 r
|
<$> 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 HBS2Git.App
|
||||||
import HBS2.Data.Types.Refs (HashRef)
|
import HBS2.Data.Types.Refs (HashRef)
|
||||||
|
|
||||||
|
import HBS2.System.Logger.Simple
|
||||||
import HBS2.Git.Local.CLI
|
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.Functor
|
||||||
import Data.Text qualified as Text
|
import Data.Text qualified as Text
|
||||||
import Data.Traversable
|
import Data.Traversable
|
||||||
import Prettyprinter.Render.Terminal
|
import Prettyprinter.Render.Terminal
|
||||||
|
import Control.Monad.IO.Unlift
|
||||||
|
import Control.Monad.Catch
|
||||||
|
import System.IO (stdout)
|
||||||
|
|
||||||
data AsRemoteEntry = AsRemoteEntry
|
data AsRemoteEntry = AsRemoteEntry
|
||||||
{ remoteName :: Text,
|
{ remoteName :: Text,
|
||||||
|
|
@ -65,6 +73,21 @@ runListRefs = do
|
||||||
where
|
where
|
||||||
isHbs2 (_, b) = Text.isPrefixOf hbs2Prefix b
|
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 :: (MonadIO m, HasCatAPI m) => Text -> m (Maybe HashRef)
|
||||||
getRefVal url =
|
getRefVal url =
|
||||||
case Text.stripPrefix hbs2Prefix url of
|
case Text.stripPrefix hbs2Prefix url of
|
||||||
|
|
|
||||||
|
|
@ -27,9 +27,17 @@ import Control.Monad.Catch
|
||||||
import Control.Concurrent.STM
|
import Control.Concurrent.STM
|
||||||
import System.IO.Unsafe
|
import System.IO.Unsafe
|
||||||
|
|
||||||
|
-- FIXME: move-orphans-to-separate-module
|
||||||
|
|
||||||
instance ToField GitHash where
|
instance ToField GitHash where
|
||||||
toField h = toField (show $ pretty h)
|
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
|
instance FromField GitHash where
|
||||||
fromField = fmap fromString . fromField @String
|
fromField = fmap fromString . fromField @String
|
||||||
|
|
||||||
|
|
@ -39,7 +47,6 @@ instance FromField GitObjectType where
|
||||||
instance ToField HashRef where
|
instance ToField HashRef where
|
||||||
toField h = toField (show $ pretty h)
|
toField h = toField (show $ pretty h)
|
||||||
|
|
||||||
|
|
||||||
instance ToField GitObjectType where
|
instance ToField GitObjectType where
|
||||||
toField h = toField (show $ pretty h)
|
toField h = toField (show $ pretty h)
|
||||||
|
|
||||||
|
|
@ -90,54 +97,97 @@ stateInit :: MonadIO m => DB m ()
|
||||||
stateInit = do
|
stateInit = do
|
||||||
conn <- ask
|
conn <- ask
|
||||||
liftIO $ execute_ conn [qc|
|
liftIO $ execute_ conn [qc|
|
||||||
create table if not exists dep
|
create table if not exists logrefval
|
||||||
( object text not null
|
( loghash text not null
|
||||||
, parent text not null
|
, refname text not null
|
||||||
, primary key (object, parent)
|
, refval text not null
|
||||||
|
, primary key (loghash, refname)
|
||||||
)
|
)
|
||||||
|]
|
|]
|
||||||
|
|
||||||
liftIO $ execute_ conn [qc|
|
liftIO $ execute_ conn [qc|
|
||||||
create table if not exists object
|
create table if not exists logobject
|
||||||
( githash text not null
|
( loghash text not null
|
||||||
, hash text not null unique
|
|
||||||
, type text not null
|
, type text not null
|
||||||
, primary key (githash,hash)
|
, githash text not null
|
||||||
|
, primary key (loghash, githash)
|
||||||
)
|
)
|
||||||
|]
|
|]
|
||||||
|
|
||||||
liftIO $ execute_ conn [qc|
|
liftIO $ execute_ conn [qc|
|
||||||
create table if not exists head
|
create table if not exists logcommitparent
|
||||||
( key text not null primary key
|
( kommit text not null
|
||||||
, hash text not null unique
|
, parent text not null
|
||||||
|
, primary key (kommit,parent)
|
||||||
)
|
)
|
||||||
|]
|
|]
|
||||||
|
|
||||||
liftIO $ execute_ conn [qc|
|
liftIO $ execute_ conn [qc|
|
||||||
create table if not exists imported
|
create table if not exists logimported
|
||||||
( seq integer primary key autoincrement
|
( hash text not null
|
||||||
, ts DATE DEFAULT (datetime('now','localtime'))
|
, primary key (hash)
|
||||||
, merkle text not null
|
|
||||||
, head text not null
|
|
||||||
, unique (merkle,head)
|
|
||||||
)
|
)
|
||||||
|]
|
|]
|
||||||
|
|
||||||
liftIO $ execute_ conn [qc|
|
liftIO $ execute_ conn [qc|
|
||||||
create table if not exists reflog
|
create table if not exists refimported
|
||||||
( seq integer primary key
|
( hash text not null
|
||||||
, ts DATE DEFAULT (datetime('now','localtime'))
|
, timestamp DATETIME DEFAULT CURRENT_TIMESTAMP
|
||||||
, merkle text not null
|
, primary key (hash)
|
||||||
, unique (merkle)
|
|
||||||
)
|
)
|
||||||
|]
|
|]
|
||||||
|
|
||||||
liftIO $ execute_ conn [qc|
|
liftIO $ execute_ conn [qc|
|
||||||
create table if not exists exported
|
create table if not exists tranimported
|
||||||
( githash text not null primary key
|
( 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 =
|
newtype Savepoint =
|
||||||
Savepoint String
|
Savepoint String
|
||||||
|
|
@ -189,179 +239,157 @@ transactional action = do
|
||||||
-- состояние репозитория
|
-- состояние репозитория
|
||||||
|
|
||||||
|
|
||||||
statePutExported :: MonadIO m => GitHash -> DB m ()
|
statePutLogRefVal :: MonadIO m => (HashRef, GitRef, GitHash) -> DB m ()
|
||||||
statePutExported h = do
|
statePutLogRefVal row = do
|
||||||
conn <- ask
|
conn <- ask
|
||||||
liftIO $ execute conn [qc|
|
liftIO $ execute conn [qc|
|
||||||
insert into exported (githash) values(?)
|
insert into logrefval (loghash,refname,refval) values(?,?,?)
|
||||||
on conflict (githash) do nothing
|
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)
|
|] (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
|
conn <- ask
|
||||||
liftIO $ query_ conn [qc|
|
liftIO $ query_ conn [qc|
|
||||||
select githash from exported
|
select distinct(githash) from logobject where type = 'commit'
|
||||||
|] <&> fmap fromOnly
|
|] <&> fmap fromOnly
|
||||||
|
|
||||||
statePutImported :: MonadIO m => HashRef -> HashRef -> DB m ()
|
stateGetActualRefs :: MonadIO m => DB m [(GitRef, GitHash)]
|
||||||
statePutImported merkle hd = do
|
stateGetActualRefs = 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
|
|
||||||
conn <- ask
|
conn <- ask
|
||||||
liftIO $ query_ conn [qc|
|
liftIO $ query_ conn [qc|
|
||||||
select seq, merkle from reflog
|
select refname,refval from v_refval_actual
|
||||||
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 = ?
|
|
||||||
|]
|
|]
|
||||||
|
|
||||||
|
stateGetActualRefValue :: MonadIO m => GitRef -> DB m (Maybe GitHash)
|
||||||
stateDepFilterAll :: MonadIO m => DB m [GitHash]
|
stateGetActualRefValue ref = do
|
||||||
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
|
|
||||||
conn <- ask
|
conn <- ask
|
||||||
liftIO $ query conn [qc|
|
liftIO $ query conn [qc|
|
||||||
select object from dep where parent = ?
|
select refval from v_refval_actual
|
||||||
|] (Only h) <&> fmap fromOnly
|
where refname = ?
|
||||||
|
|] (Only ref) <&> fmap fromOnly . listToMaybe
|
||||||
|
|
||||||
|
stateUpdateCommitDepths :: MonadIO m => DB m ()
|
||||||
statePutHash :: MonadIO m => GitObjectType -> GitHash -> HashRef -> DB m ()
|
stateUpdateCommitDepths = do
|
||||||
statePutHash t g h = do
|
|
||||||
conn <- ask
|
conn <- ask
|
||||||
liftIO $ execute conn [qc|
|
sp <- savepointNew
|
||||||
insert into object (githash,hash,type) values(?,?,?)
|
savepointBegin sp
|
||||||
on conflict (githash,hash) do nothing
|
-- TODO: check-if-delete-logcommitdepth-is-needed
|
||||||
|] (g,h,t)
|
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)
|
UNION ALL
|
||||||
stateGetHash h = do
|
|
||||||
conn <- ask
|
|
||||||
liftIO $ query conn [qc|
|
|
||||||
select hash from object where githash = ?
|
|
||||||
limit 1
|
|
||||||
|] (Only h) <&> fmap fromOnly <&> listToMaybe
|
|
||||||
|
|
||||||
|
SELECT
|
||||||
stateGetGitHash :: MonadIO m => HashRef -> DB m (Maybe GitHash)
|
p.kommit,
|
||||||
stateGetGitHash h = do
|
d.level + 1
|
||||||
conn <- ask
|
FROM logcommitparent p
|
||||||
liftIO $ query conn [qc|
|
INNER JOIN depths d ON p.parent = d.kommit
|
||||||
select githash from object where hash = ?
|
)
|
||||||
limit 1
|
SELECT
|
||||||
|] (Only h) <&> fmap fromOnly <&> listToMaybe
|
kommit,
|
||||||
|
MAX(level)
|
||||||
stateGetAllHashes :: MonadIO m => DB m [HashRef]
|
FROM depths
|
||||||
stateGetAllHashes = do
|
WHERE kommit NOT IN (SELECT kommit FROM logcommitdepth)
|
||||||
conn <- ask
|
GROUP BY kommit;
|
||||||
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
|
|
||||||
|]
|
|]
|
||||||
|
savepointRelease sp
|
||||||
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
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -15,6 +15,8 @@ import HBS2.Data.Types.Refs
|
||||||
import HBS2.Net.Proto.Types
|
import HBS2.Net.Proto.Types
|
||||||
import HBS2.Net.Auth.Credentials
|
import HBS2.Net.Auth.Credentials
|
||||||
|
|
||||||
|
import HBS2.System.Logger.Simple
|
||||||
|
|
||||||
import Data.Config.Suckless
|
import Data.Config.Suckless
|
||||||
|
|
||||||
import System.ProgressBar
|
import System.ProgressBar
|
||||||
|
|
@ -24,8 +26,11 @@ import Control.Applicative
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import Database.SQLite.Simple (Connection)
|
import Database.SQLite.Simple (Connection)
|
||||||
|
import Data.Char (isSpace)
|
||||||
import Data.Set qualified as Set
|
import Data.Set qualified as Set
|
||||||
import Data.Set (Set)
|
import Data.Set (Set)
|
||||||
|
import Data.List qualified as List
|
||||||
|
import Data.Maybe
|
||||||
import Lens.Micro.Platform
|
import Lens.Micro.Platform
|
||||||
import Data.HashMap.Strict (HashMap)
|
import Data.HashMap.Strict (HashMap)
|
||||||
import Data.HashMap.Strict qualified as HashMap
|
import Data.HashMap.Strict qualified as HashMap
|
||||||
|
|
@ -35,6 +40,9 @@ import System.IO qualified as IO
|
||||||
import System.IO (Handle)
|
import System.IO (Handle)
|
||||||
import Data.Kind
|
import Data.Kind
|
||||||
import Control.Monad.Catch
|
import Control.Monad.Catch
|
||||||
|
import Control.Monad.IO.Unlift
|
||||||
|
|
||||||
|
import System.TimeIt
|
||||||
|
|
||||||
-- FIXME: remove-udp-hardcode-asap
|
-- FIXME: remove-udp-hardcode-asap
|
||||||
type Schema = HBS2Basic
|
type Schema = HBS2Basic
|
||||||
|
|
@ -77,7 +85,7 @@ data RepoHead =
|
||||||
{ _repoHEAD :: Maybe GitRef
|
{ _repoHEAD :: Maybe GitRef
|
||||||
, _repoHeads :: HashMap GitRef GitHash
|
, _repoHeads :: HashMap GitRef GitHash
|
||||||
}
|
}
|
||||||
deriving stock (Generic)
|
deriving stock (Generic,Show)
|
||||||
|
|
||||||
makeLenses 'RepoHead
|
makeLenses 'RepoHead
|
||||||
|
|
||||||
|
|
@ -90,17 +98,40 @@ instance Semigroup RepoHead where
|
||||||
& set repoHeads ( view repoHeads a <> view repoHeads b )
|
& set repoHeads ( view repoHeads a <> view repoHeads b )
|
||||||
|
|
||||||
instance Pretty (AsGitRefsFile RepoHead) where
|
instance Pretty (AsGitRefsFile RepoHead) where
|
||||||
pretty (AsGitRefsFile h) = vcat (hhead : fmap fmt els)
|
pretty (AsGitRefsFile h) = hhead <> vcat (fmap fmt els)
|
||||||
where
|
where
|
||||||
hhead = case view repoHEAD h of
|
hhead = case view repoHEAD h of
|
||||||
Nothing -> mempty
|
Nothing -> mempty
|
||||||
Just r -> "@" <> pretty r <+> "HEAD"
|
Just r -> "@" <> pretty r <+> "HEAD" <> line
|
||||||
|
|
||||||
els = HashMap.toList (view repoHeads h)
|
els = HashMap.toList (view repoHeads h)
|
||||||
fmt (r,hx) = pretty hx <+> pretty (normalizeRef r)
|
fmt (r,hx) = pretty hx <+> pretty (normalizeRef r)
|
||||||
|
|
||||||
|
|
||||||
instance Serialise RepoHead
|
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 :: forall {c}. Id -> [Syntax c] -> [Syntax c]
|
||||||
pattern Key n ns <- SymbolVal n : ns
|
pattern Key n ns <- SymbolVal n : ns
|
||||||
|
|
@ -136,6 +167,12 @@ instance (HasCatAPI m, MonadIO m) => HasCatAPI (MaybeT m) where
|
||||||
getHttpPutAPI = lift getHttpPutAPI
|
getHttpPutAPI = lift getHttpPutAPI
|
||||||
getHttpRefLogGetAPI = lift getHttpRefLogGetAPI
|
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
|
class Monad m => HasCfgKey a b m where
|
||||||
-- type family CfgValue a :: Type
|
-- type family CfgValue a :: Type
|
||||||
key :: Id
|
key :: Id
|
||||||
|
|
@ -155,6 +192,8 @@ newtype App m a =
|
||||||
, MonadReader AppEnv
|
, MonadReader AppEnv
|
||||||
, MonadThrow
|
, MonadThrow
|
||||||
, MonadCatch
|
, MonadCatch
|
||||||
|
, MonadUnliftIO
|
||||||
|
, MonadTrans
|
||||||
)
|
)
|
||||||
|
|
||||||
instance MonadIO m => HasConf (App m) where
|
instance MonadIO m => HasConf (App m) where
|
||||||
|
|
@ -194,3 +233,9 @@ die :: MonadIO m => String -> m a
|
||||||
die s = do
|
die s = do
|
||||||
liftIO $ Exit.die s
|
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