mirror of https://github.com/voidlizard/hbs2
wip, mailboxes
This commit is contained in:
voidlizard
parent
9fca167dd3
commit
09508db720
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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{Протокол <<Mailbox>>}
|
||||
|
||||
\begin{document}
|
||||
|
||||
\maketitle
|
||||
|
||||
\section{О документе}
|
||||
|
||||
Документ рассматривает протокол доставки данных <<Mailbox>> по паттерну $*
|
||||
\rightarrow 1$ <<email>> в 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}
|
||||
|
||||
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
||||
|
|
|
|||
|
|
@ -98,3 +98,5 @@ repoFixme q@(FromParams p') lww = do
|
|||
, hxSwap_ "afterend"
|
||||
] do
|
||||
td_ [colspan_ "3"] mempty
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -114,6 +114,7 @@ library hbs2-git-dashboard-core
|
|||
, skylighting-lucid
|
||||
, stm
|
||||
, streaming
|
||||
, split
|
||||
, temporary
|
||||
, text
|
||||
, time
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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)
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
Loading…
Reference in New Issue