From 09508db720ee31cd2d9b8813d02a844819e3dd7b Mon Sep 17 00:00:00 2001 From: voidlizard Date: Mon, 7 Oct 2024 06:29:55 +0300 Subject: [PATCH] wip, mailboxes --- docs/papers/Makefile | 14 +- docs/papers/hbs2-mailbox.tex | 758 ++++++++++++++++++ hbs2-cli/app/Main.hs | 2 + hbs2-cli/hbs2-cli.cabal | 2 + hbs2-cli/lib/HBS2/CLI/Run/Mailbox.hs | 104 +++ hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs | 23 +- hbs2-git-dashboard/app/GitDashBoard.hs | 61 +- .../HBS2/Git/DashBoard/State.hs | 107 ++- .../HBS2/Git/DashBoard/State/Index/Peer.hs | 24 +- .../HBS2/Git/DashBoard/Types.hs | 8 +- .../HBS2/Git/Web/Html/Fixme.hs | 2 + .../HBS2/Git/Web/Html/Issue.hs | 2 + hbs2-git-dashboard/hbs2-git-dashboard.cabal | 1 + hbs2-peer/hbs2-peer.cabal | 3 + hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs | 68 ++ .../lib/HBS2/Peer/Proto/Mailbox/Message.hs | 206 +++++ .../lib/HBS2/Peer/Proto/Mailbox/Types.hs | 60 ++ 17 files changed, 1381 insertions(+), 64 deletions(-) create mode 100644 docs/papers/hbs2-mailbox.tex create mode 100644 hbs2-cli/lib/HBS2/CLI/Run/Mailbox.hs create mode 100644 hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs create mode 100644 hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Message.hs create mode 100644 hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs diff --git a/docs/papers/Makefile b/docs/papers/Makefile index 9982299e..525e50cd 100644 --- a/docs/papers/Makefile +++ b/docs/papers/Makefile @@ -5,7 +5,7 @@ $(basename $(1))-$(REV)$(suffix $(1)) endef -all: hbs2-git-problem hbs2-git-new-repo hbs2-git-doc +all: hbs2-git-problem hbs2-git-new-repo hbs2-git-doc hbs2-mailbox .PHONY: all clean @@ -20,13 +20,23 @@ hbs2-git-new-repo: hbs2-git-new-repo.pdf hbs2-git-doc: hbs2-git-doc-0.24.1.pdf +hbs2-mailbox: hbs2-mailbox.pdf + publish-hbs2-git-doc: hbs2-git-doc-0.24.1.pdf $(eval TARGET := $(call make_target,$<)) $(eval HASH := $(shell hbs2 metadata create --hash --auto $(TARGET))) @echo Updating $(HBS2GITDOCLWW) $(HASH) hbs2-peer lwwref update -v $(HASH) $(HBS2GITDOCLWW) -publish: publish-hbs2-git-doc + +publish-hbs2-mailbox: hbs2-mailbox.pdf + @echo not implemented yet + # $(eval TARGET := $(call make_target,$<)) + # $(eval HASH := $(shell hbs2 metadata create --hash --auto $(TARGET))) + # @echo Updating $(HBS2GITDOCLWW) $(HASH) + # hbs2-peer lwwref update -v $(HASH) $(HBS2GITDOCLWW) + +publish: publish-hbs2-git-doc publish-hbs2-mailbox clean: rm -f *.aux *.log *.nav *.out *.snm *.vrb *.toc *.pdf diff --git a/docs/papers/hbs2-mailbox.tex b/docs/papers/hbs2-mailbox.tex new file mode 100644 index 00000000..64cd48d0 --- /dev/null +++ b/docs/papers/hbs2-mailbox.tex @@ -0,0 +1,758 @@ +% +\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}} +\newcommand{\Peer}{\term{peer}{пир}} +\newcommand{\Relay}{\term{relay}{Relay}} +\newcommand{\Acc}{\term{acc}{Accumulator}} +\newcommand{\Dude}{\term{dude}{Dude}} +\newcommand{\Mailbox}{\term{mailbox}{Mailbox}} +\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{Протокол <>} + +\begin{document} + +\maketitle + +\section{О документе} + +Документ рассматривает протокол доставки данных <> по паттерну $* +\rightarrow 1$ <> в P2P окружении, как подпротокола для hbs2-peer. + +Протокол предполагается к использованию в ситуациях, когда между +\term{actor}{акторами} нет общего авторизованного канала связи (в смысле +hbs2-peer). + +Протокол не подразумевает нахождения акторов постоянно онлайн. + +Протокол не подразумевает использования механизмов вроде DNS, сертификатов PKCS +и Authority, или каких-либо (скомпрометированных) централизованных сервисов. + +Протокол не подразумевает постоянной связности сети. + +Для адресации используются публичные ключи подписи. + +Для E2E шифрования используется механизм групповых ключей. + +Для упаковки и распространения данных используются примитивы hbs2-peer: +\term{block}{блоки}, \term{merkle}{(шифрованные) деревья Меркла} с метаданными, +и протоколы для работы с ними. + +Отличие от протоколов IMAP,SMTP,POP3 в том, что это другой протокол для другого +окружения и исходящий из других предпосылок. + +Теоретически, в качестве несложного упражнения, можно поднять сервер IMAP как +локальный фронтенд для hbs2-peer и тогда это будет IMAP-via-P2P. + +\section{Предпосылки} + +В текущей реализации HBS2 существуют следующие релевантные виды каналов +(протоколов,\term{ref}{ссылок}): + +\paragraph{RefLog:} + +Обеспечивает коммуникацию по паттерну $1 \rightarrow *$, то есть один -- ко +всем, канал распространяет сообщения одного автора. Пруфом записи является +подпись \term{ksign}{ключом подписи} автора. \term{peer}{Пиры} должны +подписаться на канал для его распространения, распространять канал (ссылку) +может любой любой подписанный на него \term{peer}{пир}, так как валидность +записей проверяется подписью автора. Канал является \term{GSET}{CRDT G-SET} +записей. + +Метафорой рефлога может являться твиттер-аккаунт либо канал в телеграме, с одним +писателем и множеством подписчиков. + + +\paragraph{RefChan:} + +Обеспечивает коммуникацию по паттерну ${A} \rightarrow {R}$, то есть определяет +множество \term{author}{авторов} $A$ и множество \term{reader}{читателей} $R$, и +пруфом записи является подпись \term{author}{автора}, а +\term{permission}{разрешением} на чтение --- опциональное шифрование сообщения +\term{GK0}{групповым ключом}, куда входят читатели $R$, то есть $GK = \{ k_i +\}_{i \in R}$, где каждый $k_i$ --- секретный ключ, зашифрованный публичным +ключом $r_i$ из множества $R$. + +Кроме того, \term{refchan}{RefChan} определяет множество пиров ${P}$, которые +могут отправлять сообщение в данный \term{refchan}{RefChan} и принимаются только +такие сообщения. + +Данное ограничение необходимо для борьбы с атакой Сивиллы в случае, если \Peer{} +игнорирует настройки ${A}$. + +Кроме того, у \term{refchan}{рефчана} есть владелец, который может менять +настройки $A,R$, а блок настроек представляет собой \term{lww}{CRDT LWW регистр} +со ссылкой на блок настроек, подписанный ключом владельца. + +Как видно, распространять сообщения из \term{refchan}{рефчана} могут только пиры +$p_i \in P$ + +То есть, распространять транзакции может кто угодно, т.к каждая транзакция +подписана ключом \term{peer}{пира}, но вот при запросе состояния будут +учитываться только ответы пиров $p_i \in P$. + +Метафорой \term{refchan}{рефчана} является модерируемый чат с ограниченным +множеством участников и администраторами. + +Таким образом, при наличии этих протоколов, мы можем + +\begin{enumerate} + +\item посылать сообщения от одного автора всему миру, то есть тем пирам, которые + слушают (подписаны) на данный рефлог или + +\item осуществлять коммуникацию между ограниченными множествами пиров и + авторов/читателей. + +\end{enumerate} + +Общим является то, что бы получать обновления рефлога или рефчана, мы (как пир) +должны быть на них \term{subscribed}{подписаны}, т.е мы должны знать, что такие +\term{ref}{ссылки} существуют и явно на них подписаться. + + +Возникает вопрос, как можно обеспечить коммуникацию между произвольными +\term{actor}{акторами} Алиса и Боб, у которых нет общего канала. + +Куда писать Алисе, что бы её сообщение достигло Боба? Рефчана, куда бы входили +бы и Алиса и Боб в общем случае еще не существует, канал связи отсутствует. + +Алиса может быть подписана на какую-то ссылку Боба, но Боб не подписан на каналы +Алисы. Или наоборот. + +Предлагается ввести новый протокол, \term{mailbox}{Mailbox}, который будет +обеспечивать коммуникацию по паттерну $ * \rightarrow 1 $, то есть кто угодно +может отправлять сообщения в почтовый ящик получателя. + +Получатель проверяет почтовый ящик и забирает оттуда сообщения. + +При этом обеспечивается отправка и доставка в условиях, когда \term{peer}{пиры} +получателя и отправителя не находятся онлайн всё время. + +Данный протокол может быть полезен при установлении канала связи (например, +создании общего рефчана), или просто оффлайн обмене сообщениями в условиях +необязательного наличия каналов, например, при рассылке патчей и пулл/мерж +реквестов в git или создании тикетов или для отсылки \textit{реакций}, в общем +--- в любом случае, когда между акторами нет какого-то прямого канала. + +Важным является то, что получатель подписан только на свои, известные ему +каналы, куда все (при выполнении определённых условий) могут отправлять +сообщения. + + +\section{Протокол} + +Протокол является подпротоколом \textit{hbs2-peer} и в отношении него верно всё, +что верно для семейства этих протоколов --- авторизация и аутентификация пиров, +черные и белые списки пиров, транспортное шифрование сообщений через ByPass и +так далее. + +Идентификаторами являются публичные ключи подписи и шифрования. + +Для e2e шифрования используется тот же механизм групповых ключей. + +Передаваемыми единицами являются либо короткие сообщения +\texttt{SmallEncryptedBlock} либо \term{merkle}{деревья Меркла} с шифрованием и +метаданными. + +Протокол использует примитивы \textit{hbs2-core} и \textit{hbs2-peer}, как +минимум: + +\begin{itemize} + \item[-] SignedBox + \item[-] SmallEncryptedBlock + \item[-] MerkleTree +\end{itemize} + +Протокол определяет служебные сообщения, специфичные для него, однако обмен +данными идёт через обычные протоколы (GetBlock,GetBlockSize). + +Короткие сообщения могут доставляться непосредственно через (сигнальные) +сообщения протокола. + +\subsection{Участники} + +\paragraph{Пир} Узел hbs2, поддерживающий данный протокол + +\paragraph{Актор} также \term{dude}{Dude}. Отправители и получатели сообщений. + +Требуется определить, что явлется идентификатором, или идентификаторами \Dude{}. + +\paragraph{Message} Сообщение. + +Определяется отправителем, получателем (получателями?), и содержимым. +Видится,что сообщения могут быть двух классов: \textit{маленькое}, где всё +сообщение вместе со служебной информацией помещается в один пакет и может быть +доставлено непосредственно через коммуникационный протокол (GOSSIP), и +\textit{большое}, когда \Peer{} поддерживающий данный протокол -- будет +выкачивать все ссылки на части сообщения (большой текст, аттачменты и т.п.) + +\paragraph{Mailbox} Единица хранения и распространения сообщений. + +Mailbox бывают видов \term{Relay}{Relay} и \term{Accumulator}{Accumulator}. + +Разница между ними в том, что \Relay{} просто принимает и выкачивает сообщения, +пришедшие по протоколу, и не пытается опрашивать соседей и объединять все +известные сообщения дла \Dude{} в общее множество. + +Назначание \Relay{} --- временное хранение сообщений, пока их не заберёт один из +\term{acc}{аккумуляторов}. \Mailbox{} \Relay{} занимает фиксированное, заранее +определенное место на диске + +Поскольку мы в общем не знаем, забрали ли сообщение или нет, видится так, что +\Relay{} организует ограниченную очередь сообщений, и при исчерпании лимита +места, отведённого под почтовый ящик -- просто удаляет наиболее старые сообщения +из очереди. + +Назначание \Acc{} -- хранить все сообщения для своего \Dude{}, т.е это его +<<распределённый почтовый аккаунт>>. + +То есть, \Acc{} образуют \term{GSET}{CRDT G-SET} сообщений, и постепенно +сходятся к одному значению (объединению всех сообщений всех \Acc{}). + +Очевидно, нужно предусмотреть или записи вида \textit{Tomb}, или иной способ +удаления сообщений, например, через команду протокола. + +\Acc{} опрашивает всех соседей, получает ссылки на \term{merkle}{деревья~Меркла} +сообщений, выкачивает сообщения и объединяет их в общее множество. + +\subsection{Примеры} + +\subsection*{Минимальная конфигурация} + +Два пира при условии наличия прямой сетевой доступности в обоих направлениях. + +\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 + }, + ] + + \node[box,minimum height=2cm,label={below:{hbs2-peer}}] (dudeA) {{\underline{Dude~A}}\\ \Acc{}}; + \node[ box + , minimum height=2cm + , label={below:{hbs2-peer}} + , right=2.5cm of dudeA + ] (dudeB) {{\underline{Dude~B}}\\ \Acc{}}; + + \draw[<->] (dudeA) -- (dudeB) + node[midway,above] {Mailbox} + node[midway,below] {GOSSIP}; + + +\end{tikzpicture} +\caption{минимальная конфигурация} +\end{figure} + +\pagebreak + +\begin{itemize} + \item[-] Обмен сообщениями возможен только при одновременном нахождении обоих + пиров онлайн и наличия между ними связи + + \item[-] При потере узла Dude~A или Dude~B теряют все адресованные им сообщения +\end{itemize} + + +\subsection*{Примерно оптимальная конфигурация} + +\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 + }, + ] + + \node[box,minimum height=2cm,label={below:{hbs2-peer}}] (dudeA) {{\underline{Dude~A}}\\ \Acc{}}; + + \node[ box + , minimum height=2cm + , label={below:{hbs2-peer}} + , right=1.5cm of dudeA + ] (relayA) {{\underline{Relay~1}}\\ \Relay{}}; + + \node[ box + , minimum height=2cm + , label={below:{hbs2-peer}} + , below=1.5cm of dudeA + ] (A1) {{\underline{A1}}\\ \Acc{}}; + + \node[ box + , minimum height=2cm + , label={below:{hbs2-peer}} + , right=1.5cm of relayA + ] (relayB) {{\underline{Relay~2}}\\ \Relay{}}; + + \node[ box + , minimum height=2cm + , label={below:{hbs2-peer}} + , right=1.5cm of relayB + ] (dudeB) {{\underline{Dude~B}}\\ \Acc{}}; + + \node[ box + , minimum height=2cm + , label={below:{hbs2-peer}} + , below=1.5cm of dudeB + ] (B1) {{\underline{B1}}\\ \Acc{}}; + + \node[ box, circle, draw, dashed + , minimum size=2.5cm + , minimum height=2.5cm + , yshift=-0.5cm + , right=2.75cm of A1 + , label={below: protocol} + ] (gossip) {{\underline{Mailbox}}\\GOSSIP }; + + + \draw[<->,dashed] (dudeA) -- (relayA); + \draw[<->,dashed] (dudeB) -- (relayB); + \draw[<->,dashed] (dudeA) -- (A1); + \draw[<->,dashed] (dudeB) -- (B1); + + \draw[<->,dashed] (dudeA) -- (gossip); + \draw[<->,dashed] (dudeB) -- (gossip); + \draw[<->,dashed] (relayA) -- (gossip); + \draw[<->,dashed] (relayB) -- (gossip); + \draw[<->,dashed] (A1) -- (gossip); + \draw[<->,dashed] (B1) -- (gossip); + +\end{tikzpicture} +\caption{Примерно оптимальная конфигурация} +\end{figure} + +\begin{itemize} +\item[-] Каждый Dude имеет некоторое количество Mailbox типа \Acc{} и \Relay{}. + +\item[-] Часть из них находится на пирах, которые большую часть времени + доступны. + +\item[-] Часть доступных пиров имеет между собой прямую связь по GOSSIP. + +\item[-] Не требуется полная связность сети между Dude~A и Dude~B, достаточно, + что бы была цепочка соединений, доступных хотя бы время от времени. + +\item[-] Сообщения Dude~A и Dude~B реплицированы между узлами типа \Acc{} (для + каждого Dude -- свои мейлбоксы, естественно) и сообщения будут утрачены + только в случае полной одновременной утраты всех узлов такого типа или если + на всех этих узлах будут удалены \term{mailbox}{мейлбоксы} для Dude~A или + Dude~B. +\end{itemize} + +\pagebreak + +\section{Структуры данных} + +\subsection{Message} + +\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 + }, + ] + + \node[ draw + , minimum height=2cm + , minimum width=12cm + % , label={[yshift=5mm]south:SignedBox} + ] (msg) {}; + + + \node[draw,below=5mm of msg.north west,anchor=north west,xshift=2mm + ] (sender) {$Sender$}; + + \node[above=1.5cm of sender.north west, anchor = south west, text width=1.8cm] (label1) {Публичный ключ отправителя}; + + \draw[->] (label1.south) -- ($(sender.north west)!(label1.south)!(sender.north east)$); + + % \node[draw,below=5mm of msg.north west,anchor=north west,xshift=2mm + \node[draw,right=5mm of sender + ] (flags) {$\{F\}$}; + + \node[draw,right=1mm of flags + ] (rcpt) {$\{Recipients\}$}; + + \node[draw,right=1mm of rcpt + ] (gk) {$GK^*$}; + + \node[draw,right=1mm of gk + ] (ref) {$\{Ref\}$}; + + \node[draw,right=1mm of ref,minimum width=4cm + ] (payload) {$Payload$}; + + + \node[above=1.5cm of payload.north west, anchor = south west, text width=2cm] + (labelP) {SmallEncryptedBlock}; + + \draw[->] (labelP.south) -- ($(payload.north west)!(labelP.south)!(payload.north east)$); + + \node[ draw + , above=2mm of flags.north west, xshift=-2.5mm + , anchor=north west + , minimum width = 10cm + , minimum height = 1.1cm + , label={[yshift=-1mm]south:SignedBox} + ] (box) {}; + + +\end{tikzpicture} +\caption{Структура сообщения} +\end{figure} + +\paragraph{Sender:} Публичный (адрес) ключ подписи отправителя + +\paragraph{F:} Флаги (опции) сообщения. Например, TTL. TBD. + +\paragraph{Recipients:} Публичные ключи подписи (адреса) получателей + +Так как \term{peer}{пиру} нужно знать, в какой \Mailbox{} положить сообщение + + +\paragraph{GK:} (Опционально) групповой ключ шифрования, которым зашифровано +сообщение + +\paragraph{Refs:} Ссылки на части сообщения, (зашифрованные) +\term{merkle}{деревья} с метаданными + +\paragraph{Payload:} Непосредственное короткое сообщение + + +\section{Сообщения протокола} + +\subsection{SEND} + +Пир~A \Dude~A посылает сообщение \Dude~B или списку \Dude{} через Пир~X. + +Если Пир~X не поддерживает протокол -- то сообщение не обрабатывается. + +Если Пир~X поддерживает протокол -- то сообщение пересылается соседям Пир~X. + +Если Пир~X имеет \Mailbox{} для одного из получателей (\Dude{}) --- то сообщение +кладётся в \Mailbox{}. + +Если это \Acc{} -- то просто кладётся. Если задана квота на размер и размер +\Mailbox{} превышен (переполнен), то сообщение может игнорироваться. + +Если это \Relay{} то кладётся, если квота размера не превышена. Если превышена, +то удаляются наиболее старые сообщения, пока не освободится достаточно места на +диске. + +Если не удалось, то сообщение удаляется. + +Если сообщение содержит хэш-ссылки (вложения), то они скачиваются в соответствии +с политиками (размеры,etc). + +Каждая ссылка сообщения проверяется на целостность, скачивание продолжается, +пока оно не станет целостным или до тех пор, пока (определяется политикой). + +Если пир \Dude~A не имеет блоков, на которые ссылается сообщениe --- то мы +прекращаем скачивать зависимости. Возможно, такое сообщение стоит дропнуть. + +Авторизация: сообщение SEND подписано \Dude~A, отправителем сообщения. + +\subsection{CHECK-MAIL} + +Получатель (владелец \Mailbox{}) запрашивает хэш \term{merkle}{дерева Меркла} сообщений, +содержащихся в \Mailbox{}. + +Авторизация: сообщение SEND подписано \Dude --- владельцем \Mailbox{}. + +\subsection{MAIL-STATUS} + +Ответ на сообщение \texttt{CHECK-MAIL}, содержит хэш ссылку +\term{merkle}{дерева Меркла} сообщений, содержащихся в \Mailbox{} +или признак отсутствия сообщений. + +Поведение. Получаем сообщения из дерева, пишем в результат только валидные. + +Если затесались невалидные -- то это повод для каких-то действий в отношении +пира, который обслуживает \Mailbox{}. + +Авторизация: сообщение подписано \Dude --- владельцем \Mailbox{}. + +\subsection{DELETE} + +Удалить сообщение для \Mailbox{}. + +Содержит признак рассылать по GOSSIP или нет, допустим, оно адресовано только +одному конкретному узлу. + +Содержит предикат, какие сообщения удалять (все, для определенного отправителя, +старше, чем X, больше, чем X, и т.п.). TBD. + +Полезно для освобождения ресурсов и экономии сетевого трафика. + +Опциональное. + +Авторизация: сообщение подписано \Dude --- владельцем \Mailbox{}. + +\subsection{SET-POLICY} + +Устанавливает политики обработки сообщений и \Mailbox{}. + +Параметры: GOSSIP (да/нет) + +Данные: \term{term}{дерево Меркла} текстового файла с инструкциями. + +Авторизация: сообщение подписано \Dude --- владельцем \Mailbox{}. + +Инструкции: TBD, расширяемо. + +Возможный примерный вид: + +\begin{verbatim} + +dudes drop * +peers drop * + +dudes accept GmtNGbawvxqykjDaBiT3LsqP7xqDPHVTxqfBqoFQ6Mre + +dudes accept 3WtddmcE8zzgBAPR7Bu7mKMaVMTN423NNXSPUJp3Hx42 + +dudes delete G5K9QvFaomXdP4Y9HcYEt3diS2cCWyU8nBd2eTzrcq1j + +dude set-pow-factor 94wrDGvcnSitP8a6rxLSTPBhXSwdGYrQqkuk2FcuiM3T 10 + +peer set-pow-factor Gu5FxngYYwpRfCUS9DJBGyH3tvtjXFbcZ7CbxmJPWEGH 10 + +peers accept yFSaUfb97ZRtQqzHWdERsR7KJvN8qyWX1M8rJcxnsiu + +peer cooldown * 120 +peer cooldown yFSaUfb97ZRtQqzHWdERsR7KJvN8qyWX1M8rJcxnsiu 60 + +dude cooldown * 120 +dude cooldown G5K9QvFaomXdP4Y9HcYEt3diS2cCWyU8nBd2eTzrcq1j 300 + +\end{verbatim} + + +\section{Возможные атаки и противодействие им} + +\subsection{Спам} + +Массовые нежелательные рассылки. + +\paragraph{Тактика борьбы:} + +\begin{itemize} + \item[-] Отвергать сообщения с множеством реципиентов. + \item[-] Вводить cooldown периоды для пиров и \Dude{}. + \item[-] Вводить (общие) белые списки и принимать сообщения только от них. + \item[-] Сделать ненулевой стоимость попадания в белые списки. + \item[-] Ввести иструменты репутации и т.п. + \item[-] Ввести регулируемый PoW на сообщения. +\end{itemize} + +\subsubsection{DoS} + +Атаки на работоспособность пира и сети в целом. + +\subsubsection{Посылка огромных данных} + +TBD + +\subsubsection{Посылка невалидных данных} + +TBD + +\subsubsection{Ссылки на отсутствующие данные} + +TBD + +\subsubsection{Анализ метаданных, построение графа взаимодействий} + +Поскольку \texttt{GOSSIP} проходит через пиров и имеет открытые метаданные, +можно сохранять граф коммуникаций и запоминать публичные ключи. + +Что бы этому противодействовать -- можно только взаимодействовать с заведомо +надёжными пирами через, возможно, отдельную сеть. + +К сожалению. + +Для по-настоящему анонимного и неотслеживаемого общения нужно использовать +другие механизмы. + +\section{Примеры применения} + +\subsection{Issues/Pull requests} + + +\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] (hbs2-peer1) {hbs2-peer1}; + \node[box,right=3cm of hbs2-peer1] (hbs2-peer2) {\underline{hbs2-peer2}\\Relay}; + \node[box,below=3cm of hbs2-peer2] + (hbs2-peerN) + {\underline{hbs2-peerN}\\\Acc{}}; + + \draw[->] (hbs2-peer1) -- (hbs2-peer2) + node[below,midway] {MAILBOX:SEND} + node[above,midway] {PR~Message}; + + \draw[->] (hbs2-peer2) -- (hbs2-peerN) + node[left,midway] {MAILBOX:SEND} + node[left,midway,yshift=4mm] {PR~Message}; + + \node[box,right=2cm of hbs2-peerN] (process) {filter-process}; + + \node[box,right=2cm of process] (fixme) {fixme}; + + \node[db,right=1cm of fixme,anchor=west,yshift=-4mm] (db) {fixme-state}; + + \draw[->] (process.150) -- ($(hbs2-peerN.north east)!(process.150)!(hbs2-peerN.south east)$) + node[midway,above] {MAIL-CHECK}; + + \draw[->] (process.180) -- ($(hbs2-peerN.north east)!(process.180)!(hbs2-peerN.south east)$) + node[midway,above] {READ}; + + \draw[->] (process) -- (fixme) + node[above,midway] {import}; + + \draw[->] (fixme.south) -- ($(fixme.south) - (0,+2cm)$) -| (hbs2-peerN.south) + node[below,near start] {refchan:export}; + + \draw[->] (fixme.east) -- (db.152); + + +\end{tikzpicture} +\end{figure} + +Пользователь формирует сообщение специального вида (plaintext/fixme) которое +посылается по протоколу MAILBOX получателю -- владельцу мейлобокса, который +указан в manifest проекта, как контакт для посылки подобных сообщений. + +На некоем хосте существует процесс, который время от времени проверяет +\Mailbox{} и при обнаружении новых сообщений экспортирует их в fixme, +который, в свою очередь, помещает их в RefChan делая доступными и видимыми +для подписчиков этого рефчана. + +Обновления данного Issue/PR возможны, если в качестве fixme-key выбран некий +уникальный идентификатор, который и будет указан в каждом сообщении. + + +\end{document} + + diff --git a/hbs2-cli/app/Main.hs b/hbs2-cli/app/Main.hs index e2fe2f6e..af26ef48 100644 --- a/hbs2-cli/app/Main.hs +++ b/hbs2-cli/app/Main.hs @@ -14,6 +14,7 @@ import HBS2.CLI.Run.Peer import HBS2.CLI.Run.RefLog import HBS2.CLI.Run.RefChan import HBS2.CLI.Run.LWWRef +import HBS2.CLI.Run.Mailbox import Data.Config.Suckless.Script.File as SF @@ -68,6 +69,7 @@ main = do reflogEntries refchanEntries lwwRefEntries + mailboxEntries helpEntries SF.entries diff --git a/hbs2-cli/hbs2-cli.cabal b/hbs2-cli/hbs2-cli.cabal index a26981d7..2aa48eb4 100644 --- a/hbs2-cli/hbs2-cli.cabal +++ b/hbs2-cli/hbs2-cli.cabal @@ -70,6 +70,7 @@ common shared-properties , exceptions , filepath , filepattern + , generic-lens , hashable , interpolatedstring-perl6 , memory @@ -116,6 +117,7 @@ library HBS2.CLI.Run.RefLog HBS2.CLI.Run.RefChan HBS2.CLI.Run.LWWRef + HBS2.CLI.Run.Mailbox HBS2.CLI.Run.Sigil HBS2.CLI.Run.Help diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Mailbox.hs b/hbs2-cli/lib/HBS2/CLI/Run/Mailbox.hs new file mode 100644 index 00000000..77f6d64e --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Run/Mailbox.hs @@ -0,0 +1,104 @@ +module HBS2.CLI.Run.Mailbox where + + +import HBS2.CLI.Prelude +import HBS2.CLI.Run.Internal + +import HBS2.Net.Auth.GroupKeySymm +import HBS2.Peer.Proto.Mailbox + +import HBS2.Data.Types.Refs +import HBS2.Hash +import HBS2.Storage +import HBS2.KeyMan.Keys.Direct as K + +import Codec.Serialise +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as LBS +import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.Coerce +import Data.Either + +createMessageFromByteString :: forall s m . ( MonadUnliftIO m + , s ~ HBS2Basic + , HasStorage m + ) + => LBS8.ByteString + -> m (Message s) +createMessageFromByteString lbs = do + let ls0 = LBS8.lines lbs + let (hbs, rest1) = break LBS8.null ls0 + let payload = dropWhile LBS8.null rest1 & LBS8.unlines + let headers = parseTop (LBS8.unpack (LBS8.unlines hbs)) & fromRight mempty + + flagz <- defMessageFlags + + sender <- headMay [ Left s | ListVal [SymbolVal "sender:", HashLike s] <- headers ] + & orThrowUser "sender not defined" + + let rcpts = [ Left s | ListVal [SymbolVal "recipient:", HashLike s] <- headers ] + + sto <- getStorage + + let cms = CreateMessageServices + sto + ( runKeymanClientRO . loadCredentials ) + ( runKeymanClientRO . loadKeyRingEntry ) + + createMessage cms flagz Nothing sender rcpts mempty (LBS8.toStrict payload) + + + +mailboxEntries :: forall c m . ( IsContext c + , MonadUnliftIO m + , HasStorage m + , Exception (BadFormException c) + ) => MakeDictM c m () +mailboxEntries = do + + brief "creates a new object of Mailbox.Message from text" + $ args [arg "string" "filename"] + $ desc "" + $ returns "blob" "message" + $ entry $ bindMatch "hbs2:mailbox:message:create" $ \case + [StringLike fn] -> lift do + lbs <- liftIO $ LBS8.readFile fn + mess <- createMessageFromByteString lbs + let what = serialise mess + pure $ mkForm @c "blob" [mkStr (LBS8.unpack what)] + + _ -> throwIO (BadFormException @c nil) + + + entry $ bindMatch "hbs2:mailbox:message:read:file" $ nil_ \case + [StringLike s] -> lift do + sto <- getStorage + let rms = ReadMessageServices ( liftIO . runKeymanClientRO . extractGroupKeySecret) + + (s,_,bs) <- liftIO (LBS.readFile s) + <&> deserialiseOrFail @(Message HBS2Basic) + >>= orThrowUser "invalid message format" + >>= readMessage rms + + liftIO $ BS.putStr bs + + _ -> throwIO (BadFormException @c nil) + + + + entry $ bindMatch "hbs2:mailbox:message:read:storage" $ nil_ \case + [HashLike h] -> lift do + sto <- getStorage + let rms = ReadMessageServices ( liftIO . runKeymanClientRO . extractGroupKeySecret) + + (s,_,bs) <- getBlock sto (coerce h) + >>= orThrowUser "message not found" + <&> deserialiseOrFail @(Message HBS2Basic) + >>= orThrowUser "invalid message format" + >>= readMessage rms + + liftIO $ BS.putStr bs + + _ -> throwIO (BadFormException @c nil) + + diff --git a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs b/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs index 5247cd8f..9646b282 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs @@ -559,27 +559,32 @@ decryptBlock :: forall t s sto h m . ( MonadIO m -> SmallEncryptedBlock t -> m t -decryptBlock sto findKey (SmallEncryptedBlock{..}) = do - +decryptBlock sto findKey seb@(SmallEncryptedBlock{..}) = do gkbs <- readFromMerkle sto (SimpleKey (fromHashRef sebGK0)) gk <- either (const $ throwError (GroupKeyNotFound 1)) pure (deserialiseOrFail @(GroupKey 'Symm s) gkbs) - gksec' <- findKey gk - -- [ lookupGroupKey sk pk gk | KeyringKeys pk sk <- keys ] & catMaybes & headMay - gksec <- maybe1 gksec' (throwError (GroupKeyNotFound 2)) pure + decryptBlockWithSecret @_ @s gksec seb +decryptBlockWithSecret :: forall t s h m . ( MonadIO m + , MonadError OperationError m + , ForGroupKeySymm s + , h ~ HbSync + , Serialise t + ) + + => GroupSecret + -> SmallEncryptedBlock t + -> m t + +decryptBlockWithSecret gksec (SmallEncryptedBlock{..}) = do let prk = HKDF.extractSkip @_ @HbSyncHash (Saltine.encode gksec) let key0 = HKDF.expand prk sebNonce typicalKeyLength & Saltine.decode & fromJust let nonce0 = nonceFrom @SK.Nonce sebNonce - let unboxed = SK.secretboxOpen key0 nonce0 (unEncryptedBox sebBox) - lbs <- maybe1 unboxed (throwError DecryptionError) (pure . LBS.fromStrict) - either (const $ throwError UnsupportedFormat) pure (deserialiseOrFail lbs) - deriveGroupSecret :: NonceFrom SK.Nonce n => n -> BS.ByteString -> GroupSecret deriveGroupSecret n bs = key0 where diff --git a/hbs2-git-dashboard/app/GitDashBoard.hs b/hbs2-git-dashboard/app/GitDashBoard.hs index 8701f408..100a80fd 100644 --- a/hbs2-git-dashboard/app/GitDashBoard.hs +++ b/hbs2-git-dashboard/app/GitDashBoard.hs @@ -158,7 +158,6 @@ runDashBoardM m = do setLogging @WARN warnPrefix setLogging @NOTICE noticePrefix - mkdir dataDir flip runContT pure do @@ -185,6 +184,7 @@ runDashBoardM m = do void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client + env <- newDashBoardEnv dataDir peerAPI @@ -193,6 +193,11 @@ runDashBoardM m = do lwwAPI sto + lift $ withDashBoardEnv env do + mkdir dataDir + notice "evolving db" + withState evolveDB + void $ ContT $ withAsync do fix \next -> do dbe' <- readTVarIO (_db env) @@ -200,15 +205,18 @@ runDashBoardM m = do Just dbe -> do notice $ green "Aquired database!" runPipe dbe + forever do + pause @'Seconds 30 Nothing -> do pause @'Seconds 5 next - void $ ContT $ withAsync do - q <- withDashBoardEnv env $ asks _pipeline - forever do - liftIO (atomically $ readTQueue q) & liftIO . join + replicateM_ 2 do + ContT $ withAsync do + q <- withDashBoardEnv env $ asks _pipeline + forever do + liftIO (atomically $ readTQueue q) & liftIO . join lift $ withDashBoardEnv env m `finally` do @@ -397,9 +405,6 @@ runScotty = do env <- ask - notice "evolving db" - withState evolveDB - notice "running config" conf <- readConfig @@ -469,6 +474,9 @@ runRPC = do void $ waitAnyCatchCancel [m1,p1] + + -- pure () + updateIndexPeriodially :: DashBoardPerks m => DashBoardM m () updateIndexPeriodially = do @@ -479,18 +487,26 @@ updateIndexPeriodially = do changes <- newTQueueIO + -- queues <- newTVarIO ( mempty :: HashMap RepoLww (TQueue (IO ()) ) ) + flip runContT pure do - p1 <- ContT $ withAsync $ forever do - rs <- atomically $ peekTQueue changes >> flushTQueue changes - addJob (withDashBoardEnv env updateIndex) - pause @'Seconds 1 + lift $ addJob (withDashBoardEnv env updateIndex) + + p1 <- ContT $ withAsync $ do + pause @'Seconds 30 + forever do + rs <- atomically $ peekTQueue changes >> flushTQueue changes + addJob (withDashBoardEnv env updateIndex) + -- pause @'Seconds 1 p2 <- pollRepos changes p3 <- pollFixmies - void $ waitAnyCatchCancel [p1,p2,p3] + p4 <- pollRepoIndex + + void $ waitAnyCatchCancel [p1,p2,p3,p4] where @@ -506,7 +522,7 @@ updateIndexPeriodially = do <&> fmap (,60) ContT $ withAsync $ do - polling (Polling 1 30) chans $ \(l,r) -> do + polling (Polling 10 30) chans $ \(l,r) -> do debug $ yellow "POLL FIXME CHAN" <+> pretty (AsBase58 r) void $ runMaybeT do @@ -517,13 +533,14 @@ updateIndexPeriodially = do old <- readTVarIO cached <&> HM.lookup r + atomically $ modifyTVar cached (HM.insert r new) + when (Just new /= old) $ lift do debug $ yellow "fixme refchan changed" <+> "run update" <+> pretty new addJob do -- TODO: this-is-not-100-percent-reliable -- $workflow: backlog -- откуда нам вообще знать, что там всё получилось? - atomically $ modifyTVar cached (HM.insert r new) void $ try @_ @SomeException (withDashBoardEnv env $ updateFixmeFor l r) @@ -535,7 +552,7 @@ updateIndexPeriodially = do let rlogs = selectRefLogs <&> fmap (over _1 (coerce @_ @MyRefLogKey)) . fmap (, 60) ContT $ withAsync $ do - polling (Polling 1 30) rlogs $ \r -> do + polling (Polling 10 30) rlogs $ \r -> do debug $ yellow "POLL REFLOG" <+> pretty r @@ -544,8 +561,11 @@ updateIndexPeriodially = do old <- readTVarIO cached <&> HM.lookup r + for_ rv $ \x -> do + atomically $ modifyTVar cached (HM.insert r x) + when (rv /= old) do debug $ yellow "REFLOG UPDATED" <+> pretty r <+> pretty x atomically $ modifyTVar cached (HM.insert r x) @@ -569,8 +589,15 @@ updateIndexPeriodially = do debug $ red "SYNC" <+> pretty cmd void $ runProcess $ shell cmd - lift $ buildCommitTreeIndex (coerce lww) + pollRepoIndex = do + api <- asks _refLogAPI + let rlogs = selectRefLogs <&> fmap (over _1 (coerce @_ @MyRefLogKey)) . fmap (, 600) + + ContT $ withAsync $ do + polling (Polling 1 30) rlogs $ \r -> do + lww' <- selectLwwByRefLog (RepoRefLog r) + for_ lww' $ addRepoIndexJob . coerce quit :: DashBoardPerks m => m () quit = liftIO exitSuccess diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State.hs index 3d24d6f4..c6612a1c 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State.hs +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State.hs @@ -25,7 +25,7 @@ import DBPipe.SQLite hiding (insert) import DBPipe.SQLite qualified as S import DBPipe.SQLite.Generic as G - +import Data.List.Split (chunksOf) import Data.Aeson as Aeson import Data.ByteString.Lazy.Char8 qualified as LBS8 import Data.ByteString.Lazy (ByteString) @@ -36,6 +36,8 @@ import Data.Either import Data.List qualified as List import Data.Map qualified as Map import Data.Map (Map) +import Data.HashMap.Strict qualified as HM +import Data.HashSet qualified as HS import System.FilePath import System.Directory @@ -690,18 +692,36 @@ instance FromRow BlobInfo type TreeLocator = [(TreeParent, TreeTree, TreeLevel, TreePath)] + insertBlob :: DashBoardPerks m => (BlobHash, BlobName, BlobSize, BlobSyn) -> DBPipeM m () -insertBlob (h,n,size,syn) = do +insertBlob (h, n, size, syn) = do S.insert [qc| - insert into blob (hash,name,size,syntax) + insert into blob (hash, name, size, syntax) values (?,?,?,?) on conflict (hash) do update set name = excluded.name , size = excluded.size , syntax = excluded.syntax - |] (h,n,size,syn) + where blob.name != excluded.name + or blob.size != excluded.size + or blob.syntax != excluded.syntax + |] (h, n, size, syn) + + +-- insertBlob :: DashBoardPerks m +-- => (BlobHash, BlobName, BlobSize, BlobSyn) +-- -> DBPipeM m () +-- insertBlob (h,n,size,syn) = do +-- S.insert [qc| +-- insert into blob (hash,name,size,syntax) +-- values (?,?,?,?) +-- on conflict (hash) +-- do update set name = excluded.name +-- , size = excluded.size +-- , syntax = excluded.syntax +-- |] (h,n,size,syn) selectBlobInfo :: (DashBoardPerks m, MonadReader DashBoardEnv m) @@ -758,8 +778,8 @@ readBlob repo hash = do <&> fromRight mempty -updateForks :: (MonadIO m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> m () -updateForks lww = withState do +updateForks :: (MonadIO m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> DBPipeM m () +updateForks lww = do S.insert [qc| insert into fork (a,b) @@ -778,6 +798,13 @@ checkCommitProcessed lww co = withState do select [qc|select 1 from repocommit where lww = ? and kommit = ?|] (lww, co) <&> listToMaybe @(Only Int) <&> isJust + +listCommitsProcessed :: (MonadIO m, MonadReader DashBoardEnv m) + => LWWRefKey 'HBS2Basic -> m [GitHash] +listCommitsProcessed lww = withState do + select [qc|select kommit from repocommit where lww = ?|] (Only lww) + <&> fmap fromOnly + listCommits :: (MonadUnliftIO m, MonadReader DashBoardEnv m) => LWWRefKey HBS2Basic -> m [GitHash] listCommits lww = do @@ -837,46 +864,46 @@ getRootTree lww co = do _ -> Nothing updateRepoData :: (MonadReader DashBoardEnv m, MonadUnliftIO m) - => LWWRefKey HBS2Basic -> GitHash -> m () + => LWWRefKey HBS2Basic -> GitHash -> DBPipeM m () updateRepoData lww co = do env <- ask void $ runMaybeT do - root <- lift (getRootTree lww co) >>= toMPlus - (trees, blobs) <- lift $ getTreeRecursive lww co + root <- lift (lift (getRootTree lww co)) >>= toMPlus + (trees, blobs) <- lift $ lift $ getTreeRecursive lww co -- lift $ addJob $ liftIO $ withDashBoardEnv env do - lift $ withState $ transactional do - + -- lift $ withState do + lift do insert @RepoCommitTable $ onConflictIgnore @RepoCommitTable (RepoLww lww, RepoCommit co) for_ blobs $ \(fn, (hash, size, syn)) -> do insertBlob (BlobHash hash, BlobName fn, BlobSize size, BlobSyn syn) - for_ (Map.toList trees) $ \(t,h0) -> do + for_ (Map.toList trees) $ \(t,h0) -> do - case t of - [x] -> insertTree (TreeCommit co,TreeParent root,TreeTree h0,1,TreePath x) - _ -> pure () + case t of + [x] -> insertTree (TreeCommit co,TreeParent root,TreeTree h0,1,TreePath x) + _ -> pure () - let child = tailSafe t - debug $ red "TREE-REL:" <+> pretty t - let parent = Map.lookup child trees + let child = tailSafe t + debug $ red "TREE-REL:" <+> pretty t + let parent = Map.lookup child trees - for_ parent $ \p -> do - debug $ red "FOUND SHIT:" <+> pretty (h0,p) - insertTree ( TreeCommit co - , TreeParent p - , TreeTree h0 - , TreeLevel (length t) - , TreePath (headDef "" t) - ) + for_ parent $ \p -> do + debug $ red "FOUND SHIT:" <+> pretty (h0,p) + insertTree ( TreeCommit co + , TreeParent p + , TreeTree h0 + , TreeLevel (length t) + , TreePath (headDef "" t) + ) - updateForks lww + -- updateForks lww buildSingleCommitTreeIndex :: ( MonadUnliftIO m , DashBoardPerks m @@ -894,7 +921,9 @@ buildSingleCommitTreeIndex lww co = do done <- checkCommitProcessed lww co let skip = done && not ignoreCaches guard (not skip) - lift $ updateRepoData lww co + lift $ withState $ transactional $ do + updateRepoData lww co + updateForks lww buildCommitTreeIndex :: ( MonadUnliftIO m , DashBoardPerks m @@ -904,16 +933,26 @@ buildCommitTreeIndex :: ( MonadUnliftIO m -> m () buildCommitTreeIndex lww = do - commits <- listCommits lww + + debug $ red "buildCommitTreeIndex" <+> pretty lww + env <- ask ignoreCaches <- getIgnoreCaches - for_ commits $ \co -> void $ runMaybeT do - done <- checkCommitProcessed lww co - let skip = done && not ignoreCaches - guard (not skip) - lift $ addJob $ withDashBoardEnv env (updateRepoData lww co) + doneCommits <- listCommitsProcessed lww <&> HS.fromList + + commits <- listCommits lww <&> filter (not . flip HS.member doneCommits) + let chunks = chunksOf 100 commits + + for_ chunks $ \chunk -> do + -- addJob $ withDashBoardEnv env do + withState $ transactional do + for_ chunk $ \co -> do + updateRepoData lww co + + unless (List.null chunks) do + withState $ transactional $ do updateForks lww -- FIXME: check-names-with-spaces diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State/Index/Peer.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State/Index/Peer.hs index d9644e48..65f4e5f1 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State/Index/Peer.hs +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State/Index/Peer.hs @@ -13,12 +13,31 @@ import HBS2.System.Dir import Streaming.Prelude qualified as S +import Data.HashMap.Strict qualified as HM import System.Process.Typed {- HLINT ignore "Functor law" -} seconds = TimeoutSec + +addRepoIndexJob :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> m () +addRepoIndexJob lww = do + + e <- ask + let wip = _repoCommitIndexWIP e + + n <- atomically do + modifyTVar wip (HM.insertWith (+) (coerce lww) 1) + readTVar wip <&> HM.lookup (coerce lww) <&> fromMaybe 0 + + when ( n < 2 ) do + addJob $ withDashBoardEnv e do + buildCommitTreeIndex (coerce lww) + `finally` do + atomically do + modifyTVar wip (HM.adjust pred (coerce lww)) + updateFixmeFor :: ( MonadUnliftIO m , MonadReader DashBoardEnv m ) @@ -101,6 +120,7 @@ updateIndexFromPeer = do lift $ S.yield (lw, RepoHeadTx tx, RepoHeadRef rhh, rhead, fme) withState $ transactional do + -- withState do for_ headz $ \(l, tx, rh, rhead, fme) -> do let rlwwseq = RepoLwwSeq (fromIntegral $ lwwSeq wv) insertRepoHead l rlwwseq (RepoRefLog rk) tx rh rhead @@ -110,7 +130,9 @@ updateIndexFromPeer = do for_ fme $ \f -> do insertRepoFixme l rlwwseq f - -- buildCommitTreeIndex (coerce lw) + -- WTF? + env <- ask + buildCommitTreeIndex (coerce lw) fxe <- selectRepoFixme diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Types.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Types.hs index ab4ed417..e5ccfd5c 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Types.hs +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Types.hs @@ -20,6 +20,8 @@ import HBS2.System.Dir import System.FilePath import Data.Word +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HM type MyRefChan = RefChanId L4Proto type MyRefLogKey = RefLogKey 'HBS2Basic @@ -58,6 +60,7 @@ data DashBoardEnv = , _dashBoardHttpPort :: TVar (Maybe Word16) , _dashBoardDevAssets :: TVar (Maybe FilePath) , _dashBoardIndexIgnoreCaches :: TVar Bool + , _repoCommitIndexWIP :: TVar (HashMap (LWWRefKey 'HBS2Basic) Int) } makeLenses 'DashBoardEnv @@ -96,6 +99,7 @@ newDashBoardEnv ddir peer rlog rchan lww sto = do <*> newTVarIO (Just 8911) <*> newTVarIO Nothing <*> newTVarIO False + <*> newTVarIO mempty getHttpPortNumber :: (MonadIO m, MonadReader DashBoardEnv m, Integral a) => m a getHttpPortNumber = do @@ -131,7 +135,7 @@ withState f = do SConnect -> do notice $ yellow "connecting to db" - dbe <- liftIO $ try @_ @SomeException (newDBPipeEnv dbPipeOptsDef dbFile) + dbe <- liftIO $ try @_ @SomeException (newDBPipeEnv (dbPipeOptsDef {dbPipeBatchTime = 1}) dbFile) case dbe of Right e -> do @@ -156,6 +160,8 @@ addJob f = do q <- asks _pipeline atomically $ writeTQueue q f + + hbs2_git_dashboard :: FilePath hbs2_git_dashboard = "hbs2-git-dashboard" diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Fixme.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Fixme.hs index 99147e28..06dc67f9 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Fixme.hs +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Fixme.hs @@ -98,3 +98,5 @@ repoFixme q@(FromParams p') lww = do , hxSwap_ "afterend" ] do td_ [colspan_ "3"] mempty + + diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Issue.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Issue.hs index 7ac8afc6..ec6c6d64 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Issue.hs +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Issue.hs @@ -152,3 +152,5 @@ issuePage repo@(RepoLww lww) f = rootPage do where trim before seize txt = Text.lines txt & drop before & take seize & Text.unlines + + diff --git a/hbs2-git-dashboard/hbs2-git-dashboard.cabal b/hbs2-git-dashboard/hbs2-git-dashboard.cabal index 212f4492..5dc80c70 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard.cabal +++ b/hbs2-git-dashboard/hbs2-git-dashboard.cabal @@ -114,6 +114,7 @@ library hbs2-git-dashboard-core , skylighting-lucid , stm , streaming + , split , temporary , text , time diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index d23c9983..070ce148 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -162,6 +162,9 @@ library HBS2.Peer.Proto.AnyRef HBS2.Peer.Proto.LWWRef HBS2.Peer.Proto.LWWRef.Internal + HBS2.Peer.Proto.Mailbox + HBS2.Peer.Proto.Mailbox.Types + HBS2.Peer.Proto.Mailbox.Message HBS2.Peer.Proto.BrowserPlugin HBS2.Peer.RPC.Client diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs new file mode 100644 index 00000000..8780ea22 --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs @@ -0,0 +1,68 @@ +{-# Language UndecidableInstances #-} +{-# Language AllowAmbiguousTypes #-} +module HBS2.Peer.Proto.Mailbox + ( module HBS2.Peer.Proto.Mailbox + , module HBS2.Peer.Proto.Mailbox.Message + ) where + +import HBS2.Prelude.Plated + +import HBS2.Data.Types.SignedBox + +import HBS2.Peer.Proto.Mailbox.Types +import HBS2.Peer.Proto.Mailbox.Message + +import Codec.Serialise + +data MailBoxStatusPayload s = + MailBoxStatusPayload + { mbsMailboxKey :: MailboxKey s + , mbsMailboxHash :: HashRef + } + deriving stock (Generic) + +data SetPolicyPayload s = + SetPolicyPayload + { sppMailboxKey :: MailboxKey s + , sppPolicyVersion :: PolicyVersion + , sppPolicyRef :: HashRef + } + deriving stock (Generic) + +data GetPolicyPayload s = + GetPolicyPayload + { gppMailboxKey :: MailboxKey s + , gppPolicyVersion :: PolicyVersion + , gppPolicyRef :: HashRef + } + deriving stock (Generic) + +data DeleteMessagesPayload s = + DeleteMessagesPayload + { dmpMailboxKey :: MailboxKey s + , dmpPredicate :: MailboxMessagePredicate + } + deriving stock (Generic) + +data MailBoxProtoMessage e s = + SendMessage (Message s) -- already has signed box + | CheckMailbox (SignedBox (MailboxKey s) s) + | MailboxStatus (SignedBox (MailBoxStatusPayload s) s) + | SetPolicy (SignedBox (SetPolicyPayload s) s) + | CurrentPolicy (GetPolicyPayload s) + | DeleteMessages (SignedBox (DeleteMessagesPayload s) s) + deriving stock (Generic) + +data MailBoxProto e s = + MailBoxProtoV1 (MailBoxProtoMessage e s) + +instance ForMailbox s => Serialise (MailBoxStatusPayload s) +instance ForMailbox s => Serialise (SetPolicyPayload s) +instance ForMailbox s => Serialise (GetPolicyPayload s) +instance ForMailbox s => Serialise (DeleteMessagesPayload s) +instance ForMailbox s => Serialise (MailBoxProtoMessage e s) + + + + + diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Message.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Message.hs new file mode 100644 index 00000000..fc9675d3 --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Message.hs @@ -0,0 +1,206 @@ +{-# Language UndecidableInstances #-} +{-# Language AllowAmbiguousTypes #-} +module HBS2.Peer.Proto.Mailbox.Message where + +import HBS2.Prelude.Plated + +import HBS2.Peer.Proto.Mailbox.Types + +import HBS2.Data.Types.SmallEncryptedBlock +import HBS2.Net.Auth.Credentials.Sigil +import HBS2.Net.Auth.GroupKeySymm + +import HBS2.OrDie +import HBS2.Base58 +import HBS2.Storage +import HBS2.Hash +import HBS2.Net.Auth.Credentials +import HBS2.Data.Types.SignedBox +import HBS2.Data.Types.Refs +import HBS2.Net.Auth.Schema() + +import Control.Monad.Except +import Data.ByteString (ByteString) +import Data.Set +import Data.Set qualified as Set +import Data.Word +import Lens.Micro.Platform +import Streaming.Prelude qualified as S +import UnliftIO + + +newtype MessageTimestamp = + MessageTimestamp Word64 + deriving newtype (Eq,Ord,Num,Enum,Integral,Real,Pretty,Show,Hashable) + deriving stock Generic + + +newtype MessageTTL = MessageTTL Word32 + deriving newtype (Eq,Ord,Num,Enum,Integral,Real,Pretty,Show,Hashable) + deriving stock Generic + + +data MessageCompression = GZip + deriving stock (Eq,Ord,Generic,Show) + +data MessageFlags = + MessageFlags1 + { messageCreated :: MessageTimestamp + , messageTTL :: Maybe MessageTTL + , messageCompression :: Maybe MessageCompression + , messageSchema :: Maybe HashRef -- reserved + } + deriving stock (Eq,Ord,Generic,Show) + +type MessageRecipient s = PubKey 'Sign s + +data MessageContent s = + MessageContent + { messageFlags :: MessageFlags + , messageRecipients :: Set (MessageRecipient s) + , messageGK0 :: Either HashRef (GroupKey 'Symm s) + , messageParts :: Set HashRef + , messageData :: SmallEncryptedBlock ByteString + } + deriving stock Generic + +data Message s = + MessageBasic + { messageContent :: SignedBox (MessageContent s) s + } + deriving stock Generic + + +instance Serialise MessageTimestamp +instance Serialise MessageTTL +instance Serialise MessageCompression +instance Serialise MessageFlags +instance ForMailbox s => Serialise (MessageContent s) +instance ForMailbox s => Serialise (Message s) + +-- TODO: mailbox-proto-handler + +-- TODO: mailbox-proto-test? + + +data CreateMessageError = + SenderNotSet + | RecipientsNotSet + | SigilNotFound HashRef + | MalformedSigil (Maybe HashRef) + | SenderNoAccesToGroupKey + | NoCredentialsFound String + | NoKeyringFound String + deriving stock (Show,Typeable,Generic) + +instance Exception CreateMessageError + + +defMessageFlags :: MonadIO m => m MessageFlags +defMessageFlags = MessageFlags1 <$> (round <$> liftIO getPOSIXTime) + <*> pure mzero + <*> pure mzero + <*> pure mzero + +data CreateMessageServices s = + CreateMessageServices + { cmStorage :: AnyStorage + , cmLoadCredentials :: forall m . MonadUnliftIO m => PubKey 'Sign s -> m (Maybe (PeerCredentials s)) + , cmLoadKeyringEntry :: forall m . MonadUnliftIO m => PubKey 'Encrypt s -> m (Maybe (KeyringEntry s)) + } + +createMessage :: forall s m . (MonadUnliftIO m , s ~ HBS2Basic) + => CreateMessageServices s + -> MessageFlags + -> Maybe GroupSecret + -> Either HashRef (Sigil s) -- ^ sender + -> [Either HashRef (Sigil s)] -- ^ sigil keys (recipients) + -> [HashRef] -- ^ message parts + -> ByteString -- ^ payload + -> m (Message s) +createMessage CreateMessageServices{..} _ gks sender' rcpts' parts bs = do + -- TODO: support-flags + flags <- defMessageFlags + + pips <- getKeys + + (sender, recipients) <- case pips of + [] -> throwIO SenderNotSet + ( s : rs@(_ : _) ) -> pure (s,rs) + _ -> throwIO RecipientsNotSet + + gk <- generateGroupKey @s gks (fmap snd pips) + + gkMt <- generateGroupKey @s gks mempty + + KeyringEntry pk sk _ <- cmLoadKeyringEntry (snd sender) + >>= orThrow (NoKeyringFound (show $ pretty $ AsBase58 (snd sender))) + + gks <- lookupGroupKey sk pk gk & orThrow SenderNoAccesToGroupKey + + encrypted <- encryptBlock cmStorage gks (Right gk) Nothing bs + + let content = MessageContent @s + flags + (Set.fromList (fmap fst recipients)) + (Right gk) + -- TODO: check-if-parts-exists + (Set.fromList parts) + encrypted + + creds <- cmLoadCredentials (fst sender) + >>= orThrow (NoCredentialsFound (show $ pretty $ AsBase58 (fst sender))) + + let ssk = view peerSignSk creds + + let box = makeSignedBox @s (fst sender) ssk content + + pure $ MessageBasic box + + where + getKeys = do + S.toList_ $ for_ (sender' : rcpts') $ \case + Right si -> fromSigil Nothing si + Left hs -> do + si <- loadSigil @s cmStorage hs >>= orThrow (SigilNotFound hs) + fromSigil (Just hs) si + fromSigil h si = do + (rcpt, SigilData{..}) <- unboxSignedBox0 (sigilData si) & orThrow (MalformedSigil h) + S.yield (rcpt, sigilDataEncKey) + + +data ReadMessageServices s = + ReadMessageServices + { rmsFindGKS :: forall m . MonadIO m => GroupKey 'Symm s -> m (Maybe GroupSecret) + } + +data ReadMessageError = + ReadSignCheckFailed + | ReadNoGroupKey + | ReadNoGroupKeyAccess + deriving stock (Show,Typeable) + +instance Exception ReadMessageError + +readMessage :: forall s m . ( MonadUnliftIO m + , s ~ HBS2Basic + ) + => ReadMessageServices s + -> Message s + -> m (PubKey 'Sign s, MessageContent s, ByteString) + +readMessage ReadMessageServices{..} msg = do + + (pk, co@MessageContent{..}) <- unboxSignedBox0 (messageContent msg) + & orThrow ReadSignCheckFailed + + -- TODO: support-groupkey-by-reference + gk <- messageGK0 & orThrow ReadNoGroupKey + + gks <- rmsFindGKS gk >>= orThrow ReadNoGroupKeyAccess + + bs <- runExceptT (decryptBlockWithSecret @_ @s gks messageData) + >>= orThrowPassIO + + pure (pk, co, bs) + diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs new file mode 100644 index 00000000..9df3ce1d --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs @@ -0,0 +1,60 @@ +{-# Language UndecidableInstances #-} +{-# Language AllowAmbiguousTypes #-} +module HBS2.Peer.Proto.Mailbox.Types + ( ForMailbox + , MailboxKey + , Recipient + , Sender + , PolicyVersion + , MailboxMessagePredicate(..) + , SimplePredicate(..) + , SimplePredicateExpr(..) + , module HBS2.Net.Proto.Types + , HashRef + ) where + +import HBS2.Prelude.Plated + +import HBS2.Net.Proto.Types +import HBS2.Data.Types.Refs (HashRef) + +import HBS2.Data.Types.SignedBox +import HBS2.Net.Auth.GroupKeySymm + +import Data.Word (Word32) +import Codec.Serialise + +type MailboxKey s = PubKey 'Sign s + +type Sender s = PubKey 'Sign s + +type Recipient s = PubKey 'Sign s + +type PolicyVersion = Word32 + +data SimplePredicateExpr = + And SimplePredicateExpr SimplePredicateExpr + | Or SimplePredicateExpr SimplePredicateExpr + | Op SimplePredicate + | End + deriving stock (Generic) + +data SimplePredicate = + Nop + | MessageHashEq HashRef + deriving stock (Generic) + +data MailboxMessagePredicate = + MailboxMessagePredicate1 SimplePredicateExpr + deriving stock (Generic) + + +type ForMailbox s = ( ForGroupKeySymm s + , Ord (PubKey 'Sign s) + , ForSignedBox s + ) + +instance Serialise SimplePredicate +instance Serialise SimplePredicateExpr +instance Serialise MailboxMessagePredicate +