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
|
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
|
.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-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
|
publish-hbs2-git-doc: hbs2-git-doc-0.24.1.pdf
|
||||||
$(eval TARGET := $(call make_target,$<))
|
$(eval TARGET := $(call make_target,$<))
|
||||||
$(eval HASH := $(shell hbs2 metadata create --hash --auto $(TARGET)))
|
$(eval HASH := $(shell hbs2 metadata create --hash --auto $(TARGET)))
|
||||||
@echo Updating $(HBS2GITDOCLWW) $(HASH)
|
@echo Updating $(HBS2GITDOCLWW) $(HASH)
|
||||||
hbs2-peer lwwref update -v $(HASH) $(HBS2GITDOCLWW)
|
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:
|
clean:
|
||||||
rm -f *.aux *.log *.nav *.out *.snm *.vrb *.toc *.pdf
|
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.RefLog
|
||||||
import HBS2.CLI.Run.RefChan
|
import HBS2.CLI.Run.RefChan
|
||||||
import HBS2.CLI.Run.LWWRef
|
import HBS2.CLI.Run.LWWRef
|
||||||
|
import HBS2.CLI.Run.Mailbox
|
||||||
|
|
||||||
import Data.Config.Suckless.Script.File as SF
|
import Data.Config.Suckless.Script.File as SF
|
||||||
|
|
||||||
|
|
@ -68,6 +69,7 @@ main = do
|
||||||
reflogEntries
|
reflogEntries
|
||||||
refchanEntries
|
refchanEntries
|
||||||
lwwRefEntries
|
lwwRefEntries
|
||||||
|
mailboxEntries
|
||||||
helpEntries
|
helpEntries
|
||||||
|
|
||||||
SF.entries
|
SF.entries
|
||||||
|
|
|
||||||
|
|
@ -70,6 +70,7 @@ common shared-properties
|
||||||
, exceptions
|
, exceptions
|
||||||
, filepath
|
, filepath
|
||||||
, filepattern
|
, filepattern
|
||||||
|
, generic-lens
|
||||||
, hashable
|
, hashable
|
||||||
, interpolatedstring-perl6
|
, interpolatedstring-perl6
|
||||||
, memory
|
, memory
|
||||||
|
|
@ -116,6 +117,7 @@ library
|
||||||
HBS2.CLI.Run.RefLog
|
HBS2.CLI.Run.RefLog
|
||||||
HBS2.CLI.Run.RefChan
|
HBS2.CLI.Run.RefChan
|
||||||
HBS2.CLI.Run.LWWRef
|
HBS2.CLI.Run.LWWRef
|
||||||
|
HBS2.CLI.Run.Mailbox
|
||||||
HBS2.CLI.Run.Sigil
|
HBS2.CLI.Run.Sigil
|
||||||
|
|
||||||
HBS2.CLI.Run.Help
|
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
|
-> SmallEncryptedBlock t
|
||||||
-> m t
|
-> m t
|
||||||
|
|
||||||
decryptBlock sto findKey (SmallEncryptedBlock{..}) = do
|
decryptBlock sto findKey seb@(SmallEncryptedBlock{..}) = do
|
||||||
|
|
||||||
gkbs <- readFromMerkle sto (SimpleKey (fromHashRef sebGK0))
|
gkbs <- readFromMerkle sto (SimpleKey (fromHashRef sebGK0))
|
||||||
gk <- either (const $ throwError (GroupKeyNotFound 1)) pure (deserialiseOrFail @(GroupKey 'Symm s) gkbs)
|
gk <- either (const $ throwError (GroupKeyNotFound 1)) pure (deserialiseOrFail @(GroupKey 'Symm s) gkbs)
|
||||||
|
|
||||||
gksec' <- findKey gk
|
gksec' <- findKey gk
|
||||||
-- [ lookupGroupKey sk pk gk | KeyringKeys pk sk <- keys ] & catMaybes & headMay
|
|
||||||
|
|
||||||
gksec <- maybe1 gksec' (throwError (GroupKeyNotFound 2)) pure
|
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 prk = HKDF.extractSkip @_ @HbSyncHash (Saltine.encode gksec)
|
||||||
let key0 = HKDF.expand prk sebNonce typicalKeyLength & Saltine.decode & fromJust
|
let key0 = HKDF.expand prk sebNonce typicalKeyLength & Saltine.decode & fromJust
|
||||||
let nonce0 = nonceFrom @SK.Nonce sebNonce
|
let nonce0 = nonceFrom @SK.Nonce sebNonce
|
||||||
|
|
||||||
let unboxed = SK.secretboxOpen key0 nonce0 (unEncryptedBox sebBox)
|
let unboxed = SK.secretboxOpen key0 nonce0 (unEncryptedBox sebBox)
|
||||||
|
|
||||||
lbs <- maybe1 unboxed (throwError DecryptionError) (pure . LBS.fromStrict)
|
lbs <- maybe1 unboxed (throwError DecryptionError) (pure . LBS.fromStrict)
|
||||||
|
|
||||||
either (const $ throwError UnsupportedFormat) pure (deserialiseOrFail lbs)
|
either (const $ throwError UnsupportedFormat) pure (deserialiseOrFail lbs)
|
||||||
|
|
||||||
|
|
||||||
deriveGroupSecret :: NonceFrom SK.Nonce n => n -> BS.ByteString -> GroupSecret
|
deriveGroupSecret :: NonceFrom SK.Nonce n => n -> BS.ByteString -> GroupSecret
|
||||||
deriveGroupSecret n bs = key0
|
deriveGroupSecret n bs = key0
|
||||||
where
|
where
|
||||||
|
|
|
||||||
|
|
@ -158,7 +158,6 @@ runDashBoardM m = do
|
||||||
setLogging @WARN warnPrefix
|
setLogging @WARN warnPrefix
|
||||||
setLogging @NOTICE noticePrefix
|
setLogging @NOTICE noticePrefix
|
||||||
|
|
||||||
mkdir dataDir
|
|
||||||
|
|
||||||
flip runContT pure do
|
flip runContT pure do
|
||||||
|
|
||||||
|
|
@ -185,6 +184,7 @@ runDashBoardM m = do
|
||||||
|
|
||||||
void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
|
void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
|
||||||
|
|
||||||
|
|
||||||
env <- newDashBoardEnv
|
env <- newDashBoardEnv
|
||||||
dataDir
|
dataDir
|
||||||
peerAPI
|
peerAPI
|
||||||
|
|
@ -193,6 +193,11 @@ runDashBoardM m = do
|
||||||
lwwAPI
|
lwwAPI
|
||||||
sto
|
sto
|
||||||
|
|
||||||
|
lift $ withDashBoardEnv env do
|
||||||
|
mkdir dataDir
|
||||||
|
notice "evolving db"
|
||||||
|
withState evolveDB
|
||||||
|
|
||||||
void $ ContT $ withAsync do
|
void $ ContT $ withAsync do
|
||||||
fix \next -> do
|
fix \next -> do
|
||||||
dbe' <- readTVarIO (_db env)
|
dbe' <- readTVarIO (_db env)
|
||||||
|
|
@ -200,15 +205,18 @@ runDashBoardM m = do
|
||||||
Just dbe -> do
|
Just dbe -> do
|
||||||
notice $ green "Aquired database!"
|
notice $ green "Aquired database!"
|
||||||
runPipe dbe
|
runPipe dbe
|
||||||
|
forever do
|
||||||
|
pause @'Seconds 30
|
||||||
|
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
pause @'Seconds 5
|
pause @'Seconds 5
|
||||||
next
|
next
|
||||||
|
|
||||||
void $ ContT $ withAsync do
|
replicateM_ 2 do
|
||||||
q <- withDashBoardEnv env $ asks _pipeline
|
ContT $ withAsync do
|
||||||
forever do
|
q <- withDashBoardEnv env $ asks _pipeline
|
||||||
liftIO (atomically $ readTQueue q) & liftIO . join
|
forever do
|
||||||
|
liftIO (atomically $ readTQueue q) & liftIO . join
|
||||||
|
|
||||||
lift $ withDashBoardEnv env m
|
lift $ withDashBoardEnv env m
|
||||||
`finally` do
|
`finally` do
|
||||||
|
|
@ -397,9 +405,6 @@ runScotty = do
|
||||||
|
|
||||||
env <- ask
|
env <- ask
|
||||||
|
|
||||||
notice "evolving db"
|
|
||||||
withState evolveDB
|
|
||||||
|
|
||||||
notice "running config"
|
notice "running config"
|
||||||
conf <- readConfig
|
conf <- readConfig
|
||||||
|
|
||||||
|
|
@ -469,6 +474,9 @@ runRPC = do
|
||||||
void $ waitAnyCatchCancel [m1,p1]
|
void $ waitAnyCatchCancel [m1,p1]
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- pure ()
|
||||||
|
|
||||||
updateIndexPeriodially :: DashBoardPerks m => DashBoardM m ()
|
updateIndexPeriodially :: DashBoardPerks m => DashBoardM m ()
|
||||||
updateIndexPeriodially = do
|
updateIndexPeriodially = do
|
||||||
|
|
||||||
|
|
@ -479,18 +487,26 @@ updateIndexPeriodially = do
|
||||||
|
|
||||||
changes <- newTQueueIO
|
changes <- newTQueueIO
|
||||||
|
|
||||||
|
-- queues <- newTVarIO ( mempty :: HashMap RepoLww (TQueue (IO ()) ) )
|
||||||
|
|
||||||
flip runContT pure do
|
flip runContT pure do
|
||||||
|
|
||||||
p1 <- ContT $ withAsync $ forever do
|
lift $ addJob (withDashBoardEnv env updateIndex)
|
||||||
rs <- atomically $ peekTQueue changes >> flushTQueue changes
|
|
||||||
addJob (withDashBoardEnv env updateIndex)
|
p1 <- ContT $ withAsync $ do
|
||||||
pause @'Seconds 1
|
pause @'Seconds 30
|
||||||
|
forever do
|
||||||
|
rs <- atomically $ peekTQueue changes >> flushTQueue changes
|
||||||
|
addJob (withDashBoardEnv env updateIndex)
|
||||||
|
-- pause @'Seconds 1
|
||||||
|
|
||||||
p2 <- pollRepos changes
|
p2 <- pollRepos changes
|
||||||
|
|
||||||
p3 <- pollFixmies
|
p3 <- pollFixmies
|
||||||
|
|
||||||
void $ waitAnyCatchCancel [p1,p2,p3]
|
p4 <- pollRepoIndex
|
||||||
|
|
||||||
|
void $ waitAnyCatchCancel [p1,p2,p3,p4]
|
||||||
|
|
||||||
where
|
where
|
||||||
|
|
||||||
|
|
@ -506,7 +522,7 @@ updateIndexPeriodially = do
|
||||||
<&> fmap (,60)
|
<&> fmap (,60)
|
||||||
|
|
||||||
ContT $ withAsync $ do
|
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)
|
debug $ yellow "POLL FIXME CHAN" <+> pretty (AsBase58 r)
|
||||||
|
|
||||||
void $ runMaybeT do
|
void $ runMaybeT do
|
||||||
|
|
@ -517,13 +533,14 @@ updateIndexPeriodially = do
|
||||||
|
|
||||||
old <- readTVarIO cached <&> HM.lookup r
|
old <- readTVarIO cached <&> HM.lookup r
|
||||||
|
|
||||||
|
atomically $ modifyTVar cached (HM.insert r new)
|
||||||
|
|
||||||
when (Just new /= old) $ lift do
|
when (Just new /= old) $ lift do
|
||||||
debug $ yellow "fixme refchan changed" <+> "run update" <+> pretty new
|
debug $ yellow "fixme refchan changed" <+> "run update" <+> pretty new
|
||||||
addJob do
|
addJob do
|
||||||
-- TODO: this-is-not-100-percent-reliable
|
-- TODO: this-is-not-100-percent-reliable
|
||||||
-- $workflow: backlog
|
-- $workflow: backlog
|
||||||
-- откуда нам вообще знать, что там всё получилось?
|
-- откуда нам вообще знать, что там всё получилось?
|
||||||
atomically $ modifyTVar cached (HM.insert r new)
|
|
||||||
void $ try @_ @SomeException (withDashBoardEnv env $ updateFixmeFor l r)
|
void $ try @_ @SomeException (withDashBoardEnv env $ updateFixmeFor l r)
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -535,7 +552,7 @@ updateIndexPeriodially = do
|
||||||
let rlogs = selectRefLogs <&> fmap (over _1 (coerce @_ @MyRefLogKey)) . fmap (, 60)
|
let rlogs = selectRefLogs <&> fmap (over _1 (coerce @_ @MyRefLogKey)) . fmap (, 60)
|
||||||
|
|
||||||
ContT $ withAsync $ do
|
ContT $ withAsync $ do
|
||||||
polling (Polling 1 30) rlogs $ \r -> do
|
polling (Polling 10 30) rlogs $ \r -> do
|
||||||
|
|
||||||
debug $ yellow "POLL REFLOG" <+> pretty r
|
debug $ yellow "POLL REFLOG" <+> pretty r
|
||||||
|
|
||||||
|
|
@ -544,8 +561,11 @@ updateIndexPeriodially = do
|
||||||
|
|
||||||
old <- readTVarIO cached <&> HM.lookup r
|
old <- readTVarIO cached <&> HM.lookup r
|
||||||
|
|
||||||
|
|
||||||
for_ rv $ \x -> do
|
for_ rv $ \x -> do
|
||||||
|
|
||||||
|
atomically $ modifyTVar cached (HM.insert r x)
|
||||||
|
|
||||||
when (rv /= old) do
|
when (rv /= old) do
|
||||||
debug $ yellow "REFLOG UPDATED" <+> pretty r <+> pretty x
|
debug $ yellow "REFLOG UPDATED" <+> pretty r <+> pretty x
|
||||||
atomically $ modifyTVar cached (HM.insert r x)
|
atomically $ modifyTVar cached (HM.insert r x)
|
||||||
|
|
@ -569,8 +589,15 @@ updateIndexPeriodially = do
|
||||||
debug $ red "SYNC" <+> pretty cmd
|
debug $ red "SYNC" <+> pretty cmd
|
||||||
void $ runProcess $ shell 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 :: DashBoardPerks m => m ()
|
||||||
quit = liftIO exitSuccess
|
quit = liftIO exitSuccess
|
||||||
|
|
|
||||||
|
|
@ -25,7 +25,7 @@ import DBPipe.SQLite hiding (insert)
|
||||||
import DBPipe.SQLite qualified as S
|
import DBPipe.SQLite qualified as S
|
||||||
import DBPipe.SQLite.Generic as G
|
import DBPipe.SQLite.Generic as G
|
||||||
|
|
||||||
|
import Data.List.Split (chunksOf)
|
||||||
import Data.Aeson as Aeson
|
import Data.Aeson as Aeson
|
||||||
import Data.ByteString.Lazy.Char8 qualified as LBS8
|
import Data.ByteString.Lazy.Char8 qualified as LBS8
|
||||||
import Data.ByteString.Lazy (ByteString)
|
import Data.ByteString.Lazy (ByteString)
|
||||||
|
|
@ -36,6 +36,8 @@ import Data.Either
|
||||||
import Data.List qualified as List
|
import Data.List qualified as List
|
||||||
import Data.Map qualified as Map
|
import Data.Map qualified as Map
|
||||||
import Data.Map (Map)
|
import Data.Map (Map)
|
||||||
|
import Data.HashMap.Strict qualified as HM
|
||||||
|
import Data.HashSet qualified as HS
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
import System.Directory
|
import System.Directory
|
||||||
|
|
||||||
|
|
@ -690,18 +692,36 @@ instance FromRow BlobInfo
|
||||||
|
|
||||||
type TreeLocator = [(TreeParent, TreeTree, TreeLevel, TreePath)]
|
type TreeLocator = [(TreeParent, TreeTree, TreeLevel, TreePath)]
|
||||||
|
|
||||||
|
|
||||||
insertBlob :: DashBoardPerks m
|
insertBlob :: DashBoardPerks m
|
||||||
=> (BlobHash, BlobName, BlobSize, BlobSyn)
|
=> (BlobHash, BlobName, BlobSize, BlobSyn)
|
||||||
-> DBPipeM m ()
|
-> DBPipeM m ()
|
||||||
insertBlob (h,n,size,syn) = do
|
insertBlob (h, n, size, syn) = do
|
||||||
S.insert [qc|
|
S.insert [qc|
|
||||||
insert into blob (hash,name,size,syntax)
|
insert into blob (hash, name, size, syntax)
|
||||||
values (?,?,?,?)
|
values (?,?,?,?)
|
||||||
on conflict (hash)
|
on conflict (hash)
|
||||||
do update set name = excluded.name
|
do update set name = excluded.name
|
||||||
, size = excluded.size
|
, size = excluded.size
|
||||||
, syntax = excluded.syntax
|
, 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)
|
selectBlobInfo :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||||
|
|
@ -758,8 +778,8 @@ readBlob repo hash = do
|
||||||
<&> fromRight mempty
|
<&> fromRight mempty
|
||||||
|
|
||||||
|
|
||||||
updateForks :: (MonadIO m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> m ()
|
updateForks :: (MonadIO m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> DBPipeM m ()
|
||||||
updateForks lww = withState do
|
updateForks lww = do
|
||||||
|
|
||||||
S.insert [qc|
|
S.insert [qc|
|
||||||
insert into fork (a,b)
|
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)
|
select [qc|select 1 from repocommit where lww = ? and kommit = ?|] (lww, co)
|
||||||
<&> listToMaybe @(Only Int) <&> isJust
|
<&> 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)
|
listCommits :: (MonadUnliftIO m, MonadReader DashBoardEnv m)
|
||||||
=> LWWRefKey HBS2Basic -> m [GitHash]
|
=> LWWRefKey HBS2Basic -> m [GitHash]
|
||||||
listCommits lww = do
|
listCommits lww = do
|
||||||
|
|
@ -837,46 +864,46 @@ getRootTree lww co = do
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
updateRepoData :: (MonadReader DashBoardEnv m, MonadUnliftIO m)
|
updateRepoData :: (MonadReader DashBoardEnv m, MonadUnliftIO m)
|
||||||
=> LWWRefKey HBS2Basic -> GitHash -> m ()
|
=> LWWRefKey HBS2Basic -> GitHash -> DBPipeM m ()
|
||||||
updateRepoData lww co = do
|
updateRepoData lww co = do
|
||||||
|
|
||||||
env <- ask
|
env <- ask
|
||||||
|
|
||||||
void $ runMaybeT do
|
void $ runMaybeT do
|
||||||
|
|
||||||
root <- lift (getRootTree lww co) >>= toMPlus
|
root <- lift (lift (getRootTree lww co)) >>= toMPlus
|
||||||
(trees, blobs) <- lift $ getTreeRecursive lww co
|
(trees, blobs) <- lift $ lift $ getTreeRecursive lww co
|
||||||
|
|
||||||
-- lift $ addJob $ liftIO $ withDashBoardEnv env do
|
-- lift $ addJob $ liftIO $ withDashBoardEnv env do
|
||||||
|
|
||||||
lift $ withState $ transactional do
|
-- lift $ withState do
|
||||||
|
lift do
|
||||||
insert @RepoCommitTable $
|
insert @RepoCommitTable $
|
||||||
onConflictIgnore @RepoCommitTable (RepoLww lww, RepoCommit co)
|
onConflictIgnore @RepoCommitTable (RepoLww lww, RepoCommit co)
|
||||||
|
|
||||||
for_ blobs $ \(fn, (hash, size, syn)) -> do
|
for_ blobs $ \(fn, (hash, size, syn)) -> do
|
||||||
insertBlob (BlobHash hash, BlobName fn, BlobSize size, BlobSyn syn)
|
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
|
case t of
|
||||||
[x] -> insertTree (TreeCommit co,TreeParent root,TreeTree h0,1,TreePath x)
|
[x] -> insertTree (TreeCommit co,TreeParent root,TreeTree h0,1,TreePath x)
|
||||||
_ -> pure ()
|
_ -> pure ()
|
||||||
|
|
||||||
let child = tailSafe t
|
let child = tailSafe t
|
||||||
debug $ red "TREE-REL:" <+> pretty t
|
debug $ red "TREE-REL:" <+> pretty t
|
||||||
let parent = Map.lookup child trees
|
let parent = Map.lookup child trees
|
||||||
|
|
||||||
for_ parent $ \p -> do
|
for_ parent $ \p -> do
|
||||||
debug $ red "FOUND SHIT:" <+> pretty (h0,p)
|
debug $ red "FOUND SHIT:" <+> pretty (h0,p)
|
||||||
insertTree ( TreeCommit co
|
insertTree ( TreeCommit co
|
||||||
, TreeParent p
|
, TreeParent p
|
||||||
, TreeTree h0
|
, TreeTree h0
|
||||||
, TreeLevel (length t)
|
, TreeLevel (length t)
|
||||||
, TreePath (headDef "" t)
|
, TreePath (headDef "" t)
|
||||||
)
|
)
|
||||||
|
|
||||||
updateForks lww
|
-- updateForks lww
|
||||||
|
|
||||||
buildSingleCommitTreeIndex :: ( MonadUnliftIO m
|
buildSingleCommitTreeIndex :: ( MonadUnliftIO m
|
||||||
, DashBoardPerks m
|
, DashBoardPerks m
|
||||||
|
|
@ -894,7 +921,9 @@ buildSingleCommitTreeIndex lww co = do
|
||||||
done <- checkCommitProcessed lww co
|
done <- checkCommitProcessed lww co
|
||||||
let skip = done && not ignoreCaches
|
let skip = done && not ignoreCaches
|
||||||
guard (not skip)
|
guard (not skip)
|
||||||
lift $ updateRepoData lww co
|
lift $ withState $ transactional $ do
|
||||||
|
updateRepoData lww co
|
||||||
|
updateForks lww
|
||||||
|
|
||||||
buildCommitTreeIndex :: ( MonadUnliftIO m
|
buildCommitTreeIndex :: ( MonadUnliftIO m
|
||||||
, DashBoardPerks m
|
, DashBoardPerks m
|
||||||
|
|
@ -904,16 +933,26 @@ buildCommitTreeIndex :: ( MonadUnliftIO m
|
||||||
-> m ()
|
-> m ()
|
||||||
buildCommitTreeIndex lww = do
|
buildCommitTreeIndex lww = do
|
||||||
|
|
||||||
commits <- listCommits lww
|
|
||||||
|
debug $ red "buildCommitTreeIndex" <+> pretty lww
|
||||||
|
|
||||||
env <- ask
|
env <- ask
|
||||||
|
|
||||||
ignoreCaches <- getIgnoreCaches
|
ignoreCaches <- getIgnoreCaches
|
||||||
|
|
||||||
for_ commits $ \co -> void $ runMaybeT do
|
doneCommits <- listCommitsProcessed lww <&> HS.fromList
|
||||||
done <- checkCommitProcessed lww co
|
|
||||||
let skip = done && not ignoreCaches
|
commits <- listCommits lww <&> filter (not . flip HS.member doneCommits)
|
||||||
guard (not skip)
|
let chunks = chunksOf 100 commits
|
||||||
lift $ addJob $ withDashBoardEnv env (updateRepoData lww co)
|
|
||||||
|
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
|
-- FIXME: check-names-with-spaces
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -13,12 +13,31 @@ import HBS2.System.Dir
|
||||||
|
|
||||||
import Streaming.Prelude qualified as S
|
import Streaming.Prelude qualified as S
|
||||||
|
|
||||||
|
import Data.HashMap.Strict qualified as HM
|
||||||
import System.Process.Typed
|
import System.Process.Typed
|
||||||
|
|
||||||
{- HLINT ignore "Functor law" -}
|
{- HLINT ignore "Functor law" -}
|
||||||
|
|
||||||
seconds = TimeoutSec
|
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
|
updateFixmeFor :: ( MonadUnliftIO m
|
||||||
, MonadReader DashBoardEnv m
|
, MonadReader DashBoardEnv m
|
||||||
)
|
)
|
||||||
|
|
@ -101,6 +120,7 @@ updateIndexFromPeer = do
|
||||||
lift $ S.yield (lw, RepoHeadTx tx, RepoHeadRef rhh, rhead, fme)
|
lift $ S.yield (lw, RepoHeadTx tx, RepoHeadRef rhh, rhead, fme)
|
||||||
|
|
||||||
withState $ transactional do
|
withState $ transactional do
|
||||||
|
-- withState do
|
||||||
for_ headz $ \(l, tx, rh, rhead, fme) -> do
|
for_ headz $ \(l, tx, rh, rhead, fme) -> do
|
||||||
let rlwwseq = RepoLwwSeq (fromIntegral $ lwwSeq wv)
|
let rlwwseq = RepoLwwSeq (fromIntegral $ lwwSeq wv)
|
||||||
insertRepoHead l rlwwseq (RepoRefLog rk) tx rh rhead
|
insertRepoHead l rlwwseq (RepoRefLog rk) tx rh rhead
|
||||||
|
|
@ -110,7 +130,9 @@ updateIndexFromPeer = do
|
||||||
for_ fme $ \f -> do
|
for_ fme $ \f -> do
|
||||||
insertRepoFixme l rlwwseq f
|
insertRepoFixme l rlwwseq f
|
||||||
|
|
||||||
-- buildCommitTreeIndex (coerce lw)
|
-- WTF?
|
||||||
|
env <- ask
|
||||||
|
buildCommitTreeIndex (coerce lw)
|
||||||
|
|
||||||
fxe <- selectRepoFixme
|
fxe <- selectRepoFixme
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -20,6 +20,8 @@ import HBS2.System.Dir
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
|
|
||||||
import Data.Word
|
import Data.Word
|
||||||
|
import Data.HashMap.Strict (HashMap)
|
||||||
|
import Data.HashMap.Strict qualified as HM
|
||||||
|
|
||||||
type MyRefChan = RefChanId L4Proto
|
type MyRefChan = RefChanId L4Proto
|
||||||
type MyRefLogKey = RefLogKey 'HBS2Basic
|
type MyRefLogKey = RefLogKey 'HBS2Basic
|
||||||
|
|
@ -58,6 +60,7 @@ data DashBoardEnv =
|
||||||
, _dashBoardHttpPort :: TVar (Maybe Word16)
|
, _dashBoardHttpPort :: TVar (Maybe Word16)
|
||||||
, _dashBoardDevAssets :: TVar (Maybe FilePath)
|
, _dashBoardDevAssets :: TVar (Maybe FilePath)
|
||||||
, _dashBoardIndexIgnoreCaches :: TVar Bool
|
, _dashBoardIndexIgnoreCaches :: TVar Bool
|
||||||
|
, _repoCommitIndexWIP :: TVar (HashMap (LWWRefKey 'HBS2Basic) Int)
|
||||||
}
|
}
|
||||||
|
|
||||||
makeLenses 'DashBoardEnv
|
makeLenses 'DashBoardEnv
|
||||||
|
|
@ -96,6 +99,7 @@ newDashBoardEnv ddir peer rlog rchan lww sto = do
|
||||||
<*> newTVarIO (Just 8911)
|
<*> newTVarIO (Just 8911)
|
||||||
<*> newTVarIO Nothing
|
<*> newTVarIO Nothing
|
||||||
<*> newTVarIO False
|
<*> newTVarIO False
|
||||||
|
<*> newTVarIO mempty
|
||||||
|
|
||||||
getHttpPortNumber :: (MonadIO m, MonadReader DashBoardEnv m, Integral a) => m a
|
getHttpPortNumber :: (MonadIO m, MonadReader DashBoardEnv m, Integral a) => m a
|
||||||
getHttpPortNumber = do
|
getHttpPortNumber = do
|
||||||
|
|
@ -131,7 +135,7 @@ withState f = do
|
||||||
|
|
||||||
SConnect -> do
|
SConnect -> do
|
||||||
notice $ yellow "connecting to db"
|
notice $ yellow "connecting to db"
|
||||||
dbe <- liftIO $ try @_ @SomeException (newDBPipeEnv dbPipeOptsDef dbFile)
|
dbe <- liftIO $ try @_ @SomeException (newDBPipeEnv (dbPipeOptsDef {dbPipeBatchTime = 1}) dbFile)
|
||||||
|
|
||||||
case dbe of
|
case dbe of
|
||||||
Right e -> do
|
Right e -> do
|
||||||
|
|
@ -156,6 +160,8 @@ addJob f = do
|
||||||
q <- asks _pipeline
|
q <- asks _pipeline
|
||||||
atomically $ writeTQueue q f
|
atomically $ writeTQueue q f
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
hbs2_git_dashboard :: FilePath
|
hbs2_git_dashboard :: FilePath
|
||||||
hbs2_git_dashboard = "hbs2-git-dashboard"
|
hbs2_git_dashboard = "hbs2-git-dashboard"
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -98,3 +98,5 @@ repoFixme q@(FromParams p') lww = do
|
||||||
, hxSwap_ "afterend"
|
, hxSwap_ "afterend"
|
||||||
] do
|
] do
|
||||||
td_ [colspan_ "3"] mempty
|
td_ [colspan_ "3"] mempty
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -152,3 +152,5 @@ issuePage repo@(RepoLww lww) f = rootPage do
|
||||||
where
|
where
|
||||||
trim before seize txt =
|
trim before seize txt =
|
||||||
Text.lines txt & drop before & take seize & Text.unlines
|
Text.lines txt & drop before & take seize & Text.unlines
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -114,6 +114,7 @@ library hbs2-git-dashboard-core
|
||||||
, skylighting-lucid
|
, skylighting-lucid
|
||||||
, stm
|
, stm
|
||||||
, streaming
|
, streaming
|
||||||
|
, split
|
||||||
, temporary
|
, temporary
|
||||||
, text
|
, text
|
||||||
, time
|
, time
|
||||||
|
|
|
||||||
|
|
@ -162,6 +162,9 @@ library
|
||||||
HBS2.Peer.Proto.AnyRef
|
HBS2.Peer.Proto.AnyRef
|
||||||
HBS2.Peer.Proto.LWWRef
|
HBS2.Peer.Proto.LWWRef
|
||||||
HBS2.Peer.Proto.LWWRef.Internal
|
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.Proto.BrowserPlugin
|
||||||
|
|
||||||
HBS2.Peer.RPC.Client
|
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