From 39e790ef3277160801af0678774fd681cad1dbc7 Mon Sep 17 00:00:00 2001 From: voidlizard Date: Wed, 30 Oct 2024 08:19:32 +0300 Subject: [PATCH] storage w. AnyProbe --- .fixme-new/config | 4 +- Makefile | 24 + docs/papers/Makefile | 14 +- docs/papers/hbs2-mailbox.tex | 758 ++++++++++++++ fixme-new/lib/Fixme/Types.hs | 1 - hbs2-cli/app/Main.hs | 4 + hbs2-cli/hbs2-cli.cabal | 3 + hbs2-cli/lib/HBS2/CLI/Run/Internal.hs | 22 + hbs2-cli/lib/HBS2/CLI/Run/Mailbox.hs | 305 ++++++ hbs2-cli/lib/HBS2/CLI/Run/Peer.hs | 30 +- hbs2-cli/lib/HBS2/CLI/Run/Sigil.hs | 69 +- hbs2-cli/lib/HBS2/CLI/Run/Tree.hs | 47 + hbs2-core/lib/HBS2/Data/Types/SignedBox.hs | 1 + .../HBS2/Data/Types/SmallEncryptedBlock.hs | 2 +- .../lib/HBS2/Net/Auth/Credentials/Sigil.hs | 1 + hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs | 23 +- hbs2-core/lib/HBS2/Net/Messaging/TCP.hs | 11 +- hbs2-git-dashboard/app/GitDashBoard.hs | 61 +- .../HBS2/Git/DashBoard/State.hs | 107 +- .../HBS2/Git/DashBoard/State/Index/Peer.hs | 24 +- .../HBS2/Git/DashBoard/Types.hs | 8 +- .../HBS2/Git/Web/Html/Fixme.hs | 2 + .../HBS2/Git/Web/Html/Issue.hs | 2 + hbs2-git-dashboard/hbs2-git-dashboard.cabal | 1 + hbs2-peer/app/CLI/Mailbox.hs | 411 ++++++++ hbs2-peer/app/MailboxProtoWorker.hs | 970 ++++++++++++++++++ hbs2-peer/app/PeerMain.hs | 26 + hbs2-peer/app/RPC2.hs | 2 + hbs2-peer/app/RPC2/Mailbox.hs | 110 ++ hbs2-peer/app/RefChan.hs | 2 - hbs2-peer/app/RefLog.hs | 2 +- hbs2-peer/hbs2-peer.cabal | 13 +- hbs2-peer/lib/HBS2/Peer/Proto.hs | 11 + hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs | 330 ++++++ .../lib/HBS2/Peer/Proto/Mailbox/Entry.hs | 66 ++ .../lib/HBS2/Peer/Proto/Mailbox/Message.hs | 161 +++ .../lib/HBS2/Peer/Proto/Mailbox/Policy.hs | 37 + .../HBS2/Peer/Proto/Mailbox/Policy/Basic.hs | 125 +++ hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Ref.hs | 43 + .../lib/HBS2/Peer/Proto/Mailbox/Types.hs | 238 +++++ .../lib/HBS2/Peer/Proto/RefChan/Types.hs | 1 + hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs | 78 ++ hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs | 32 +- .../lib/HBS2/Storage/Simple.hs | 41 +- .../fuzzy-parse/src/Data/Text/Fuzzy/SExp.hs | 11 +- .../lib/Data/Config/Suckless/Script/File.hs | 10 +- .../Data/Config/Suckless/Script/Internal.hs | 284 ++++- .../lib/Data/Config/Suckless/Syntax.hs | 106 +- test/RT/test-basic-policy-1.baseline | 33 + test/RT/test-basic-policy-1.rt | 86 ++ 50 files changed, 4566 insertions(+), 187 deletions(-) create mode 100644 docs/papers/hbs2-mailbox.tex create mode 100644 hbs2-cli/lib/HBS2/CLI/Run/Mailbox.hs create mode 100644 hbs2-cli/lib/HBS2/CLI/Run/Tree.hs create mode 100644 hbs2-peer/app/CLI/Mailbox.hs create mode 100644 hbs2-peer/app/MailboxProtoWorker.hs create mode 100644 hbs2-peer/app/RPC2/Mailbox.hs create mode 100644 hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs create mode 100644 hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Entry.hs create mode 100644 hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Message.hs create mode 100644 hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Policy.hs create mode 100644 hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Policy/Basic.hs create mode 100644 hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Ref.hs create mode 100644 hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs create mode 100644 hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs create mode 100644 test/RT/test-basic-policy-1.baseline create mode 100644 test/RT/test-basic-policy-1.rt diff --git a/.fixme-new/config b/.fixme-new/config index cfda0c85..0c993698 100644 --- a/.fixme-new/config +++ b/.fixme-new/config @@ -17,7 +17,7 @@ fixme-attribs :committer-name :commit-time fixme-value-set :workflow :new :backlog :wip :test :fixed :done :ready :merged -fixme-value-set class hardcode performance boilerplate +fixme-value-set class hardcode performance boilerplate ui ; fixme-value-set cat bug feat refactor @@ -50,7 +50,7 @@ fixme-comments ";" "--" (align 8 $class) " " (align 12 $assigned) " " (align 20 (trim 20 $committer-name)) " " - (trim 50 ($fixme-title)) " " + (trim 40 ($fixme-title)) " " (nl)) ) ) diff --git a/Makefile b/Makefile index ae956ff7..a2873fa4 100644 --- a/Makefile +++ b/Makefile @@ -5,6 +5,13 @@ SHELL := bash MAKEFLAGS += --warn-undefined-variables MAKEFLAGS += --no-builtin-rules +RT_DIR := test/RT + +VPATH += test/RT + +RT_FILES := $(wildcard $(RT_DIR)/*.rt) +OUT_FILES := $(RT_FILES:.rt=.out) + GHC_VERSION := 9.6.6 BIN_DIR := ./bin BINS := \ @@ -21,11 +28,28 @@ BINS := \ fixme-new \ hbs2-storage-simple-benchmarks \ +RT_DIR := tests/RT + ifeq ($(origin .RECIPEPREFIX), undefined) $(error This Make does not support .RECIPEPREFIX. Please use GNU Make 4.0 or later) endif .RECIPEPREFIX = > +rt: $(OUT_FILES) + +%.out: %.rt +> @hbs2-cli --run $< > $(dir $<)$(notdir $@) +> @hbs2-cli \ + [define r [eq? [parse:top:file root $(dir $<)$(notdir $@)] \ + [parse:top:file root $(dir $<)$(basename $(notdir $@)).baseline]]] \ + and [print '"[RT]"' space \ + [if r [ansi green _ [concat ✅ OK space space]] \ + [ansi red~ _ [concat ❌FAIL]]] \ + : space $(notdir $(basename $@))] \ + and println + +> $(RM) $(dir $<)$(notdir $@) + $(BIN_DIR): > @mkdir -p $@ diff --git a/docs/papers/Makefile b/docs/papers/Makefile index 9982299e..525e50cd 100644 --- a/docs/papers/Makefile +++ b/docs/papers/Makefile @@ -5,7 +5,7 @@ $(basename $(1))-$(REV)$(suffix $(1)) endef -all: hbs2-git-problem hbs2-git-new-repo hbs2-git-doc +all: hbs2-git-problem hbs2-git-new-repo hbs2-git-doc hbs2-mailbox .PHONY: all clean @@ -20,13 +20,23 @@ hbs2-git-new-repo: hbs2-git-new-repo.pdf hbs2-git-doc: hbs2-git-doc-0.24.1.pdf +hbs2-mailbox: hbs2-mailbox.pdf + publish-hbs2-git-doc: hbs2-git-doc-0.24.1.pdf $(eval TARGET := $(call make_target,$<)) $(eval HASH := $(shell hbs2 metadata create --hash --auto $(TARGET))) @echo Updating $(HBS2GITDOCLWW) $(HASH) hbs2-peer lwwref update -v $(HASH) $(HBS2GITDOCLWW) -publish: publish-hbs2-git-doc + +publish-hbs2-mailbox: hbs2-mailbox.pdf + @echo not implemented yet + # $(eval TARGET := $(call make_target,$<)) + # $(eval HASH := $(shell hbs2 metadata create --hash --auto $(TARGET))) + # @echo Updating $(HBS2GITDOCLWW) $(HASH) + # hbs2-peer lwwref update -v $(HASH) $(HBS2GITDOCLWW) + +publish: publish-hbs2-git-doc publish-hbs2-mailbox clean: rm -f *.aux *.log *.nav *.out *.snm *.vrb *.toc *.pdf diff --git a/docs/papers/hbs2-mailbox.tex b/docs/papers/hbs2-mailbox.tex new file mode 100644 index 00000000..64cd48d0 --- /dev/null +++ b/docs/papers/hbs2-mailbox.tex @@ -0,0 +1,758 @@ +% +\documentclass[11pt,a4paper]{article} + +\usepackage{polyglossia} +\usepackage{xltxtra} +\usepackage[margin=2cm,a4paper]{geometry}% http://ctan.org/pkg/geometry +\usepackage{pdfpages} +\usepackage{graphicx} +\usepackage[ddmmyyyy]{datetime} +\usepackage{booktabs} +\usepackage{enumitem} +\usepackage{amssymb} +\usepackage{amsmath} +\usepackage{bm} +\usepackage[nomessages]{fp} +\usepackage{caption} +\usepackage{url} +\usepackage{indentfirst} +\usepackage[parfill]{parskip} +\usepackage[ colorlinks=true + , linkcolor=black + , anchorcolor=black + , citecolor=black + , filecolor=black + , menucolor=black + , runcolor=black + , urlcolor=blue]{hyperref} +\usepackage{tikz} +\usetikzlibrary{arrows,snakes,shapes,backgrounds,positioning,calc} +\usepackage{marvosym} +\usepackage{pifont} +\usepackage{fontspec} +\usepackage{fontawesome5} +\usepackage{listings} +\usepackage{verbatim} +\usepackage{xcolor} +\usepackage{float} % Needed for the floating environment + +\setmainlanguage{russian} +\defaultfontfeatures{Ligatures=TeX,Mapping=tex-text} +\setmainfont{Liberation Serif} +\newfontfamily\cyrillicfont{Liberation Serif}[Script=Cyrillic] +\newfontfamily{\cyrillicfonttt}{Liberation Mono}[Scale=0.8] + +\setlist{noitemsep} +\setlength{\intextsep}{2cm} + +\newcommand{\term}[2]{\textit{#2}} +\newcommand{\Peer}{\term{peer}{пир}} +\newcommand{\Relay}{\term{relay}{Relay}} +\newcommand{\Acc}{\term{acc}{Accumulator}} +\newcommand{\Dude}{\term{dude}{Dude}} +\newcommand{\Mailbox}{\term{mailbox}{Mailbox}} +\renewcommand{\dateseparator}{.} +\renewcommand*\contentsname{Содержание} + +\lstset{ + language=Haskell, + basicstyle=\ttfamily\small, + keywordstyle=\color{blue}, + commentstyle=\color{green}, + stringstyle=\color{red}, + % numberstyle=\tiny\color{gray}, + % numbers=left, + % stepnumber=1, + showstringspaces=false, + breaklines=true, + frame=single, +} + +\newfloat{Code}{t}{myc} + +\graphicspath{ {img/}} + +\title{Протокол <>} + +\begin{document} + +\maketitle + +\section{О документе} + +Документ рассматривает протокол доставки данных <> по паттерну $* +\rightarrow 1$ <> в P2P окружении, как подпротокола для hbs2-peer. + +Протокол предполагается к использованию в ситуациях, когда между +\term{actor}{акторами} нет общего авторизованного канала связи (в смысле +hbs2-peer). + +Протокол не подразумевает нахождения акторов постоянно онлайн. + +Протокол не подразумевает использования механизмов вроде DNS, сертификатов PKCS +и Authority, или каких-либо (скомпрометированных) централизованных сервисов. + +Протокол не подразумевает постоянной связности сети. + +Для адресации используются публичные ключи подписи. + +Для E2E шифрования используется механизм групповых ключей. + +Для упаковки и распространения данных используются примитивы hbs2-peer: +\term{block}{блоки}, \term{merkle}{(шифрованные) деревья Меркла} с метаданными, +и протоколы для работы с ними. + +Отличие от протоколов IMAP,SMTP,POP3 в том, что это другой протокол для другого +окружения и исходящий из других предпосылок. + +Теоретически, в качестве несложного упражнения, можно поднять сервер IMAP как +локальный фронтенд для hbs2-peer и тогда это будет IMAP-via-P2P. + +\section{Предпосылки} + +В текущей реализации HBS2 существуют следующие релевантные виды каналов +(протоколов,\term{ref}{ссылок}): + +\paragraph{RefLog:} + +Обеспечивает коммуникацию по паттерну $1 \rightarrow *$, то есть один -- ко +всем, канал распространяет сообщения одного автора. Пруфом записи является +подпись \term{ksign}{ключом подписи} автора. \term{peer}{Пиры} должны +подписаться на канал для его распространения, распространять канал (ссылку) +может любой любой подписанный на него \term{peer}{пир}, так как валидность +записей проверяется подписью автора. Канал является \term{GSET}{CRDT G-SET} +записей. + +Метафорой рефлога может являться твиттер-аккаунт либо канал в телеграме, с одним +писателем и множеством подписчиков. + + +\paragraph{RefChan:} + +Обеспечивает коммуникацию по паттерну ${A} \rightarrow {R}$, то есть определяет +множество \term{author}{авторов} $A$ и множество \term{reader}{читателей} $R$, и +пруфом записи является подпись \term{author}{автора}, а +\term{permission}{разрешением} на чтение --- опциональное шифрование сообщения +\term{GK0}{групповым ключом}, куда входят читатели $R$, то есть $GK = \{ k_i +\}_{i \in R}$, где каждый $k_i$ --- секретный ключ, зашифрованный публичным +ключом $r_i$ из множества $R$. + +Кроме того, \term{refchan}{RefChan} определяет множество пиров ${P}$, которые +могут отправлять сообщение в данный \term{refchan}{RefChan} и принимаются только +такие сообщения. + +Данное ограничение необходимо для борьбы с атакой Сивиллы в случае, если \Peer{} +игнорирует настройки ${A}$. + +Кроме того, у \term{refchan}{рефчана} есть владелец, который может менять +настройки $A,R$, а блок настроек представляет собой \term{lww}{CRDT LWW регистр} +со ссылкой на блок настроек, подписанный ключом владельца. + +Как видно, распространять сообщения из \term{refchan}{рефчана} могут только пиры +$p_i \in P$ + +То есть, распространять транзакции может кто угодно, т.к каждая транзакция +подписана ключом \term{peer}{пира}, но вот при запросе состояния будут +учитываться только ответы пиров $p_i \in P$. + +Метафорой \term{refchan}{рефчана} является модерируемый чат с ограниченным +множеством участников и администраторами. + +Таким образом, при наличии этих протоколов, мы можем + +\begin{enumerate} + +\item посылать сообщения от одного автора всему миру, то есть тем пирам, которые + слушают (подписаны) на данный рефлог или + +\item осуществлять коммуникацию между ограниченными множествами пиров и + авторов/читателей. + +\end{enumerate} + +Общим является то, что бы получать обновления рефлога или рефчана, мы (как пир) +должны быть на них \term{subscribed}{подписаны}, т.е мы должны знать, что такие +\term{ref}{ссылки} существуют и явно на них подписаться. + + +Возникает вопрос, как можно обеспечить коммуникацию между произвольными +\term{actor}{акторами} Алиса и Боб, у которых нет общего канала. + +Куда писать Алисе, что бы её сообщение достигло Боба? Рефчана, куда бы входили +бы и Алиса и Боб в общем случае еще не существует, канал связи отсутствует. + +Алиса может быть подписана на какую-то ссылку Боба, но Боб не подписан на каналы +Алисы. Или наоборот. + +Предлагается ввести новый протокол, \term{mailbox}{Mailbox}, который будет +обеспечивать коммуникацию по паттерну $ * \rightarrow 1 $, то есть кто угодно +может отправлять сообщения в почтовый ящик получателя. + +Получатель проверяет почтовый ящик и забирает оттуда сообщения. + +При этом обеспечивается отправка и доставка в условиях, когда \term{peer}{пиры} +получателя и отправителя не находятся онлайн всё время. + +Данный протокол может быть полезен при установлении канала связи (например, +создании общего рефчана), или просто оффлайн обмене сообщениями в условиях +необязательного наличия каналов, например, при рассылке патчей и пулл/мерж +реквестов в git или создании тикетов или для отсылки \textit{реакций}, в общем +--- в любом случае, когда между акторами нет какого-то прямого канала. + +Важным является то, что получатель подписан только на свои, известные ему +каналы, куда все (при выполнении определённых условий) могут отправлять +сообщения. + + +\section{Протокол} + +Протокол является подпротоколом \textit{hbs2-peer} и в отношении него верно всё, +что верно для семейства этих протоколов --- авторизация и аутентификация пиров, +черные и белые списки пиров, транспортное шифрование сообщений через ByPass и +так далее. + +Идентификаторами являются публичные ключи подписи и шифрования. + +Для e2e шифрования используется тот же механизм групповых ключей. + +Передаваемыми единицами являются либо короткие сообщения +\texttt{SmallEncryptedBlock} либо \term{merkle}{деревья Меркла} с шифрованием и +метаданными. + +Протокол использует примитивы \textit{hbs2-core} и \textit{hbs2-peer}, как +минимум: + +\begin{itemize} + \item[-] SignedBox + \item[-] SmallEncryptedBlock + \item[-] MerkleTree +\end{itemize} + +Протокол определяет служебные сообщения, специфичные для него, однако обмен +данными идёт через обычные протоколы (GetBlock,GetBlockSize). + +Короткие сообщения могут доставляться непосредственно через (сигнальные) +сообщения протокола. + +\subsection{Участники} + +\paragraph{Пир} Узел hbs2, поддерживающий данный протокол + +\paragraph{Актор} также \term{dude}{Dude}. Отправители и получатели сообщений. + +Требуется определить, что явлется идентификатором, или идентификаторами \Dude{}. + +\paragraph{Message} Сообщение. + +Определяется отправителем, получателем (получателями?), и содержимым. +Видится,что сообщения могут быть двух классов: \textit{маленькое}, где всё +сообщение вместе со служебной информацией помещается в один пакет и может быть +доставлено непосредственно через коммуникационный протокол (GOSSIP), и +\textit{большое}, когда \Peer{} поддерживающий данный протокол -- будет +выкачивать все ссылки на части сообщения (большой текст, аттачменты и т.п.) + +\paragraph{Mailbox} Единица хранения и распространения сообщений. + +Mailbox бывают видов \term{Relay}{Relay} и \term{Accumulator}{Accumulator}. + +Разница между ними в том, что \Relay{} просто принимает и выкачивает сообщения, +пришедшие по протоколу, и не пытается опрашивать соседей и объединять все +известные сообщения дла \Dude{} в общее множество. + +Назначание \Relay{} --- временное хранение сообщений, пока их не заберёт один из +\term{acc}{аккумуляторов}. \Mailbox{} \Relay{} занимает фиксированное, заранее +определенное место на диске + +Поскольку мы в общем не знаем, забрали ли сообщение или нет, видится так, что +\Relay{} организует ограниченную очередь сообщений, и при исчерпании лимита +места, отведённого под почтовый ящик -- просто удаляет наиболее старые сообщения +из очереди. + +Назначание \Acc{} -- хранить все сообщения для своего \Dude{}, т.е это его +<<распределённый почтовый аккаунт>>. + +То есть, \Acc{} образуют \term{GSET}{CRDT G-SET} сообщений, и постепенно +сходятся к одному значению (объединению всех сообщений всех \Acc{}). + +Очевидно, нужно предусмотреть или записи вида \textit{Tomb}, или иной способ +удаления сообщений, например, через команду протокола. + +\Acc{} опрашивает всех соседей, получает ссылки на \term{merkle}{деревья~Меркла} +сообщений, выкачивает сообщения и объединяет их в общее множество. + +\subsection{Примеры} + +\subsection*{Минимальная конфигурация} + +Два пира при условии наличия прямой сетевой доступности в обоих направлениях. + +\begin{figure}[h!] +\centering +\begin{tikzpicture}[ every label/.style={font=\scriptsize}, + every node/.style={font=\scriptsize}, + handle/.style={ draw=black + , circle + , inner sep=2pt + }, + box/.style={ draw=black + , rounded corners, + , anchor=base + , font=\scriptsize + , minimum height=1.5cm + , text width=1.5cm + , align=center + }, + ] + + \node[box,minimum height=2cm,label={below:{hbs2-peer}}] (dudeA) {{\underline{Dude~A}}\\ \Acc{}}; + \node[ box + , minimum height=2cm + , label={below:{hbs2-peer}} + , right=2.5cm of dudeA + ] (dudeB) {{\underline{Dude~B}}\\ \Acc{}}; + + \draw[<->] (dudeA) -- (dudeB) + node[midway,above] {Mailbox} + node[midway,below] {GOSSIP}; + + +\end{tikzpicture} +\caption{минимальная конфигурация} +\end{figure} + +\pagebreak + +\begin{itemize} + \item[-] Обмен сообщениями возможен только при одновременном нахождении обоих + пиров онлайн и наличия между ними связи + + \item[-] При потере узла Dude~A или Dude~B теряют все адресованные им сообщения +\end{itemize} + + +\subsection*{Примерно оптимальная конфигурация} + +\begin{figure}[h!] +\centering +\begin{tikzpicture}[ every label/.style={font=\scriptsize}, + every node/.style={font=\scriptsize}, + handle/.style={ draw=black + , circle + , inner sep=2pt + }, + box/.style={ draw=black + , rounded corners, + , anchor=base + , font=\scriptsize + , minimum height=1.5cm + , text width=1.5cm + , align=center + }, + ] + + \node[box,minimum height=2cm,label={below:{hbs2-peer}}] (dudeA) {{\underline{Dude~A}}\\ \Acc{}}; + + \node[ box + , minimum height=2cm + , label={below:{hbs2-peer}} + , right=1.5cm of dudeA + ] (relayA) {{\underline{Relay~1}}\\ \Relay{}}; + + \node[ box + , minimum height=2cm + , label={below:{hbs2-peer}} + , below=1.5cm of dudeA + ] (A1) {{\underline{A1}}\\ \Acc{}}; + + \node[ box + , minimum height=2cm + , label={below:{hbs2-peer}} + , right=1.5cm of relayA + ] (relayB) {{\underline{Relay~2}}\\ \Relay{}}; + + \node[ box + , minimum height=2cm + , label={below:{hbs2-peer}} + , right=1.5cm of relayB + ] (dudeB) {{\underline{Dude~B}}\\ \Acc{}}; + + \node[ box + , minimum height=2cm + , label={below:{hbs2-peer}} + , below=1.5cm of dudeB + ] (B1) {{\underline{B1}}\\ \Acc{}}; + + \node[ box, circle, draw, dashed + , minimum size=2.5cm + , minimum height=2.5cm + , yshift=-0.5cm + , right=2.75cm of A1 + , label={below: protocol} + ] (gossip) {{\underline{Mailbox}}\\GOSSIP }; + + + \draw[<->,dashed] (dudeA) -- (relayA); + \draw[<->,dashed] (dudeB) -- (relayB); + \draw[<->,dashed] (dudeA) -- (A1); + \draw[<->,dashed] (dudeB) -- (B1); + + \draw[<->,dashed] (dudeA) -- (gossip); + \draw[<->,dashed] (dudeB) -- (gossip); + \draw[<->,dashed] (relayA) -- (gossip); + \draw[<->,dashed] (relayB) -- (gossip); + \draw[<->,dashed] (A1) -- (gossip); + \draw[<->,dashed] (B1) -- (gossip); + +\end{tikzpicture} +\caption{Примерно оптимальная конфигурация} +\end{figure} + +\begin{itemize} +\item[-] Каждый Dude имеет некоторое количество Mailbox типа \Acc{} и \Relay{}. + +\item[-] Часть из них находится на пирах, которые большую часть времени + доступны. + +\item[-] Часть доступных пиров имеет между собой прямую связь по GOSSIP. + +\item[-] Не требуется полная связность сети между Dude~A и Dude~B, достаточно, + что бы была цепочка соединений, доступных хотя бы время от времени. + +\item[-] Сообщения Dude~A и Dude~B реплицированы между узлами типа \Acc{} (для + каждого Dude -- свои мейлбоксы, естественно) и сообщения будут утрачены + только в случае полной одновременной утраты всех узлов такого типа или если + на всех этих узлах будут удалены \term{mailbox}{мейлбоксы} для Dude~A или + Dude~B. +\end{itemize} + +\pagebreak + +\section{Структуры данных} + +\subsection{Message} + +\begin{figure}[h!] +\centering +\begin{tikzpicture}[ every label/.style={font=\scriptsize}, + every node/.style={font=\scriptsize}, + handle/.style={ draw=black + , circle + , inner sep=2pt + }, + box/.style={ draw=black + , rounded corners, + , anchor=base + , font=\scriptsize + , minimum height=1.5cm + , text width=1.5cm + , align=center + }, + ] + + \node[ draw + , minimum height=2cm + , minimum width=12cm + % , label={[yshift=5mm]south:SignedBox} + ] (msg) {}; + + + \node[draw,below=5mm of msg.north west,anchor=north west,xshift=2mm + ] (sender) {$Sender$}; + + \node[above=1.5cm of sender.north west, anchor = south west, text width=1.8cm] (label1) {Публичный ключ отправителя}; + + \draw[->] (label1.south) -- ($(sender.north west)!(label1.south)!(sender.north east)$); + + % \node[draw,below=5mm of msg.north west,anchor=north west,xshift=2mm + \node[draw,right=5mm of sender + ] (flags) {$\{F\}$}; + + \node[draw,right=1mm of flags + ] (rcpt) {$\{Recipients\}$}; + + \node[draw,right=1mm of rcpt + ] (gk) {$GK^*$}; + + \node[draw,right=1mm of gk + ] (ref) {$\{Ref\}$}; + + \node[draw,right=1mm of ref,minimum width=4cm + ] (payload) {$Payload$}; + + + \node[above=1.5cm of payload.north west, anchor = south west, text width=2cm] + (labelP) {SmallEncryptedBlock}; + + \draw[->] (labelP.south) -- ($(payload.north west)!(labelP.south)!(payload.north east)$); + + \node[ draw + , above=2mm of flags.north west, xshift=-2.5mm + , anchor=north west + , minimum width = 10cm + , minimum height = 1.1cm + , label={[yshift=-1mm]south:SignedBox} + ] (box) {}; + + +\end{tikzpicture} +\caption{Структура сообщения} +\end{figure} + +\paragraph{Sender:} Публичный (адрес) ключ подписи отправителя + +\paragraph{F:} Флаги (опции) сообщения. Например, TTL. TBD. + +\paragraph{Recipients:} Публичные ключи подписи (адреса) получателей + +Так как \term{peer}{пиру} нужно знать, в какой \Mailbox{} положить сообщение + + +\paragraph{GK:} (Опционально) групповой ключ шифрования, которым зашифровано +сообщение + +\paragraph{Refs:} Ссылки на части сообщения, (зашифрованные) +\term{merkle}{деревья} с метаданными + +\paragraph{Payload:} Непосредственное короткое сообщение + + +\section{Сообщения протокола} + +\subsection{SEND} + +Пир~A \Dude~A посылает сообщение \Dude~B или списку \Dude{} через Пир~X. + +Если Пир~X не поддерживает протокол -- то сообщение не обрабатывается. + +Если Пир~X поддерживает протокол -- то сообщение пересылается соседям Пир~X. + +Если Пир~X имеет \Mailbox{} для одного из получателей (\Dude{}) --- то сообщение +кладётся в \Mailbox{}. + +Если это \Acc{} -- то просто кладётся. Если задана квота на размер и размер +\Mailbox{} превышен (переполнен), то сообщение может игнорироваться. + +Если это \Relay{} то кладётся, если квота размера не превышена. Если превышена, +то удаляются наиболее старые сообщения, пока не освободится достаточно места на +диске. + +Если не удалось, то сообщение удаляется. + +Если сообщение содержит хэш-ссылки (вложения), то они скачиваются в соответствии +с политиками (размеры,etc). + +Каждая ссылка сообщения проверяется на целостность, скачивание продолжается, +пока оно не станет целостным или до тех пор, пока (определяется политикой). + +Если пир \Dude~A не имеет блоков, на которые ссылается сообщениe --- то мы +прекращаем скачивать зависимости. Возможно, такое сообщение стоит дропнуть. + +Авторизация: сообщение SEND подписано \Dude~A, отправителем сообщения. + +\subsection{CHECK-MAIL} + +Получатель (владелец \Mailbox{}) запрашивает хэш \term{merkle}{дерева Меркла} сообщений, +содержащихся в \Mailbox{}. + +Авторизация: сообщение SEND подписано \Dude --- владельцем \Mailbox{}. + +\subsection{MAIL-STATUS} + +Ответ на сообщение \texttt{CHECK-MAIL}, содержит хэш ссылку +\term{merkle}{дерева Меркла} сообщений, содержащихся в \Mailbox{} +или признак отсутствия сообщений. + +Поведение. Получаем сообщения из дерева, пишем в результат только валидные. + +Если затесались невалидные -- то это повод для каких-то действий в отношении +пира, который обслуживает \Mailbox{}. + +Авторизация: сообщение подписано \Dude --- владельцем \Mailbox{}. + +\subsection{DELETE} + +Удалить сообщение для \Mailbox{}. + +Содержит признак рассылать по GOSSIP или нет, допустим, оно адресовано только +одному конкретному узлу. + +Содержит предикат, какие сообщения удалять (все, для определенного отправителя, +старше, чем X, больше, чем X, и т.п.). TBD. + +Полезно для освобождения ресурсов и экономии сетевого трафика. + +Опциональное. + +Авторизация: сообщение подписано \Dude --- владельцем \Mailbox{}. + +\subsection{SET-POLICY} + +Устанавливает политики обработки сообщений и \Mailbox{}. + +Параметры: GOSSIP (да/нет) + +Данные: \term{term}{дерево Меркла} текстового файла с инструкциями. + +Авторизация: сообщение подписано \Dude --- владельцем \Mailbox{}. + +Инструкции: TBD, расширяемо. + +Возможный примерный вид: + +\begin{verbatim} + +dudes drop * +peers drop * + +dudes accept GmtNGbawvxqykjDaBiT3LsqP7xqDPHVTxqfBqoFQ6Mre + +dudes accept 3WtddmcE8zzgBAPR7Bu7mKMaVMTN423NNXSPUJp3Hx42 + +dudes delete G5K9QvFaomXdP4Y9HcYEt3diS2cCWyU8nBd2eTzrcq1j + +dude set-pow-factor 94wrDGvcnSitP8a6rxLSTPBhXSwdGYrQqkuk2FcuiM3T 10 + +peer set-pow-factor Gu5FxngYYwpRfCUS9DJBGyH3tvtjXFbcZ7CbxmJPWEGH 10 + +peers accept yFSaUfb97ZRtQqzHWdERsR7KJvN8qyWX1M8rJcxnsiu + +peer cooldown * 120 +peer cooldown yFSaUfb97ZRtQqzHWdERsR7KJvN8qyWX1M8rJcxnsiu 60 + +dude cooldown * 120 +dude cooldown G5K9QvFaomXdP4Y9HcYEt3diS2cCWyU8nBd2eTzrcq1j 300 + +\end{verbatim} + + +\section{Возможные атаки и противодействие им} + +\subsection{Спам} + +Массовые нежелательные рассылки. + +\paragraph{Тактика борьбы:} + +\begin{itemize} + \item[-] Отвергать сообщения с множеством реципиентов. + \item[-] Вводить cooldown периоды для пиров и \Dude{}. + \item[-] Вводить (общие) белые списки и принимать сообщения только от них. + \item[-] Сделать ненулевой стоимость попадания в белые списки. + \item[-] Ввести иструменты репутации и т.п. + \item[-] Ввести регулируемый PoW на сообщения. +\end{itemize} + +\subsubsection{DoS} + +Атаки на работоспособность пира и сети в целом. + +\subsubsection{Посылка огромных данных} + +TBD + +\subsubsection{Посылка невалидных данных} + +TBD + +\subsubsection{Ссылки на отсутствующие данные} + +TBD + +\subsubsection{Анализ метаданных, построение графа взаимодействий} + +Поскольку \texttt{GOSSIP} проходит через пиров и имеет открытые метаданные, +можно сохранять граф коммуникаций и запоминать публичные ключи. + +Что бы этому противодействовать -- можно только взаимодействовать с заведомо +надёжными пирами через, возможно, отдельную сеть. + +К сожалению. + +Для по-настоящему анонимного и неотслеживаемого общения нужно использовать +другие механизмы. + +\section{Примеры применения} + +\subsection{Issues/Pull requests} + + +\begin{figure}[h!] +\centering +\begin{tikzpicture}[ every label/.style={font=\scriptsize}, + every node/.style={font=\scriptsize}, + handle/.style={ draw=black + , circle + , inner sep=2pt + }, + box/.style={ draw=black + , rounded corners, + , anchor=base + , font=\scriptsize + , minimum height=1.5cm + , text width=1.5cm + , align=center + }, + db/.style={ cylinder + , draw + , fill=gray!10 + , minimum height=1cm + , minimum width=1.5cm + , shape border rotate=90 + , aspect=0.5 + } + ] + + \node[box] (hbs2-peer1) {hbs2-peer1}; + \node[box,right=3cm of hbs2-peer1] (hbs2-peer2) {\underline{hbs2-peer2}\\Relay}; + \node[box,below=3cm of hbs2-peer2] + (hbs2-peerN) + {\underline{hbs2-peerN}\\\Acc{}}; + + \draw[->] (hbs2-peer1) -- (hbs2-peer2) + node[below,midway] {MAILBOX:SEND} + node[above,midway] {PR~Message}; + + \draw[->] (hbs2-peer2) -- (hbs2-peerN) + node[left,midway] {MAILBOX:SEND} + node[left,midway,yshift=4mm] {PR~Message}; + + \node[box,right=2cm of hbs2-peerN] (process) {filter-process}; + + \node[box,right=2cm of process] (fixme) {fixme}; + + \node[db,right=1cm of fixme,anchor=west,yshift=-4mm] (db) {fixme-state}; + + \draw[->] (process.150) -- ($(hbs2-peerN.north east)!(process.150)!(hbs2-peerN.south east)$) + node[midway,above] {MAIL-CHECK}; + + \draw[->] (process.180) -- ($(hbs2-peerN.north east)!(process.180)!(hbs2-peerN.south east)$) + node[midway,above] {READ}; + + \draw[->] (process) -- (fixme) + node[above,midway] {import}; + + \draw[->] (fixme.south) -- ($(fixme.south) - (0,+2cm)$) -| (hbs2-peerN.south) + node[below,near start] {refchan:export}; + + \draw[->] (fixme.east) -- (db.152); + + +\end{tikzpicture} +\end{figure} + +Пользователь формирует сообщение специального вида (plaintext/fixme) которое +посылается по протоколу MAILBOX получателю -- владельцу мейлобокса, который +указан в manifest проекта, как контакт для посылки подобных сообщений. + +На некоем хосте существует процесс, который время от времени проверяет +\Mailbox{} и при обнаружении новых сообщений экспортирует их в fixme, +который, в свою очередь, помещает их в RefChan делая доступными и видимыми +для подписчиков этого рефчана. + +Обновления данного Issue/PR возможны, если в качестве fixme-key выбран некий +уникальный идентификатор, который и будет указан в каждом сообщении. + + +\end{document} + + diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index a8dc5c81..89afc136 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/fixme-new/lib/Fixme/Types.hs @@ -62,7 +62,6 @@ data MyPeerClientEndpoints = makeLenses 'MyPeerClientEndpoints -- FIXME: move-to-suckless-conf -deriving stock instance Ord (Syntax C) pattern FixmeHashLike :: forall {c} . Text -> Syntax c pattern FixmeHashLike e <- (fixmeHashFromSyn -> Just e) diff --git a/hbs2-cli/app/Main.hs b/hbs2-cli/app/Main.hs index e2fe2f6e..5d5780b4 100644 --- a/hbs2-cli/app/Main.hs +++ b/hbs2-cli/app/Main.hs @@ -10,10 +10,12 @@ import HBS2.CLI.Run.Keyring import HBS2.CLI.Run.GroupKey import HBS2.CLI.Run.Sigil import HBS2.CLI.Run.MetaData +import HBS2.CLI.Run.Tree 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 @@ -63,11 +65,13 @@ main = do keyringEntries groupKeyEntries sigilEntries + treeEntries metaDataEntries peerEntries reflogEntries refchanEntries lwwRefEntries + mailboxEntries helpEntries SF.entries diff --git a/hbs2-cli/hbs2-cli.cabal b/hbs2-cli/hbs2-cli.cabal index a26981d7..7179a924 100644 --- a/hbs2-cli/hbs2-cli.cabal +++ b/hbs2-cli/hbs2-cli.cabal @@ -70,6 +70,7 @@ common shared-properties , exceptions , filepath , filepattern + , generic-lens , hashable , interpolatedstring-perl6 , memory @@ -111,11 +112,13 @@ library HBS2.CLI.Run.GroupKey HBS2.CLI.Run.KeyMan HBS2.CLI.Run.Keyring + HBS2.CLI.Run.Tree HBS2.CLI.Run.MetaData HBS2.CLI.Run.Peer HBS2.CLI.Run.RefLog HBS2.CLI.Run.RefChan HBS2.CLI.Run.LWWRef + HBS2.CLI.Run.Mailbox HBS2.CLI.Run.Sigil HBS2.CLI.Run.Help diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs index 66a013cf..623b92f3 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs @@ -151,6 +151,23 @@ internalEntries :: forall c m . (IsContext c, Exception (BadFormException c), Mo internalEntries = do SC.internalEntries + entry $ bindMatch "--run" $ \case + [] -> do + liftIO getContents + <&> parseTop + >>= either (error.show) (pure . fmap (fixContext @_ @c)) + >>= evalTop + + [StringLike fn] -> do + liftIO (readFile fn) + <&> parseTop + >>= either (error.show) (pure . fmap (fixContext @_ @c)) + >>= evalTop + + _ -> throwIO (BadFormException @c nil) + + -- TODO: re-implement-all-on-top-of-opaque + entry $ bindMatch "blob:base58" $ \case [LitStrVal t] -> do bs <- pure (Text.unpack t & BS8.pack & fromBase58) @@ -196,4 +213,9 @@ internalEntries = do e -> throwIO (BadFormException @c nil) + entry $ bindMatch "test:opaque" $ \case + [ LitIntVal n ] -> mkOpaque n + [ StringLike s ] -> mkOpaque s + + _ -> mkOpaque () diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Mailbox.hs b/hbs2-cli/lib/HBS2/CLI/Run/Mailbox.hs new file mode 100644 index 00000000..ad698907 --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Run/Mailbox.hs @@ -0,0 +1,305 @@ +module HBS2.CLI.Run.Mailbox where + + +import HBS2.CLI.Prelude +import HBS2.CLI.Run.Internal +import HBS2.CLI.Run.Internal.Merkle + +import HBS2.Net.Auth.GroupKeySymm +import HBS2.Peer.Proto.Mailbox +import HBS2.Peer.Proto.Mailbox.Policy.Basic + +import HBS2.Base58 +import HBS2.System.Dir +import HBS2.Data.Types.Refs +import HBS2.Hash +import HBS2.Storage +import HBS2.KeyMan.Keys.Direct as K + +import Codec.Serialise +import Data.Text qualified as Text +import Data.Text.Encoding (encodeUtf8) +import Control.Monad.Except +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 + +createShortMessageFromByteString :: forall s m . ( MonadUnliftIO m + , s ~ HBS2Basic + , HasStorage m + ) + => LBS8.ByteString + -> m (Message s) +createShortMessageFromByteString 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 Message from file" + $ args [arg "string" "filename"] + $ desc [qc| +hbs2:mailbox:message:create:short:file FILENAME + +FILENAME is file with format: + +field1 VALUE +field2 VALUE + +message text... + + +;; + +supported fields: + +sender +recipient + + |] + $ returns "blob" "message" + $ entry $ bindMatch "hbs2:mailbox:message:create:short:file" $ \case + [StringLike fn] -> lift do + lbs <- liftIO $ LBS8.readFile fn + mess <- createShortMessageFromByteString lbs + mkOpaque (serialise mess) + + _ -> throwIO (BadFormException @c nil) + + + brief "creates a new multipart message" + $ desc [qc| +;; creates multipart message + +hbs2:mailbox:message:create:multipart [kw k1 v1 kn kv] + +WHERE + + k ::= sender | recipient | body | part + + sender ::= HASH(sigil) + body ::= STRING + part ::= FILENAME + + |] + $ examples [qc| + +[hbs2:peer:storage:block:put + [hbs2:mailbox:message:create:multipart + [kw sender ghna99Xtm33ncfdUBT3htBUoEyT16wTZGMdm24BQ1kh + recipient 4e9moTcp9AW13wRYYWg5F8HWooVH1PuQ7zsf5g2JYPWj + body [str:file body.txt] + part patch1.patch + ]]] + +NOTE: + +Each "part" will be represented as encrypted merkle tree +with metadata, i.e. it will be created in storage. + +So it's a good idea to remove excessive/unrequired trees using +hbs2 del -r command. + +|] + $ returns "bytes" "message" + $ entry $ bindMatch "hbs2:mailbox:message:create:multipart" $ \syn -> lift do + + sto <- getStorage + let cms = CreateMessageServices + sto + ( runKeymanClientRO . loadCredentials ) + ( runKeymanClientRO . loadKeyRingEntry ) + + + flagz <- defMessageFlags + tsender <- newTVarIO Nothing + tbody <- newTVarIO (mempty :: LBS.ByteString) + trcpt <- newTVarIO mempty + tparts <- newTVarIO mempty + + case syn of + [ListVal (SymbolVal "dict" : parts)] -> do + + for_ parts $ \case + ListVal [StringLike "sender", HashLike ss] -> do + atomically $ writeTVar tsender (Just ss) + + ListVal [StringLike "recipient", HashLike ss] -> do + atomically $ modifyTVar trcpt (ss:) + + ListVal [StringLike "body", StringLike s] -> do + let lbs = encodeUtf8 (fromString s) & LBS.fromStrict + atomically $ modifyTVar tbody (LBS.append lbs) + + ListVal [StringLike "part", StringLike fn] -> do + let what = takeFileName fn & fromString + let rfn = liftIO (LBS.readFile fn) + let meta = [("file-name:", what)] + atomically $ modifyTVar tparts ( [(meta,rfn)] <> ) + + _ -> pure () + + _ -> throwIO (BadFormException @c nil) + + sender <- readTVarIO tsender >>= orThrowUser "sender not set" + rcpt <- readTVarIO trcpt <&> fmap Left + body <- readTVarIO tbody + parts <- readTVarIO tparts + mess <- createMessage cms flagz Nothing + (Left sender) + rcpt + parts + (LBS.toStrict body) + + mkOpaque (serialise mess) + + entry $ bindMatch "hbs2:mailbox:message:dump" $ nil_ \syn -> lift do + lbs <- case syn of + [ HashLike h ] -> do + sto <- getStorage + getBlock sto (coerce h) >>= orThrowUser "message not found" + + [ StringLike fn ] -> do + liftIO $ LBS.readFile fn + + _ -> throwIO (BadFormException @c nil) + + let rms = ReadMessageServices ( liftIO . runKeymanClientRO . extractGroupKeySecret) + + (s,mess,co) <- deserialiseOrFail @(Message HBS2Basic) lbs + & orThrowUser "malformed message" + >>= readMessage rms + + -- TODO: implement-normally + liftIO do + print $ "sender" <+> pretty (AsBase58 s) + + for_ (messageRecipients mess) $ \r -> do + print $ "recipient" <+> pretty (AsBase58 r) + + for_ (messageParts mess) $ \p -> do + print $ "attachment" <+> pretty p + + putStrLn "" + + BS.putStr co + + 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) + + + entry $ bindMatch "hbs2:mailbox:policy:basic:read:syntax" $ \case + [ListVal syn] -> do + po <- parseBasicPolicy syn >>= orThrowUser "malformed policy" + mkOpaque po + + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "hbs2:mailbox:policy:basic:read:file" $ \case + [StringLike fn] -> lift do + + what <- liftIO (readFile fn) + <&> parseTop + >>= either (error.show) pure + >>= parseBasicPolicy + >>= orThrowUser "invalid policy" + + mkOpaque what + + _ -> throwIO (BadFormException @c nil) + + + entry $ bindMatch "hbs2:mailbox:policy:basic:read:storage" $ \case + [HashLike href] -> lift do + sto <- getStorage + what <- runExceptT (getTreeContents sto href) + >>= orThrowPassIO + <&> parseTop . LBS8.unpack + >>= either (error.show) pure + >>= parseBasicPolicy + >>= orThrowUser "invalid policy" + mkOpaque what + + _ -> throwIO (BadFormException @c nil) + + + entry $ bindMatch "hbs2:mailbox:policy:basic:accept:peer" $ \case + [SignPubKeyLike who, OpaqueVal box] -> lift do + p <- fromOpaqueThrow @(BasicPolicy HBS2Basic) "expected BasicPolicy" box + r <- policyAcceptPeer @HBS2Basic p who + pure $ mkBool @c r + + _ -> throwIO (BadFormException @c nil) + + + entry $ bindMatch "hbs2:mailbox:policy:basic:accept:sender" $ \case + [SignPubKeyLike who, OpaqueVal box] -> lift do + p <- fromOpaqueThrow @(BasicPolicy HBS2Basic) "expected BasicPolicy" box + r <- policyAcceptSender @HBS2Basic p who + pure $ mkBool @c r + + _ -> throwIO (BadFormException @c nil) + + + entry $ bindMatch "hbs2:mailbox:policy:basic:dump" $ nil_ $ \case + [OpaqueVal box] -> lift do + p <- fromOpaqueThrow @(BasicPolicy HBS2Basic) "expected BasicPolicy" box + liftIO $ print $ vcat (fmap pretty (getAsSyntax @c p)) + + _ -> throwIO (BadFormException @c nil) + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Peer.hs b/hbs2-cli/lib/HBS2/CLI/Run/Peer.hs index 67678bc2..06d162ef 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Peer.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Peer.hs @@ -1,3 +1,5 @@ +{-# Language ViewPatterns #-} +{-# Language PatternSynonyms #-} module HBS2.CLI.Run.Peer where import HBS2.CLI.Prelude @@ -20,7 +22,9 @@ import Data.List qualified as L import Data.Maybe import Control.Monad.Trans.Cont import Data.Text qualified as Text +import Data.ByteString qualified as BS import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.ByteString.Lazy qualified as LBS import Lens.Micro.Platform import Text.InterpolatedString.Perl6 (qc) @@ -51,7 +55,7 @@ peerEntries = do entry $ bindMatch "hbs2:peer:detect" $ \case _ -> detectRPC <&> maybe (nil @c) mkStr - entry $ bindMatch "hbs2:peer:get-block" $ \case + entry $ bindMatch "hbs2:peer:storage:block:get" $ \case [StringLike s] -> do flip runContT pure do @@ -66,23 +70,29 @@ peerEntries = do _ -> throwIO $ BadFormException @c nil - entry $ bindMatch "hbs2:peer:has-block" $ \case - [StringLike s] -> do + entry $ bindMatch "hbs2:peer:storage:block:size" $ \case + [HashLike ha] -> do flip runContT pure do - sto <- getStorage - - ha <- pure (fromStringMay @HashRef s) - `orDie` "invalid hash" - mbsz <- hasBlock sto (fromHashRef ha) - pure $ maybe (mkSym "no-block") mkInt mbsz _ -> throwIO $ BadFormException @c nil -- stores *small* block - entry $ bindMatch "hbs2:peer:put-block" $ \case + entry $ bindMatch "hbs2:peer:storage:block:put" $ \case + + [isOpaqueOf @LBS.ByteString -> Just lbs] -> do + sto <- getStorage + (putBlock sto lbs <&> fmap (mkStr . show . pretty . HashRef) ) + >>= orThrowUser "storage error" + + [isOpaqueOf @BS.ByteString -> Just bs] -> do + sto <- getStorage + (putBlock sto (LBS.fromStrict bs) <&> fmap (mkStr . show . pretty . HashRef) ) + >>= orThrowUser "storage error" + + -- FIXME: deprecate-this [ListVal [SymbolVal "blob", LitStrVal s]] -> do flip runContT pure do sto <- getStorage diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Sigil.hs b/hbs2-cli/lib/HBS2/CLI/Run/Sigil.hs index 8201388f..e74e4565 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Sigil.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Sigil.hs @@ -60,7 +60,6 @@ sigilEntries = do $ entry $ bindMatch "hbs2:sigil:load:base58" $ \case [HashLike key] -> lift do sto <- getStorage - warn $ pretty key r <- loadSigil @HBS2Basic sto key >>= orThrowUser "no sigil found" pure $ mkStr @c ( show $ pretty $ AsBase58 r ) @@ -80,37 +79,57 @@ sigilEntries = do _ -> throwIO $ BadFormException @c nil - entry $ bindMatch "hbs2:sigil:create:from-keyring" $ \syn -> do + brief "create sigil from keyring" $ + desc [qc| - args <- case syn of - [ StringLike s ] -> pure (fmap snd . headMay, s) - [ StringLike p, StringLike s ] -> pure ( findKey p, s) - [ LitIntVal n, StringLike s ] -> pure ( L.lookup n, s) +;; creates from keyring, uses first encryption key if found - _ -> throwIO $ BadFormException @C nil +hbs2:sigil:create:from-keyring KEYRING-FILE - let lbs = BS8.pack (snd args) +;; creates from keyring, uses n-th encryption key if found, N starts from 1 - cred <- pure (parseCredentials @'HBS2Basic (AsCredFile lbs)) - `orDie` "bad keyring data" +hbs2:sigil:create:from-keyring KEYRING-FILE N - let es = zip [0..] - [ p | KeyringEntry p _ _ - <- view peerKeyring cred - ] +;; creates from keyring, uses encryption key wit prefix S if found - enc <- pure (fst args es) - `orDie` "key not found" +hbs2:sigil:create:from-keyring KEYRING-FILE S - sigil <- pure (makeSigilFromCredentials @'HBS2Basic cred enc Nothing Nothing) - `orDie` "can't create a sigil" + |] + $ entry $ bindMatch "hbs2:sigil:create:from-keyring" $ \syn -> do - pure $ mkStr (show $ pretty $ AsBase58 sigil) - - where - findKey s xs = headMay [ k - | e@(_,k) <- xs - , L.isPrefixOf s (show $ pretty (AsBase58 k)) - ] + let readKeyring fn = liftIO (BS8.readFile fn) + <&> parseCredentials @'HBS2Basic . AsCredFile + >>= orThrowUser "malformed keyring file" + (cred, KeyringEntry enc _ _) <- case syn of + [ StringLike fn ] -> do + s <- readKeyring fn + kr <- headMay (view peerKeyring s) & orThrowUser "encryption key missed" + pure (s,kr) + + [ StringLike fn, LitIntVal n ] -> do + s <- readKeyring fn + kr <- headMay (drop (fromIntegral (max 0 (n-1))) (view peerKeyring s)) + & orThrowUser "encryption key not found" + pure (s,kr) + + [ StringLike fn, StringLike p ] -> do + + s <- readKeyring fn + kr <- findKey p (view peerKeyring s) & orThrowUser "encryption key not found" + pure (s,kr) + + _ -> throwIO $ BadFormException @c nil + + sigil <- pure (makeSigilFromCredentials @'HBS2Basic cred enc Nothing Nothing) + `orDie` "can't create a sigil" + + pure $ mkStr (show $ pretty $ AsBase58 sigil) + + where + findKey s xs = headMay [ e + | e@(KeyringEntry k _ _) <- xs + , L.isPrefixOf s (show $ pretty (AsBase58 k)) + ] + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Tree.hs b/hbs2-cli/lib/HBS2/CLI/Run/Tree.hs new file mode 100644 index 00000000..7625bc30 --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Run/Tree.hs @@ -0,0 +1,47 @@ +module HBS2.CLI.Run.Tree + ( treeEntries + ) where + +import HBS2.CLI.Prelude +import HBS2.CLI.Run.Internal +import HBS2.CLI.Run.Internal.GroupKey as G +import HBS2.CLI.Run.Internal.Merkle + +import HBS2.Data.Types.Refs +import HBS2.Merkle +import HBS2.System.Dir +import HBS2.Storage +import HBS2.Storage.Operations.ByteString + +import HBS2.Net.Auth.Schema() + +import HBS2.Peer.RPC.API.Storage +import HBS2.Peer.RPC.Client +import HBS2.Peer.RPC.Client.Unix + +import Control.Monad.Except + +treeEntries :: forall c m . ( IsContext c + , MonadUnliftIO m + , Exception (BadFormException c) + , HasStorage m + , HasClientAPI StorageAPI UNIX m + ) => MakeDictM c m () +treeEntries = do + + brief "reads merkle tree data from storage" + $ args [arg "string" "tree"] + $ desc "hbs2:tree:read HASH" + $ returns "bytestring" "data" + $ entry $ bindMatch "hbs2:tree:read" $ \case + [ HashLike h ] -> lift do + sto <- getStorage + + co <- runExceptT (getTreeContents sto h) + >>= orThrowPassIO + + mkOpaque co + + _ -> throwIO (BadFormException @c nil) + + diff --git a/hbs2-core/lib/HBS2/Data/Types/SignedBox.hs b/hbs2-core/lib/HBS2/Data/Types/SignedBox.hs index 62f4e061..d4a88ae0 100644 --- a/hbs2-core/lib/HBS2/Data/Types/SignedBox.hs +++ b/hbs2-core/lib/HBS2/Data/Types/SignedBox.hs @@ -33,6 +33,7 @@ type ForSignedBox s = ( Serialise ( PubKey 'Sign s) , FromStringMaybe (PubKey 'Sign s) , Serialise (Signature s) , Signatures s + , Eq (Signature s) , Hashable (PubKey 'Sign s) ) diff --git a/hbs2-core/lib/HBS2/Data/Types/SmallEncryptedBlock.hs b/hbs2-core/lib/HBS2/Data/Types/SmallEncryptedBlock.hs index 7fbba673..a3d22869 100644 --- a/hbs2-core/lib/HBS2/Data/Types/SmallEncryptedBlock.hs +++ b/hbs2-core/lib/HBS2/Data/Types/SmallEncryptedBlock.hs @@ -14,7 +14,7 @@ data SmallEncryptedBlock t = , sebNonce :: ByteString , sebBox :: EncryptedBox t } - deriving stock (Generic) + deriving stock (Eq,Generic) instance Serialise (SmallEncryptedBlock t) diff --git a/hbs2-core/lib/HBS2/Net/Auth/Credentials/Sigil.hs b/hbs2-core/lib/HBS2/Net/Auth/Credentials/Sigil.hs index ed90fcbf..70f8c6f0 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/Credentials/Sigil.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/Credentials/Sigil.hs @@ -63,6 +63,7 @@ type ForSigil s = ( Serialise (PubKey 'Encrypt s) , Hashable (PubKey 'Sign s) , IsEncoding (PubKey 'Encrypt s) , Eq (PubKey 'Encrypt s) + , Eq (Signature s) , FromStringMaybe (PubKey 'Sign s) ) diff --git a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs b/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs index 5247cd8f..9646b282 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs @@ -559,27 +559,32 @@ decryptBlock :: forall t s sto h m . ( MonadIO m -> SmallEncryptedBlock t -> m t -decryptBlock sto findKey (SmallEncryptedBlock{..}) = do - +decryptBlock sto findKey seb@(SmallEncryptedBlock{..}) = do gkbs <- readFromMerkle sto (SimpleKey (fromHashRef sebGK0)) gk <- either (const $ throwError (GroupKeyNotFound 1)) pure (deserialiseOrFail @(GroupKey 'Symm s) gkbs) - gksec' <- findKey gk - -- [ lookupGroupKey sk pk gk | KeyringKeys pk sk <- keys ] & catMaybes & headMay - gksec <- maybe1 gksec' (throwError (GroupKeyNotFound 2)) pure + decryptBlockWithSecret @_ @s gksec seb +decryptBlockWithSecret :: forall t s h m . ( MonadIO m + , MonadError OperationError m + , ForGroupKeySymm s + , h ~ HbSync + , Serialise t + ) + + => GroupSecret + -> SmallEncryptedBlock t + -> m t + +decryptBlockWithSecret gksec (SmallEncryptedBlock{..}) = do let prk = HKDF.extractSkip @_ @HbSyncHash (Saltine.encode gksec) let key0 = HKDF.expand prk sebNonce typicalKeyLength & Saltine.decode & fromJust let nonce0 = nonceFrom @SK.Nonce sebNonce - let unboxed = SK.secretboxOpen key0 nonce0 (unEncryptedBox sebBox) - lbs <- maybe1 unboxed (throwError DecryptionError) (pure . LBS.fromStrict) - either (const $ throwError UnsupportedFormat) pure (deserialiseOrFail lbs) - deriveGroupSecret :: NonceFrom SK.Nonce n => n -> BS.ByteString -> GroupSecret deriveGroupSecret n bs = key0 where diff --git a/hbs2-core/lib/HBS2/Net/Messaging/TCP.hs b/hbs2-core/lib/HBS2/Net/Messaging/TCP.hs index 2ad678b0..1073721c 100644 --- a/hbs2-core/lib/HBS2/Net/Messaging/TCP.hs +++ b/hbs2-core/lib/HBS2/Net/Messaging/TCP.hs @@ -36,7 +36,8 @@ import Network.ByteOrder hiding (ByteString) import Network.Simple.TCP import Network.Socket hiding (listen,connect) import System.Random hiding (next) -import Control.Monad.Trans.Resource +import Control.Monad.Trans.Cont +import Control.Exception import UnliftIO.Async import UnliftIO.STM @@ -177,7 +178,7 @@ spawnConnection :: forall m . MonadIO m spawnConnection tp env so sa = liftIO do - runResourceT do + flip runContT pure $ do let myCookie = view tcpCookie env let own = view tcpOwnPeer env @@ -209,7 +210,7 @@ spawnConnection tp env so sa = liftIO do readTVar (view tcpConnUsed env) <&> HashMap.findWithDefault 0 connId - void $ allocate (pure connId) cleanupConn + void $ ContT $ bracket (pure connId) cleanupConn debug $ "USED:" <+> viaShow tp <+> pretty own <+> pretty used @@ -225,7 +226,7 @@ spawnConnection tp env so sa = liftIO do <+> pretty newP <+> parens ("used:" <+> pretty used) - rd <- async $ fix \next -> do + rd <- ContT $ withAsync $ fix \next -> do spx <- readFromSocket so 4 <&> LBS.toStrict ssize <- readFromSocket so 4 <&> LBS.toStrict --- УУУ, фреейминг @@ -247,7 +248,7 @@ spawnConnection tp env so sa = liftIO do next - wr <- async $ fix \next -> do + wr <- ContT $ withAsync $ fix \next -> do (rcpt, bs) <- atomically $ readTQueue q pq <- makeReqId rcpt diff --git a/hbs2-git-dashboard/app/GitDashBoard.hs b/hbs2-git-dashboard/app/GitDashBoard.hs index bcabc0ba..356d21cc 100644 --- a/hbs2-git-dashboard/app/GitDashBoard.hs +++ b/hbs2-git-dashboard/app/GitDashBoard.hs @@ -158,7 +158,6 @@ runDashBoardM m = do setLogging @WARN warnPrefix setLogging @NOTICE noticePrefix - mkdir dataDir flip runContT pure do @@ -185,6 +184,7 @@ runDashBoardM m = do void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client + env <- newDashBoardEnv dataDir peerAPI @@ -193,6 +193,11 @@ runDashBoardM m = do lwwAPI sto + lift $ withDashBoardEnv env do + mkdir dataDir + notice "evolving db" + withState evolveDB + void $ ContT $ withAsync do fix \next -> do dbe' <- readTVarIO (_db env) @@ -200,15 +205,18 @@ runDashBoardM m = do Just dbe -> do notice $ green "Aquired database!" runPipe dbe + forever do + pause @'Seconds 30 Nothing -> do pause @'Seconds 5 next - void $ ContT $ withAsync do - q <- withDashBoardEnv env $ asks _pipeline - forever do - liftIO (atomically $ readTQueue q) & liftIO . join + replicateM_ 2 do + ContT $ withAsync do + q <- withDashBoardEnv env $ asks _pipeline + forever do + liftIO (atomically $ readTQueue q) & liftIO . join lift $ withDashBoardEnv env m `finally` do @@ -398,9 +406,6 @@ runScotty = do env <- ask - notice "evolving db" - withState evolveDB - notice "running config" conf <- readConfig @@ -470,6 +475,9 @@ runRPC = do void $ waitAnyCatchCancel [m1,p1] + + -- pure () + updateIndexPeriodially :: DashBoardPerks m => DashBoardM m () updateIndexPeriodially = do @@ -480,18 +488,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 @@ -507,7 +523,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 @@ -518,13 +534,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) @@ -536,7 +553,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 @@ -545,8 +562,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) @@ -570,8 +590,15 @@ updateIndexPeriodially = do debug $ red "SYNC" <+> pretty cmd void $ runProcess $ shell cmd - lift $ buildCommitTreeIndex (coerce lww) + pollRepoIndex = do + api <- asks _refLogAPI + let rlogs = selectRefLogs <&> fmap (over _1 (coerce @_ @MyRefLogKey)) . fmap (, 600) + + ContT $ withAsync $ do + polling (Polling 1 30) rlogs $ \r -> do + lww' <- selectLwwByRefLog (RepoRefLog r) + for_ lww' $ addRepoIndexJob . coerce quit :: DashBoardPerks m => m () quit = liftIO exitSuccess diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State.hs index 3d24d6f4..c6612a1c 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State.hs +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State.hs @@ -25,7 +25,7 @@ import DBPipe.SQLite hiding (insert) import DBPipe.SQLite qualified as S import DBPipe.SQLite.Generic as G - +import Data.List.Split (chunksOf) import Data.Aeson as Aeson import Data.ByteString.Lazy.Char8 qualified as LBS8 import Data.ByteString.Lazy (ByteString) @@ -36,6 +36,8 @@ import Data.Either import Data.List qualified as List import Data.Map qualified as Map import Data.Map (Map) +import Data.HashMap.Strict qualified as HM +import Data.HashSet qualified as HS import System.FilePath import System.Directory @@ -690,18 +692,36 @@ instance FromRow BlobInfo type TreeLocator = [(TreeParent, TreeTree, TreeLevel, TreePath)] + insertBlob :: DashBoardPerks m => (BlobHash, BlobName, BlobSize, BlobSyn) -> DBPipeM m () -insertBlob (h,n,size,syn) = do +insertBlob (h, n, size, syn) = do S.insert [qc| - insert into blob (hash,name,size,syntax) + insert into blob (hash, name, size, syntax) values (?,?,?,?) on conflict (hash) do update set name = excluded.name , size = excluded.size , syntax = excluded.syntax - |] (h,n,size,syn) + where blob.name != excluded.name + or blob.size != excluded.size + or blob.syntax != excluded.syntax + |] (h, n, size, syn) + + +-- insertBlob :: DashBoardPerks m +-- => (BlobHash, BlobName, BlobSize, BlobSyn) +-- -> DBPipeM m () +-- insertBlob (h,n,size,syn) = do +-- S.insert [qc| +-- insert into blob (hash,name,size,syntax) +-- values (?,?,?,?) +-- on conflict (hash) +-- do update set name = excluded.name +-- , size = excluded.size +-- , syntax = excluded.syntax +-- |] (h,n,size,syn) selectBlobInfo :: (DashBoardPerks m, MonadReader DashBoardEnv m) @@ -758,8 +778,8 @@ readBlob repo hash = do <&> fromRight mempty -updateForks :: (MonadIO m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> m () -updateForks lww = withState do +updateForks :: (MonadIO m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> DBPipeM m () +updateForks lww = do S.insert [qc| insert into fork (a,b) @@ -778,6 +798,13 @@ checkCommitProcessed lww co = withState do select [qc|select 1 from repocommit where lww = ? and kommit = ?|] (lww, co) <&> listToMaybe @(Only Int) <&> isJust + +listCommitsProcessed :: (MonadIO m, MonadReader DashBoardEnv m) + => LWWRefKey 'HBS2Basic -> m [GitHash] +listCommitsProcessed lww = withState do + select [qc|select kommit from repocommit where lww = ?|] (Only lww) + <&> fmap fromOnly + listCommits :: (MonadUnliftIO m, MonadReader DashBoardEnv m) => LWWRefKey HBS2Basic -> m [GitHash] listCommits lww = do @@ -837,46 +864,46 @@ getRootTree lww co = do _ -> Nothing updateRepoData :: (MonadReader DashBoardEnv m, MonadUnliftIO m) - => LWWRefKey HBS2Basic -> GitHash -> m () + => LWWRefKey HBS2Basic -> GitHash -> DBPipeM m () updateRepoData lww co = do env <- ask void $ runMaybeT do - root <- lift (getRootTree lww co) >>= toMPlus - (trees, blobs) <- lift $ getTreeRecursive lww co + root <- lift (lift (getRootTree lww co)) >>= toMPlus + (trees, blobs) <- lift $ lift $ getTreeRecursive lww co -- lift $ addJob $ liftIO $ withDashBoardEnv env do - lift $ withState $ transactional do - + -- lift $ withState do + lift do insert @RepoCommitTable $ onConflictIgnore @RepoCommitTable (RepoLww lww, RepoCommit co) for_ blobs $ \(fn, (hash, size, syn)) -> do insertBlob (BlobHash hash, BlobName fn, BlobSize size, BlobSyn syn) - for_ (Map.toList trees) $ \(t,h0) -> do + for_ (Map.toList trees) $ \(t,h0) -> do - case t of - [x] -> insertTree (TreeCommit co,TreeParent root,TreeTree h0,1,TreePath x) - _ -> pure () + case t of + [x] -> insertTree (TreeCommit co,TreeParent root,TreeTree h0,1,TreePath x) + _ -> pure () - let child = tailSafe t - debug $ red "TREE-REL:" <+> pretty t - let parent = Map.lookup child trees + let child = tailSafe t + debug $ red "TREE-REL:" <+> pretty t + let parent = Map.lookup child trees - for_ parent $ \p -> do - debug $ red "FOUND SHIT:" <+> pretty (h0,p) - insertTree ( TreeCommit co - , TreeParent p - , TreeTree h0 - , TreeLevel (length t) - , TreePath (headDef "" t) - ) + for_ parent $ \p -> do + debug $ red "FOUND SHIT:" <+> pretty (h0,p) + insertTree ( TreeCommit co + , TreeParent p + , TreeTree h0 + , TreeLevel (length t) + , TreePath (headDef "" t) + ) - updateForks lww + -- updateForks lww buildSingleCommitTreeIndex :: ( MonadUnliftIO m , DashBoardPerks m @@ -894,7 +921,9 @@ buildSingleCommitTreeIndex lww co = do done <- checkCommitProcessed lww co let skip = done && not ignoreCaches guard (not skip) - lift $ updateRepoData lww co + lift $ withState $ transactional $ do + updateRepoData lww co + updateForks lww buildCommitTreeIndex :: ( MonadUnliftIO m , DashBoardPerks m @@ -904,16 +933,26 @@ buildCommitTreeIndex :: ( MonadUnliftIO m -> m () buildCommitTreeIndex lww = do - commits <- listCommits lww + + debug $ red "buildCommitTreeIndex" <+> pretty lww + env <- ask ignoreCaches <- getIgnoreCaches - for_ commits $ \co -> void $ runMaybeT do - done <- checkCommitProcessed lww co - let skip = done && not ignoreCaches - guard (not skip) - lift $ addJob $ withDashBoardEnv env (updateRepoData lww co) + doneCommits <- listCommitsProcessed lww <&> HS.fromList + + commits <- listCommits lww <&> filter (not . flip HS.member doneCommits) + let chunks = chunksOf 100 commits + + for_ chunks $ \chunk -> do + -- addJob $ withDashBoardEnv env do + withState $ transactional do + for_ chunk $ \co -> do + updateRepoData lww co + + unless (List.null chunks) do + withState $ transactional $ do updateForks lww -- FIXME: check-names-with-spaces diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State/Index/Peer.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State/Index/Peer.hs index d9644e48..65f4e5f1 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State/Index/Peer.hs +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State/Index/Peer.hs @@ -13,12 +13,31 @@ import HBS2.System.Dir import Streaming.Prelude qualified as S +import Data.HashMap.Strict qualified as HM import System.Process.Typed {- HLINT ignore "Functor law" -} seconds = TimeoutSec + +addRepoIndexJob :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> m () +addRepoIndexJob lww = do + + e <- ask + let wip = _repoCommitIndexWIP e + + n <- atomically do + modifyTVar wip (HM.insertWith (+) (coerce lww) 1) + readTVar wip <&> HM.lookup (coerce lww) <&> fromMaybe 0 + + when ( n < 2 ) do + addJob $ withDashBoardEnv e do + buildCommitTreeIndex (coerce lww) + `finally` do + atomically do + modifyTVar wip (HM.adjust pred (coerce lww)) + updateFixmeFor :: ( MonadUnliftIO m , MonadReader DashBoardEnv m ) @@ -101,6 +120,7 @@ updateIndexFromPeer = do lift $ S.yield (lw, RepoHeadTx tx, RepoHeadRef rhh, rhead, fme) withState $ transactional do + -- withState do for_ headz $ \(l, tx, rh, rhead, fme) -> do let rlwwseq = RepoLwwSeq (fromIntegral $ lwwSeq wv) insertRepoHead l rlwwseq (RepoRefLog rk) tx rh rhead @@ -110,7 +130,9 @@ updateIndexFromPeer = do for_ fme $ \f -> do insertRepoFixme l rlwwseq f - -- buildCommitTreeIndex (coerce lw) + -- WTF? + env <- ask + buildCommitTreeIndex (coerce lw) fxe <- selectRepoFixme diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Types.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Types.hs index 2e191d98..a2e32f83 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Types.hs +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Types.hs @@ -20,6 +20,8 @@ import HBS2.System.Dir import System.FilePath import Data.Word +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HM import Data.Text qualified as Text type MyRefChan = RefChanId L4Proto @@ -60,6 +62,7 @@ data DashBoardEnv = , _dashBoardDevAssets :: TVar (Maybe FilePath) , _dashBoardBaseUrl :: TVar (Maybe Text) , _dashBoardIndexIgnoreCaches :: TVar Bool + , _repoCommitIndexWIP :: TVar (HashMap (LWWRefKey 'HBS2Basic) Int) } makeLenses 'DashBoardEnv @@ -99,6 +102,7 @@ newDashBoardEnv ddir peer rlog rchan lww sto = do <*> newTVarIO Nothing <*> newTVarIO Nothing <*> newTVarIO False + <*> newTVarIO mempty getHttpPortNumber :: (MonadIO m, MonadReader DashBoardEnv m, Integral a) => m a getHttpPortNumber = do @@ -139,7 +143,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 @@ -164,5 +168,7 @@ addJob f = do q <- asks _pipeline atomically $ writeTQueue q f + + hbs2_git_dashboard :: FilePath hbs2_git_dashboard = "hbs2-git-dashboard" diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Fixme.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Fixme.hs index b9c02c92..05734d12 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Fixme.hs +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Fixme.hs @@ -98,3 +98,5 @@ repoFixme q@(FromParams p') lww = asksBaseUrl $ withBaseUrl do , hxSwap_ "afterend" ] do td_ [colspan_ "3"] mempty + + diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Issue.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Issue.hs index 1f90dfd0..1c663966 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Issue.hs +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Issue.hs @@ -152,3 +152,5 @@ issuePage repo@(RepoLww lww) f = asksBaseUrl $ withBaseUrl $ rootPage do where trim before seize txt = Text.lines txt & drop before & take seize & Text.unlines + + diff --git a/hbs2-git-dashboard/hbs2-git-dashboard.cabal b/hbs2-git-dashboard/hbs2-git-dashboard.cabal index 212f4492..5dc80c70 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard.cabal +++ b/hbs2-git-dashboard/hbs2-git-dashboard.cabal @@ -114,6 +114,7 @@ library hbs2-git-dashboard-core , skylighting-lucid , stm , streaming + , split , temporary , text , time diff --git a/hbs2-peer/app/CLI/Mailbox.hs b/hbs2-peer/app/CLI/Mailbox.hs new file mode 100644 index 00000000..1370e4f8 --- /dev/null +++ b/hbs2-peer/app/CLI/Mailbox.hs @@ -0,0 +1,411 @@ +{-# Language PatternSynonyms #-} +{-# Language ViewPatterns #-} +module CLI.Mailbox (pMailBox) where + +import HBS2.Prelude.Plated +import HBS2.Base58 +import HBS2.Hash +import HBS2.OrDie +import HBS2.Merkle +import HBS2.Data.Types.Refs +import HBS2.Net.Proto.Service +import HBS2.Net.Auth.Credentials +import HBS2.Storage +import HBS2.Storage.Operations.ByteString +import HBS2.Data.Types.SignedBox +import HBS2.Peer.Proto.Mailbox +import HBS2.Peer.Proto.Mailbox.Types +import HBS2.Peer.Proto.Mailbox.Entry + +import HBS2.Peer.RPC.API.Mailbox +import HBS2.Peer.RPC.API.Storage +import HBS2.Peer.RPC.Client.StorageClient +import HBS2.KeyMan.Keys.Direct + +import CLI.Common +import RPC2() +import PeerLogger hiding (info) + +import Codec.Serialise +import Control.Monad.Trans.Cont +import Control.Monad.Trans.Maybe +import Data.ByteString.Lazy qualified as LBS +import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.ByteString qualified as BS +import Data.Either +import Data.Coerce +import Data.Config.Suckless.Script +import Data.HashSet (HashSet) +import Data.HashSet qualified as HS +import Data.Maybe +import Data.Word +import Lens.Micro.Platform +import Options.Applicative +import System.Environment (lookupEnv) +import System.Exit +import UnliftIO + +import Text.InterpolatedString.Perl6 (qc) + +pattern MailboxTypeLike :: forall {c}. MailboxType -> Syntax c +pattern MailboxTypeLike w <- (mailboxTypeLike -> Just w) + +mailboxTypeLike :: Syntax c -> Maybe MailboxType +mailboxTypeLike = \case + StringLike s -> fromStringMay @MailboxType s + _ -> Nothing + +pMailBox :: Parser (IO ()) +pMailBox = do + rpc <- pRpcCommon + what <- many (strArgument (metavar "ARGS" <> help "hbs2-cli mailbox command-line")) + pure (runMailboxCLI rpc what) + + + +runMailboxCLI :: RPCOpt -> [String] -> IO () +runMailboxCLI rpc s = do + + cli <- parseTop (unwords s) & either (error.show) pure + + let t = TimeoutSec 1 + + let dict sto api = makeDict @C do + entry $ bindMatch "hey" $ nil_ $ const do + who <- liftIO (lookupEnv "USER") <&> fromMaybe "stranger" + liftIO $ print $ "hey," <+> pretty who + + entry $ bindMatch "poke" $ nil_ $ const do + _ <- callRpcWaitMay @RpcMailboxPoke t api () + >>= orThrowUser "rpc call timeout" + + liftIO $ print $ pretty "okay, rpc is here" + + brief "creates mailbox of given type" $ + desc createMailBoxDesc $ + examples createMailBoxExamples + $ entry $ bindMatch "create" $ nil_ $ \syn -> do + + case syn of + [ StringLike "--key", SignPubKeyLike puk, MailboxTypeLike tp ] -> do + + r <- callRpcWaitMay @RpcMailboxCreate t api (puk, tp) + >>= orThrowUser "rpc call timeout" + + liftIO $ print $ viaShow r + + [ StringLike "--sigil", HashLike sh, StringLike tp ] -> do + -- TODO: implement-create-by-sigil + warn $ "create by sigil (hash)" + error "not implemented" + + [ StringLike "--sigil-file", StringLike f, StringLike tp ] -> do + -- TODO: implement-create-by-sigil-file + warn $ "create by sigil file" <+> pretty f + error "not implemented" + + _ -> throwIO $ BadFormException @C nil + + brief "send message via gossip" $ + desc sendMessageDesc + $ entry $ bindMatch "send" $ nil_ $ \syn -> do + + blob <- case syn of + [ StringLike "--stdin" ] -> do + liftIO (LBS.hGetContents stdin) + + [ StringLike "--file", StringLike fn ] -> do + liftIO (LBS.readFile fn) + + [ HashLike h ] -> do + liftIO (getBlock sto (coerce h)) + >>= orThrowUser "message not found" + + _ -> throwIO $ BadFormException @C nil + + mess <- deserialiseOrFail @(Message HBS2Basic) blob + & either (const $ error "malformed message") pure + + _ <- callRpcWaitMay @RpcMailboxSend t api mess + >>= orThrowUser "rpc call timeout" + + pure () + + brief "get mailbox value" + $ entry $ bindMatch "get" $ nil_ $ \case + [ SignPubKeyLike m ] -> do + + v <- callRpcWaitMay @RpcMailboxGet t api m + >>= orThrowUser "rpc call timeout" + + liftIO $ print $ pretty v + + _ -> throwIO $ BadFormException @C nil + + brief "get mailbox status" + $ entry $ bindMatch "status" $ nil_ $ \case + [ SignPubKeyLike m ] -> do + + v <- callRpcWaitMay @RpcMailboxGetStatus t api m + >>= orThrowUser "rpc call timeout" + >>= orThrowPassIO + + liftIO $ print $ pretty v + + _ -> throwIO $ BadFormException @C nil + + + brief "fetch mailbox" + $ entry $ bindMatch "fetch" $ nil_ $ \case + [ SignPubKeyLike m ] -> do + + callRpcWaitMay @RpcMailboxFetch t api m + >>= orThrowUser "rpc call timeout" + >>= orThrowPassIO + + _ -> throwIO $ BadFormException @C nil + + brief "set mailbox policy" $ + desc setPolicyDesc + -- $ examples setPolicyExamples + $ entry $ bindMatch "set-policy" $ nil_ $ \case + [ SignPubKeyLike m, LitIntVal v, StringLike fn ] -> lift do + + mstatus <- callRpcWaitMay @RpcMailboxGetStatus t api m + >>= orThrowUser "rpc call timeout" + >>= orThrowPassIO + + s <- liftIO $ readFile fn + <&> parseTop + >>= either (error . show) pure + + pv <- fromMaybe 0 <$> runMaybeT do + MailBoxStatusPayload{..} <- toMPlus mstatus + pbox <- toMPlus mbsMailboxPolicy + (who, SetPolicyPayload{..}) <- unboxSignedBox0 pbox & toMPlus + + guard ( m == who ) + + pure sppPolicyVersion + + -- TODO: validate-policy + + creds <- runKeymanClientRO (loadCredentials m) + >>= orThrowUser ("can't load credentials for" <+> pretty (AsBase58 m)) + + let normalized = show $ vcat (fmap pretty s) + + notice $ "policy" <> line <> pretty normalized + + notice $ "okay" <+> pretty pv <+> "->" <+> pretty v <+> pretty fn + + hash <- writeAsMerkle sto (LBS8.pack normalized) + + notice $ "stored policy as" <+> pretty hash + + let spp = SetPolicyPayload @HBS2Basic m (fromIntegral v) (HashRef hash) + + let box = makeSignedBox @HBS2Basic (view peerSignPk creds) (view peerSignSk creds) spp + + notice $ "signed policy payload done okay" + + r <- callRpcWaitMay @RpcMailboxSetPolicy t api (m,box) + >>= orThrowUser "rpc call timeout" + >>= orThrowPassIO + + liftIO $ print $ pretty r + + _ -> throwIO $ BadFormException @C nil + + + brief "list mailboxes" + $ entry $ bindMatch "list" $ nil_ $ const do + + let fmtMbox (m,t) = pretty m <+> pretty t + + v <- callRpcWaitMay @RpcMailboxList t api () + >>= orThrowUser "rpc call timeout" + + liftIO $ print $ vcat (fmap fmtMbox v) + + brief "read message" + $ desc [qc|;; reads message + read HASH +|] + $ entry $ bindMatch "read" $ nil_ $ \case + [ HashLike mhash ] -> do + + let rms = ReadMessageServices (liftIO . runKeymanClientRO . extractGroupKeySecret) + + (s,_,bs) <- getBlock sto (coerce mhash) + >>= orThrowUser "message not found" + <&> deserialiseOrFail @(Message HBS2Basic) + >>= orThrowUser "invalid message format" + >>= readMessage rms + + liftIO $ BS.putStr bs + + none + + _ -> throwIO $ BadFormException @C nil + + brief "delete message" + $ desc deleteMessageDesc + $ entry $ bindMatch "delete:message" $ nil_ $ \case + [ SignPubKeyLike ref, HashLike mess ] -> do + + creds <- runKeymanClientRO (loadCredentials ref) + >>= orThrowUser ("can't load credentials for" <+> pretty (AsBase58 ref)) + + let expr = MailboxMessagePredicate1 (Op (MessageHashEq mess)) + let messP = DeleteMessagesPayload @HBS2Basic expr + + let box = makeSignedBox @HBS2Basic (view peerSignPk creds) (view peerSignSk creds) messP + + callRpcWaitMay @RpcMailboxDeleteMessages t api box + >>= orThrowUser "rpc call timeout" + >>= orThrowPassIO + + _ -> throwIO $ BadFormException @C nil + + brief "list messages" + $ entry $ bindMatch "list:messages" $ nil_ $ \case + [ SignPubKeyLike m ] -> void $ runMaybeT do + + v <- lift (callRpcWaitMay @RpcMailboxGet t api m) + >>= orThrowUser "rpc call timeout" + >>= toMPlus + + d <- liftIO $ newTVarIO (mempty :: HashSet HashRef) + r <- liftIO $ newTVarIO (mempty :: HashSet HashRef) + + walkMerkle @[HashRef] (coerce v) (liftIO . getBlock sto) $ \case + Left what -> err $ "missed block for tree" <+> pretty v <+> pretty what + Right hs -> void $ runMaybeT do + for_ hs $ \h -> do + + -- TODO: better-error-handling + e <- getBlock sto (coerce h) + >>= toMPlus + <&> deserialiseOrFail @MailboxEntry + >>= toMPlus + + case e of + Deleted _ mh -> do + atomically $ modifyTVar d (HS.insert mh) + + Exists _ mh -> do + atomically $ modifyTVar r (HS.insert mh) + + deleted <- readTVarIO d + rest <- readTVarIO r + + for_ (HS.difference rest deleted) $ \mh -> do + liftIO $ print $ pretty mh + + _ -> throwIO $ BadFormException @C nil + + + brief "delete mailbox" + $ entry $ bindMatch "delete" $ nil_ $ \case + [ SignPubKeyLike mbox ]-> lift do + callRpcWaitMay @RpcMailboxDelete t api mbox + >>= orThrowUser "rpc call timeout" + + _ -> throwIO $ BadFormException @C nil + + entry $ bindMatch "help" $ nil_ \case + HelpEntryBound what -> helpEntry what + [StringLike s] -> helpList False (Just s) + _ -> helpList False Nothing + + flip runContT pure do + + caller <- ContT $ withMyRPC @MailboxAPI rpc + stoAPI <- ContT $ withMyRPC @StorageAPI rpc + let sto = AnyStorage (StorageClient stoAPI) + lift $ run (dict sto caller) cli >>= eatNil display + + +-- man entries + +createMailBoxDesc :: Doc a +createMailBoxDesc = [qc| +; creates a mailbox using recipient SIGN public key + +create --key KEY TYPE + +; creates a mailbox using key from a SIGIL with HASH (should stored first) + +create --sigil HASH TYPE + +; creates a mailbox using key from a SIGIL from FILE + +create --sigil-file FILE TYPE + +TYPE ::= hub | relay + +|] + +createMailBoxExamples :: ManExamples +createMailBoxExamples = [qc| +; create using recipient public key + +create --key 3fKeGjaDGBKtNqeNBPsThh8vSj4TPiqaaK7uHbB8MQUV relay + +; create using sigil hash + +create --sigil ghna99Xtm33ncfdUBT3htBUoEyT16wTZGMdm24BQ1kh relay + +; create using sigil file + +create --sigil-file ./my.sigil hub + +see hbs2-cli for sigil commands (create, store, load, etc) + +|] + + +sendMessageDesc :: Doc a +sendMessageDesc = [qc| +; reads message blob from stdin + +send --stdin + +; read message blob from file + +send --file FILE + +; reads message blob from storage + +send HASH + +you may create a message from plain text using + +hbs2-cli hbs2:mailbox:message:create + +command + +SEE ALSO + hbs2:mailbox:message:create + +|] + + +setPolicyDesc :: Doc a +setPolicyDesc = [qc| + set-policy (MAILBOX-KEY :: PUBKEY) (VERSION :: INT) FILENAME +|] + +setPolicyExamples :: ManExamples +setPolicyExamples = mempty + +deleteMessageDesc :: Doc a +deleteMessageDesc = [qc| + +;; deletes message from mailbox + delete:message MAILBOX-KEY MESSAGE-HASH + +|] + + diff --git a/hbs2-peer/app/MailboxProtoWorker.hs b/hbs2-peer/app/MailboxProtoWorker.hs new file mode 100644 index 00000000..dc777ec9 --- /dev/null +++ b/hbs2-peer/app/MailboxProtoWorker.hs @@ -0,0 +1,970 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# Language MultiWayIf #-} +{-# Language AllowAmbiguousTypes #-} +{-# Language UndecidableInstances #-} +{-# Language PatternSynonyms #-} +module MailboxProtoWorker ( mailboxProtoWorker + , createMailboxProtoWorker + , MailboxProtoWorker + , IsMailboxProtoAdapter + , MailboxProtoException(..) + , hbs2MailboxDirOpt + ) where + +import HBS2.Prelude.Plated +import HBS2.OrDie +import HBS2.Actors.Peer +import HBS2.Data.Types.Refs +import HBS2.Data.Detect +import HBS2.Net.Proto +import HBS2.Base58 +import HBS2.Storage +import HBS2.Storage.Operations.Missed +import HBS2.Storage.Operations.ByteString +import HBS2.Merkle +import HBS2.Hash +import HBS2.Net.Auth.Credentials +import HBS2.Data.Types.SignedBox +import HBS2.Net.Proto.Types +import HBS2.Peer.Proto +import HBS2.Peer.Proto.Mailbox +import HBS2.Peer.Proto.Mailbox.Entry +import HBS2.Peer.Proto.Mailbox.Policy +import HBS2.Peer.Proto.Mailbox.Policy.Basic +import HBS2.Net.Messaging.Unix +import HBS2.Net.Auth.Credentials + +import HBS2.Polling +import HBS2.System.Dir +import HBS2.Misc.PrettyStuff + +import Brains +import PeerConfig +import PeerTypes +import BlockDownload() + +import DBPipe.SQLite as Q + +import Data.Config.Suckless.Script + +import Control.Concurrent.STM qualified as STM +-- import Control.Concurrent.STM.TBQueue +import Control.Monad.Trans.Cont +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Except +import Control.Monad.Except (throwError) +import Data.Coerce +import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HM +import Data.HashSet (HashSet) +import Data.HashSet qualified as HS +import Data.Either +import Data.List qualified as L +import Data.Maybe +import Data.Word +import Data.Hashable +import Codec.Serialise +import Lens.Micro.Platform +import Text.InterpolatedString.Perl6 (qc) +import Streaming.Prelude qualified as S +import UnliftIO + +newtype PolicyHash = PolicyHash HashRef + deriving newtype (Eq,Ord,Show,Hashable,Pretty) + +instance FromField PolicyHash where + fromField s = PolicyHash . fromString <$> fromField @String s + +instance ToField PolicyHash where + toField f = toField (show $ pretty f) + +data MailboxProtoException = + MailboxProtoWorkerTerminatedException + | MailboxProtoCantAccessMailboxes FilePath + | MailboxProtoMailboxDirNotSet + deriving stock (Show,Typeable) + +instance Exception MailboxProtoException + +hbs2MailboxDirOpt :: String +hbs2MailboxDirOpt = "hbs2:mailbox:dir" + +{- HLINT ignore "Functor law" -} + +data PolicyDownload s = + PolicyDownload + { policyDownloadWhen :: Word64 + , policyDownloadWhat :: SetPolicyPayload s + , policyDownloadBox :: HashRef + } + deriving stock (Generic) + +instance ForMailbox s => Serialise (PolicyDownload s) + +deriving instance ForMailbox s => Eq (PolicyDownload s) + +instance ForMailbox s => Hashable (PolicyDownload s) where + hashWithSalt s p = hashWithSalt s (serialise p) + +data MailboxDownload s = + MailboxDownload + { mailboxRef :: MailboxRefKey s + , mailboxStatusRef :: HashRef + , mailboxDownWhen :: Word64 + , mailboxDownPolicy :: Maybe PolicyVersion + , mailboxDownDone :: Bool + } + deriving stock (Generic) + +deriving stock instance ForMailbox s => Eq (MailboxDownload s) + +instance ForMailbox s => Hashable (MailboxDownload s) + +data MailboxProtoWorker (s :: CryptoScheme) e = + MailboxProtoWorker + { mpwPeerEnv :: PeerEnv e + , mpwDownloadEnv :: DownloadEnv e + , mpwStorage :: AnyStorage + , mpwCredentials :: PeerCredentials s + , mpwFetchQ :: TVar (HashSet (MailboxRefKey s)) + , inMessageQueue :: TBQueue (Maybe (PubKey 'Sign s), Message s, MessageContent s) + , inMessageMergeQueue :: TVar (HashMap (MailboxRefKey s) (HashSet HashRef)) + , inPolicyDownloadQ :: TVar (HashMap HashRef (PolicyDownload s)) + , inMailboxDownloadQ :: TVar (HashMap HashRef (MailboxDownload s)) + , inMessageQueueInNum :: TVar Int + , inMessageQueueOutNum :: TVar Int + , inMessageQueueDropped :: TVar Int + , inMessageDeclined :: TVar Int + , mailboxDB :: TVar (Maybe DBPipeEnv) + } + +okay :: Monad m => good -> m (Either bad good) +okay good = pure (Right good) + +pattern PlainMessageDelete :: forall {s :: CryptoScheme} . HashRef -> DeleteMessagesPayload s +pattern PlainMessageDelete x <- DeleteMessagesPayload (MailboxMessagePredicate1 (Op (MessageHashEq x))) + +instance IsAcceptPolicy HBS2Basic () where + policyAcceptPeer _ _ = pure True + policyAcceptMessage _ _ _ = pure True + policyAcceptSender _ _ = pure True + +instance (s ~ HBS2Basic, e ~ L4Proto, s ~ Encryption e) => IsMailboxProtoAdapter s (MailboxProtoWorker s e) where + + mailboxGetCredentials = pure . mpwCredentials + + mailboxGetStorage = pure . mpwStorage + + mailboxGetPolicy MailboxProtoWorker{..} mbox = do + let def = AnyPolicy (defaultBasicPolicy @s) + fromMaybe def <$> runMaybeT do + dbe <- readTVarIO mailboxDB >>= toMPlus + co <- loadPolicyContent dbe mpwStorage mbox + pure (AnyPolicy co) + + mailboxAcceptMessage MailboxProtoWorker{..} peer m c = do + atomically do + full <- isFullTBQueue inMessageQueue + if full then do + modifyTVar inMessageQueueDropped succ + else do + writeTBQueue inMessageQueue (peer, m,c) + modifyTVar inMessageQueueInNum succ + + mailboxAcceptDelete MailboxProtoWorker{..} mbox dmp box = do + debug $ red "<<>> mailbox: mailboxAcceptDelete" <+> pretty mbox + + let sto = mpwStorage + -- TODO: add-policy-reference + + flip runContT pure do + + h' <- putBlock sto (serialise box) + + h <- ContT $ maybe1 h' storageFail + + let proof = ProofOfDelete (Just (HashRef h)) + + let what' = case dmp of + PlainMessageDelete x -> Just x + _ -> Nothing + + what <- ContT $ maybe1 what' unsupportedPredicate + + let de = Deleted proof what + + deh' <- enqueueBlock sto (serialise (Deleted proof what)) + <&> fmap HashRef + + deh <- ContT $ maybe1 deh' storageFail + + atomically $ modifyTVar inMessageMergeQueue (HM.insert mbox (HS.singleton deh)) + + where + storageFail = err $ red "mailbox (storage:critical)" <+> "block writing failure" + unsupportedPredicate = err $ red "mailbox (unsuported-predicate)" + +instance ( s ~ Encryption e, e ~ L4Proto + ) => IsMailboxService s (MailboxProtoWorker s e) where + mailboxCreate MailboxProtoWorker{..} t p = do + debug $ "mailboxWorker.mailboxCreate" <+> pretty (AsBase58 p) <+> pretty t + + flip runContT pure $ callCC \exit -> do + + mdbe <- readTVarIO mailboxDB + + dbe <- ContT $ maybe1 mdbe (pure $ Left (MailboxCreateFailed "database not ready")) + + r <- liftIO $ try @_ @SomeException $ withDB dbe do + insert [qc| + insert into mailbox (recipient,type) + values (?,?) + on conflict (recipient) do nothing + |] (show $ pretty $ AsBase58 p, show $ pretty t) + + case r of + Right{} -> pure $ Right () + Left{} -> pure $ Left (MailboxCreateFailed "database operation") + + mailboxSetPolicy me@MailboxProtoWorker{..} sbox = do + -- check policy version + -- check policy has peers + -- write policy block + -- update reference to policy block + -- + -- test: write policy, check mailboxGetStatus + + debug $ red "mailboxSetPolicy" + + runExceptT do + + -- check policy signature + (who, spp) <- unboxSignedBox0 sbox + & orThrowError (MailboxAuthError "invalid signature") + + dbe <- readTVarIO mailboxDB + >>= orThrowError (MailboxSetPolicyFailed "database not ready") + + loaded <- loadPolicyPayloadFor dbe mpwStorage (MailboxRefKey @s who) + <&> fmap ( unboxSignedBox0 @(SetPolicyPayload s) @s . snd ) + <&> join + + what <- case loaded of + Nothing -> do + err $ red "mailboxSetPolicy FUCKED" + putBlock mpwStorage (serialise sbox) + >>= orThrowError (MailboxSetPolicyFailed "storage error") + <&> HashRef + + Just (k, spp0) | sppPolicyVersion spp > sppPolicyVersion spp0 || k /= who -> do + putBlock mpwStorage (serialise sbox) + >>= orThrowError (MailboxSetPolicyFailed "storage error") + <&> HashRef + + _ -> do + throwError (MailboxSetPolicyFailed "too old") + + liftIO $ withDB dbe $ Q.transactional do + insert [qc| insert into policy (mailbox,hash) values(?,?) + on conflict (mailbox) do update set hash = excluded.hash + |] (MailboxRefKey @s who, PolicyHash what) + + + void $ runMaybeT do + msp <- mailboxGetStatus me (MailboxRefKey @s who) + >>= toMPlus + >>= toMPlus + + creds <- mailboxGetCredentials @s me + let box = makeSignedBox @s (view peerSignPk creds) (view peerSignSk creds) msp + + liftIO $ withPeerM mpwPeerEnv do + gossip (MailBoxProtoV1 @s @e (MailboxStatus box)) + + pure what + + mailboxDelete MailboxProtoWorker{..} mbox = do + + flip runContT pure do + + mdbe <- readTVarIO mailboxDB + + dbe <- ContT $ maybe1 mdbe (pure $ Left (MailboxOperationError "database not ready")) + + debug $ red "delete fucking mailbox" <+> pretty (MailboxRefKey @s mbox) + + -- TODO: actually-purge-messages-and-attachments + withDB dbe do + insert [qc| delete from mailbox where recipient = ? |] (Only (MailboxRefKey @s mbox)) + + delRef mpwStorage (MailboxRefKey @s mbox) + + pure $ Right () + + mailboxSendDelete w@MailboxProtoWorker{..} box = do + debug $ red "mailboxSendDelete" + + flip runContT pure do + + -- 1. unpack-and-check + let r = unboxSignedBox0 box + + (k, _) <- ContT $ maybe1 r authFailed + + mdbe <- readTVarIO mailboxDB + + dbe <- ContT $ maybe1 mdbe dbNotReady + + t <- getMailboxType_ dbe (MailboxRefKey @s k) + + void $ ContT $ maybe1 t (noMailbox k) + + -- 2. what? + -- gossip and shit + + liftIO $ withPeerM mpwPeerEnv do + me <- ownPeer @e + runResponseM me $ do + mailboxProto @e True w (MailBoxProtoV1 (DeleteMessages box)) + + okay () + + where + dbNotReady = pure $ Left (MailboxOperationError "database not ready") + authFailed = pure $ Left (MailboxAuthError "inconsistent signature") + noMailbox k = pure $ + Left (MailboxOperationError (show $ "no mailox" <+> pretty (AsBase58 k))) + + + mailboxSendMessage w@MailboxProtoWorker{..} mess = do + -- we do not check message signature here + -- because it will be checked in the protocol handler anyway + liftIO $ withPeerM mpwPeerEnv do + me <- ownPeer @e + runResponseM me $ do + mailboxProto @e True w (MailBoxProtoV1 (SendMessage mess)) + + pure $ Right () + + mailboxListBasic MailboxProtoWorker{..} = do + + flip runContT pure do + + mdbe <- readTVarIO mailboxDB + + dbe <- ContT $ maybe1 mdbe (pure $ Left (MailboxCreateFailed "database not ready")) + + debug $ red "mailboxListBasic" + + r <- listMailboxes dbe + + pure $ Right r + + mailboxAcceptStatus me@MailboxProtoWorker{..} ref who s2@MailBoxStatusPayload{..} = do + + flip runContT pure $ callCC \stop -> do + + s0 <- runMaybeT do + MailBoxStatusPayload{..} <- mailboxGetStatus me ref + >>= toMPlus + >>= toMPlus + toMPlus mbsMailboxHash + + now <- liftIO $ getPOSIXTime <&> round + + mdbe <- readTVarIO mailboxDB + + dbe <- ContT $ maybe1 mdbe (pure $ Left (MailboxCreateFailed "database not ready")) + + p0 <- loadPolicyPayloadFor dbe mpwStorage ref + <&> fmap (sppPolicyVersion . snd) . ((unboxSignedBox0 . snd) =<<) + <&> fromMaybe 0 + + let bogusPolicyMessage = + err $ red "!!! arrived invalid policy signature for" + <+> pretty ref + <+> "from" + <+> pretty (AsBase58 who) + + let downloadStatus v = do + maybe1 mbsMailboxHash (okay ()) $ \h -> do + when (s0 /= Just h) do + startDownloadStuff me h + -- one download per version per hash + let downKey = HashRef $ hashObject (serialise (v,h)) + atomically $ modifyTVar inMailboxDownloadQ (HM.insert downKey (MailboxDownload ref h now v False)) + okay () + + case mbsMailboxPolicy of + Nothing -> downloadStatus Nothing + + Just newPolicy -> do + + -- TODO: handle-invalid-policy-error + -- not "okay" actually + + (rcptKey, pNew) <- ContT $ maybe1 (unboxSignedBox0 newPolicy) + (bogusPolicyMessage >> okay ()) + + when (coerce rcptKey /= ref) $ lift bogusPolicyMessage >> stop (Right ()) + + when (sppPolicyVersion pNew > p0) do + startDownloadStuff me (sppPolicyRef pNew) + + mph <- putBlock mpwStorage (serialise newPolicy) + + for_ mph $ \ph -> do + let insActually = HM.insert (sppPolicyRef pNew) (PolicyDownload now pNew (HashRef ph)) + atomically $ modifyTVar inPolicyDownloadQ insActually + + let v = Just $ max p0 (sppPolicyVersion pNew) + + downloadStatus v + + mailboxGetStatus MailboxProtoWorker{..} ref = do + -- TODO: support-policy-ASAP + + now <- liftIO $ getPOSIXTime <&> round + + flip runContT pure do + + mdbe <- readTVarIO mailboxDB + + dbe <- ContT $ maybe1 mdbe (pure $ Left (MailboxCreateFailed "database not ready")) + + t' <- getMailboxType_ dbe ref + + t <- ContT $ maybe1 t' (pure $ Right Nothing) + + v <- getRef mpwStorage ref <&> fmap HashRef + + spp <- loadPolicyPayloadFor dbe mpwStorage ref + <&> fmap snd + + pure $ Right $ Just $ MailBoxStatusPayload @s now (coerce ref) t v spp + + mailboxFetch MailboxProtoWorker{..} ref = do + debug $ red "mailboxFetch" <+> pretty ref + atomically (modifyTVar mpwFetchQ (HS.insert ref)) + okay () + +startDownloadStuff :: forall s e m . (ForMailbox s, s ~ Encryption e, MyPeer e, MonadIO m) + => MailboxProtoWorker s e + -> HashRef + -> m () + +startDownloadStuff MailboxProtoWorker{..} href = do + liftIO $ withPeerM mpwPeerEnv $ withDownload mpwDownloadEnv + $ do + debug $ "startDownloadStuff" <+> pretty href + addDownload @e Nothing (coerce href) + +listMailboxes :: forall s m . (ForMailbox s, MonadIO m) + => DBPipeEnv + -> m [(MailboxRefKey s, MailboxType)] +listMailboxes dbe = do + withDB dbe do + select_ [qc|select recipient,type from mailbox|] + +loadPolicyPayloadFor :: forall s m . (ForMailbox s, MonadIO m) + => DBPipeEnv + -> AnyStorage + -> MailboxRefKey s + -> m (Maybe (HashRef, SignedBox (SetPolicyPayload s) s)) +loadPolicyPayloadFor dbe sto who = do + phash <- withDB dbe do + select @(Only PolicyHash) [qc|select hash from policy where mailbox = ?|] (Only who) + <&> fmap (coerce @_ @HashRef . fromOnly) + <&> headMay + + runMaybeT do + ha <- toMPlus phash + what <- getBlock sto (coerce ha) + >>= toMPlus + <&> deserialiseOrFail + >>= toMPlus + pure (ha, what) + + +loadPolicyPayloadUnboxed :: forall s m . (ForMailbox s, MonadIO m) + => DBPipeEnv + -> AnyStorage + -> MailboxRefKey s + -> m (Maybe (SetPolicyPayload s)) +loadPolicyPayloadUnboxed dbe sto mbox = do + loadPolicyPayloadFor dbe sto mbox + <&> fmap snd + <&> fmap unboxSignedBox0 + <&> join + <&> fmap snd + +loadPolicyContent :: forall s m . (s ~ HBS2Basic, ForMailbox s, MonadIO m) + => DBPipeEnv + -> AnyStorage + -> MailboxRefKey s + -> m (BasicPolicy s) +loadPolicyContent dbe sto mbox = do + let def = defaultBasicPolicy @s + fromMaybe def <$> runMaybeT do + SetPolicyPayload{..} <- loadPolicyPayloadUnboxed dbe sto mbox >>= toMPlus + + lbs' <- runExceptT (readFromMerkle sto (SimpleKey (coerce sppPolicyRef))) + + when (isLeft lbs') do + warn $ yellow "can't read policy for" <+> pretty mbox + + syn' <- toMPlus lbs' + <&> LBS8.unpack + <&> parseTop + + when (isLeft syn') do + warn $ yellow "can't parse policy for" <+> pretty mbox + + syn <- toMPlus syn' + + liftIO (parseBasicPolicy syn) >>= toMPlus + +getMailboxType_ :: (ForMailbox s, MonadIO m) => DBPipeEnv -> MailboxRefKey s -> m (Maybe MailboxType) +getMailboxType_ d r = do + let sql = [qc|select type from mailbox where recipient = ? limit 1|] + withDB d do + select @(Only String) sql (Only r) + <&> fmap (fromStringMay @MailboxType . fromOnly) + <&> headMay . catMaybes + +createMailboxProtoWorker :: forall s e m . ( MonadIO m + , s ~ Encryption e + , ForMailbox s + ) + => PeerCredentials s + -> PeerEnv e + -> DownloadEnv e + -> AnyStorage + -> m (MailboxProtoWorker s e) +createMailboxProtoWorker pc pe de sto = do + -- FIXME: queue-size-hardcode + -- $class: hardcode + MailboxProtoWorker pe de sto pc + <$> newTVarIO mempty + <*> newTBQueueIO 8000 + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO Nothing + +mailboxProtoWorker :: forall e s m . ( MonadIO m + , MonadUnliftIO m + , MyPeer e + , HasStorage m + , Sessions e (KnownPeer e) m + , HasGossip e (MailBoxProto s e) m + , Signatures s + , s ~ Encryption e + , IsRefPubKey s + , ForMailbox s + , m ~ PeerM e IO + , e ~ L4Proto + ) + => m [Syntax C] + -> MailboxProtoWorker s e + -> m () + +mailboxProtoWorker readConf me@MailboxProtoWorker{..} = do + + pause @'Seconds 1 + + flip runContT pure do + + dbe <- lift $ mailboxStateEvolve readConf me + + dpipe <- ContT $ withAsync (runPipe dbe) + + inq <- ContT $ withAsync (mailboxInQ dbe) + + mergeQ <- ContT $ withAsync mailboxMergeQ + + mCheckQ <- ContT $ withAsync (mailboxCheckQ dbe) + + mFetchQ <- ContT $ withAsync (mailboxFetchQ dbe) + + pDownQ <- ContT $ withAsync (policyDownloadQ dbe) + + sDownQ <- ContT $ withAsync stateDownloadQ + + bs <- ContT $ withAsync do + + forever do + pause @'Seconds 10 + debug $ "I'm" <+> yellow "mailboxProtoWorker" + + void $ waitAnyCancel [bs,dpipe,inq,mergeQ,pDownQ,sDownQ,mCheckQ,mFetchQ] + + `catch` \( e :: MailboxProtoException ) -> do + err $ red "mailbox protocol worker terminated" <+> viaShow e + + `finally` do + warn $ yellow "mailbox protocol worker exited" + + where + + mailboxInQ dbe = do + let sto = mpwStorage + forever do + pause @'Seconds 10 + mess <- atomically $ STM.flushTBQueue inMessageQueue + for_ mess $ \(peer, m, s) -> do + atomically $ modifyTVar inMessageQueueInNum pred + + -- TODO: process-with-policy + + for_ (messageRecipients s) $ \rcpt -> void $ runMaybeT do + + let theMailbox = MailboxRefKey @s rcpt + + mbox <- getMailboxType_ @s dbe theMailbox + >>= toMPlus + + -- FIXME: excess-sign-check + (sender, _) <- unboxSignedBox0 (messageContent m) & toMPlus + + po <- mailboxGetPolicy @s me theMailbox + + acceptPeer <- maybe1 peer (pure True) $ \p -> + policyAcceptPeer @s po p + + unless acceptPeer do + warn $ red "message dropped by peer policy" + <+> pretty mbox <+> pretty (fmap AsBase58 peer) + mzero + + accept <- policyAcceptMessage @s po sender s + + unless accept do + warn $ red "message dropped by policy for" <+> pretty theMailbox + mzero + + -- TODO: ASAP-block-accounting + ha' <- putBlock sto (serialise m) <&> fmap HashRef + + ha <- case ha' of + Just x -> pure x + Nothing -> do + err $ red "storage error, can't store message" + mzero + + debug $ yellow "mailbox: message stored" <+> pretty theMailbox <+> pretty ha + + -- TODO: add-policy-reference + let proof = ProofOfExist mzero + h' <- enqueueBlock sto (serialise (Exists proof ha)) + + for_ h' $ \h -> do + atomically do + modifyTVar inMessageMergeQueue (HM.insertWith (<>) theMailbox (HS.singleton (HashRef h))) + + -- TODO: check-attachment-policy-for-mailbox + + -- TODO: ASAP-block-accounting-for-attachment + for_ (messageParts s) (startDownloadStuff me) + either (startDownloadStuff me) dontHandle (messageGK0 s) + + + mailboxMergeQ = do + let sto = mpwStorage + -- FIXME: poll-timeout-hardcode? + let mboxes = readTVarIO inMessageMergeQueue + <&> fmap (,2) . HM.keys . HM.filter ( not . HS.null ) + + polling (Polling 2 5) mboxes $ \r -> void $ runMaybeT do + debug $ yellow "mailbox: merge-poll" <+> pretty r + + -- NOTE: reliability + -- в случае отказа сторейджа все эти сообщения будут потеряны + -- однако, ввиду дублирования -- они рано или поздно будут + -- восстановлены с других реплик, если таковые имеются. + -- + -- Кроме того, мы можем писать WAL. + -- + newTx <- atomically do + n <- readTVar inMessageMergeQueue + <&> fromMaybe mempty . HM.lookup r + modifyTVar inMessageMergeQueue (HM.delete r) + pure n + + wipTx <- newTVarIO HS.empty + + newTxProvenL <- S.toList_ $ + for_ newTx $ \th -> void $ runMaybeT do + + tx <- getBlock sto (coerce th) + >>= toMPlus + + case deserialiseOrFail tx of + + Left{} -> do + -- here, but lame + err $ red "mailbox (invalid block)" + void $ putBlock sto (serialise (MergedEntry r th)) + + -- maybe to something more sophisticated + Right (Exists{}) -> lift $ S.yield th + + Right (Deleted (ProofOfDelete{..}) _) -> do + h <- toMPlus deleteMessage + + mbox <- getBlock sto (coerce h) + -- >>= toMPlus + + when (isNothing mbox) do + startDownloadStuff me h + warn $ red "<<~~~>>" <+> "Proof not found!" <+> pretty h + + box <- toMPlus mbox + <&> deserialiseOrFail @(SignedBox (DeleteMessagesPayload s) s) + >>= toMPlus + + debug $ red "<<***>> mailbox:" <+> "found proof of message deleting" <+> pretty h + + (pk,_) <- unboxSignedBox0 box & toMPlus + + guard (MailboxRefKey pk == r) + + debug $ red "<<***>> mailbox:" <+> "PROVEN message deleting" <+> pretty h + + lift $ S.yield th + + let newTxProven = HS.fromList newTxProvenL + + v <- getRef sto r <&> fmap HashRef + txs <- maybe1 v (pure mempty) (readLog (liftIO . getBlock sto) ) + + let mergedTx = HS.fromList txs <> newTxProven & HS.toList + + -- FIXME: size-hardcode-again + let pt = toPTree (MaxSize 6000) (MaxNum 1024) mergedTx + nref <- makeMerkle 0 pt $ \(_,_,bss) -> void $ liftIO $ putBlock sto bss + + updateRef sto r nref + debug $ yellow "mailbox updated" <+> pretty r <+> pretty nref + + for_ newTxProven $ \t -> do + -- FIXME: use-bloom-filter-or-something + -- $class: leak + putBlock sto (serialise (MergedEntry r t)) + + policyDownloadQ dbe = do + + -- FIXME: too-often-checks-affect-performance + -- $class: performance + let policies = readTVarIO inPolicyDownloadQ + <&> HM.toList + <&> fmap (,1) + + polling (Polling 10 10) policies $ \(pk,PolicyDownload{..}) -> do + done <- findMissedBlocks mpwStorage pk <&> L.null + + when done $ flip runContT pure do + + let mbox = MailboxRefKey (sppMailboxKey policyDownloadWhat) + + current <- loadPolicyPayloadUnboxed @s dbe mpwStorage mbox + <&> fmap sppPolicyVersion + <&> fromMaybe 0 + + let downloaded = sppPolicyVersion policyDownloadWhat + + mlbs <- getBlock mpwStorage (coerce policyDownloadBox) + + lbs <- ContT $ maybe1 mlbs (err $ red "storage fail: missed block" <+> pretty pk) + + let msp = deserialiseOrFail @(SignedBox (SetPolicyPayload s) s) lbs + & either (const Nothing) Just + + spb <- ContT $ maybe1 msp (err $ red "storage fail: corrupted block" <+> pretty pk) + + when (downloaded > current) do + void $ mailboxSetPolicy me spb + + atomically $ modifyTVar inPolicyDownloadQ (HM.delete pk) + + stateDownloadQ = do + + let mail = readTVarIO inMailboxDownloadQ + <&> HM.toList + <&> fmap (,10) + + polling (Polling 2 2) mail $ \(pk, down@MailboxDownload{..}) -> do + done <- findMissedBlocks mpwStorage mailboxStatusRef <&> L.null + + fails <- newTVarIO 0 + + when (done && not mailboxDownDone) do + atomically $ modifyTVar inMailboxDownloadQ (HM.insert pk (down { mailboxDownDone = True })) + debug $ "mailbox state downloaded" <+> pretty pk + + when done do + debug $ "mailbox/debug: drop state" <+> pretty pk <+> pretty mailboxStatusRef + + -- FIXME: assume-huge-mailboxes + + walkMerkle @[HashRef] (coerce mailboxStatusRef) (getBlock mpwStorage) $ \case + Left what -> do + err $ red "mailbox: missed block for tree" <+> pretty mailboxStatusRef <+> pretty what + atomically $ modifyTVar fails succ + + Right hs -> do + for_ hs $ \h -> void $ runMaybeT do + debug $ red ">>>" <+> "MERGE MAILBOX ENTRY" <+> pretty h + + -- FIXME: invent-better-filter + -- $class: leak + let mergedEntry = serialise (MergedEntry mailboxRef h) + let mergedH = mergedEntry & hashObject + + already <- getBlock mpwStorage mergedH + + when (isJust already) do + debug $ red "!!!" <+> "skip already merged tx" <+> pretty h + mzero + + entry' <- getBlock mpwStorage (coerce h) + + when (isNothing entry') do + startDownloadStuff me h + atomically $ modifyTVar fails succ + mzero + + entry <- toMPlus entry' + <&> deserialiseOrFail @MailboxEntry + >>= toMPlus + + case entry of + Deleted{} -> do + atomically $ modifyTVar inMessageMergeQueue (HM.insert mailboxRef (HS.singleton h)) + -- write-already-merged + + Exists _ w -> do + debug $ red ">>>" <+> blue "TX: Exists" <+> pretty w + msg' <- getBlock mpwStorage (coerce w) + + case msg' of + Nothing -> do + debug $ red "START DOWNLOAD" <+> pretty w + startDownloadStuff me w + atomically $ modifyTVar fails succ + mzero + + Just msg -> do + let mess = deserialiseOrFail @(Message s) msg + + case mess of + Left{} -> do + warn $ "malformed message" <+> pretty w + void $ putBlock mpwStorage mergedEntry + + Right normal -> do + let checked = unboxSignedBox0 (messageContent normal) + + case checked of + Nothing -> do + warn $ "invalid signature for message" <+> pretty w + void $ putBlock mpwStorage mergedEntry + + Just (_, content) -> do + -- FIXME: what-if-message-queue-full? + mailboxAcceptMessage me mzero normal content + pure () + + failNum <- readTVarIO fails + + when (failNum == 0) do + debug $ "mailbox state process succeed" <+> pretty mailboxStatusRef + atomically $ modifyTVar inMailboxDownloadQ (HM.delete pk) + + mailboxFetchQ dbe = forever do + toFetch <- atomically $ do + q <- readTVar mpwFetchQ + when (HS.null q) STM.retry + writeTVar mpwFetchQ mempty + pure q + + for_ toFetch $ \r -> do + t <- getMailboxType_ dbe r + maybe1 t none $ \_ -> do + debug $ yellow "mailbox: SEND FETCH REQUEST FOR" <+> pretty r + now <- liftIO (getPOSIXTime <&> round) + gossip (MailBoxProtoV1 @s @e (CheckMailbox (Just now) (coerce r))) + + mailboxCheckQ dbe = do + + -- FIXME: mailbox-check-period + -- right now it's 60 seconds for debug purposes + -- remove hardcode to smth reasonable + let mboxes = liftIO (listMailboxes @s dbe <&> fmap (set _2 600) ) + + polling (Polling 10 10) mboxes $ \r -> do + debug $ yellow "mailbox: SEND FETCH REQUEST FOR" <+> pretty r + now <- liftIO (getPOSIXTime <&> round) + gossip (MailBoxProtoV1 @s @e (CheckMailbox (Just now) (coerce r))) + +mailboxStateEvolve :: forall e s m . ( MonadIO m + , MonadUnliftIO m + , HasStorage m + , s ~ Encryption e + ) + => m [Syntax C] + -> MailboxProtoWorker s e -> m DBPipeEnv + +mailboxStateEvolve readConf MailboxProtoWorker{..} = do + + conf <- readConf + + debug $ red "mailboxStateEvolve" <> line <> pretty conf + + mailboxDir <- lastMay [ dir + | ListVal [StringLike o, StringLike dir] <- conf + , o == hbs2MailboxDirOpt + ] + & orThrow MailboxProtoMailboxDirNotSet + + r <- try @_ @SomeException (mkdir mailboxDir) + + either (const $ throwIO (MailboxProtoCantAccessMailboxes mailboxDir)) dontHandle r + + dbe <- newDBPipeEnv dbPipeOptsDef (mailboxDir "state.db") + + atomically $ writeTVar mailboxDB (Just dbe) + + withDB dbe $ Q.transactional do + ddl [qc|create table if not exists + mailbox ( recipient text not null + , type text not null + , primary key (recipient) + ) + |] + + ddl [qc|create table if not exists + policy ( mailbox text not null + , hash text not null + , primary key (mailbox) + ) + |] + + pure dbe + + +instance ForMailbox s => ToField (MailboxRefKey s) where + toField (MailboxRefKey a) = toField (show $ pretty (AsBase58 a)) + +instance ForMailbox s => FromField (MailboxRefKey s) where + fromField w = fromField @String w <&> fromString @(MailboxRefKey s) + +instance FromField MailboxType where + fromField w = fromField @String w <&> fromString @MailboxType + + diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index a2061b8d..6d17b063 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -11,6 +11,7 @@ import HBS2.Actors.Peer import HBS2.Base58 import HBS2.Merkle import HBS2.Defaults +import HBS2.System.Dir (takeDirectory,()) import HBS2.Events import HBS2.Hash import HBS2.Data.Types.Refs @@ -28,6 +29,7 @@ import HBS2.Peer.Proto import HBS2.Peer.Proto.RefChan qualified as R import HBS2.Peer.Proto.RefChan.Adapter import HBS2.Net.Proto.Notify +import HBS2.Peer.Proto.Mailbox import HBS2.OrDie import HBS2.Storage.Simple import HBS2.Storage.Operations.Missed @@ -53,12 +55,14 @@ import CheckMetrics import RefLog qualified import RefLog (reflogWorker) import LWWRef (lwwRefWorker) +import MailboxProtoWorker import HttpWorker import DispatchProxy import PeerMeta import CLI.Common import CLI.RefChan import CLI.LWWRef +import CLI.Mailbox import RefChan import RefChanNotifyLog import Fetch (fetchHash) @@ -73,6 +77,7 @@ import HBS2.Peer.RPC.API.Peer import HBS2.Peer.RPC.API.RefLog import HBS2.Peer.RPC.API.RefChan import HBS2.Peer.RPC.API.LWWRef +import HBS2.Peer.RPC.API.Mailbox import HBS2.Peer.Notify import HBS2.Peer.RPC.Client.StorageClient @@ -80,6 +85,8 @@ import HBS2.Peer.Proto.LWWRef.Internal import RPC2(RPC2Context(..)) +import Data.Config.Suckless.Script hiding (optional) + import Codec.Serialise as Serialise import Control.Concurrent (myThreadId) import Control.Concurrent.STM @@ -92,6 +99,7 @@ import Data.Aeson qualified as Aeson import Data.ByteString.Lazy qualified as LBS import Data.ByteString qualified as BS import Data.Cache qualified as Cache +import Data.Coerce import Data.Fixed import Data.List qualified as L import Data.Map (Map) @@ -247,6 +255,7 @@ runCLI = do <> command "reflog" (info pRefLog (progDesc "reflog commands")) <> command "refchan" (info pRefChan (progDesc "refchan commands")) <> command "lwwref" (info pLwwRef (progDesc "lwwref commands")) + <> command "mailbox" (info pMailBox (progDesc "mailbox commands")) <> command "peers" (info pPeers (progDesc "show known peers")) <> command "pexinfo" (info pPexInfo (progDesc "show pex")) <> command "download" (info pDownload (progDesc "download management")) @@ -775,6 +784,9 @@ runPeer opts = respawnOnError opts $ runResourceT do s <- simpleStorageInit @HbSync (Just pref) let blk = liftIO . hasBlock s + stoProbe <- newSimpleProbe "StorageSimple" + simpleStorageSetProbe s stoProbe + addProbe stoProbe w <- replicateM defStorageThreads $ async $ liftIO $ simpleStorageWorker s @@ -922,6 +934,8 @@ runPeer opts = respawnOnError opts $ runResourceT do rcw <- async $ liftIO $ runRefChanRelyWorker rce refChanAdapter + mailboxWorker <- createMailboxProtoWorker pc penv denv (AnyStorage s) + let onNoBlock (p, h) = do already <- liftIO $ Cache.lookup nbcache (p,h) <&> isJust unless already do @@ -1130,6 +1144,14 @@ runPeer opts = respawnOnError opts $ runResourceT do peerThread "lwwRefWorker" (lwwRefWorker @e conf (SomeBrains brains)) + -- setup mailboxes stuff + let defConf = coerce conf + let mboxConf = maybe1 pref defConf $ \p -> do + let mboxDir = takeDirectory (coerce p) "hbs2-mailbox" + mkList [mkSym hbs2MailboxDirOpt, mkStr mboxDir] : coerce defConf + + peerThread "mailboxProtoWorker" (mailboxProtoWorker (pure mboxConf) mailboxWorker) + liftIO $ withPeerM penv do runProto @e [ makeResponse (blockSizeProto blk (downloadOnBlockSize denv) onNoBlock) @@ -1146,6 +1168,7 @@ runPeer opts = respawnOnError opts $ runResourceT do , makeResponse (refChanNotifyProto False refChanAdapter) -- TODO: change-all-to-authorized , makeResponse ((authorized . subscribed (SomeBrains brains)) lwwRefProtoA) + , makeResponse ((authorized . mailboxProto False) mailboxWorker) ] @@ -1245,6 +1268,8 @@ runPeer opts = respawnOnError opts $ runResourceT do , rpcDoRefChanHeadPost = refChanHeadPostAction , rpcDoRefChanPropose = refChanProposeAction , rpcDoRefChanNotify = refChanNotifyAction + , rpcMailboxService = AnyMailboxService @s mailboxWorker + , rpcMailboxAdapter = AnyMailboxAdapter @s mailboxWorker } m1 <- async $ runMessagingUnix rpcmsg @@ -1260,6 +1285,7 @@ runPeer opts = respawnOnError opts $ runResourceT do , makeResponse (makeServer @RefChanAPI) , makeResponse (makeServer @StorageAPI) , makeResponse (makeServer @LWWRefAPI) + , makeResponse (makeServer @MailboxAPI) , makeResponse (makeNotifyServer @(RefChanEvents L4Proto) env) , makeResponse (makeNotifyServer @(RefLogEvents L4Proto) envrl) ] diff --git a/hbs2-peer/app/RPC2.hs b/hbs2-peer/app/RPC2.hs index e9e10db9..dd1c9e6d 100644 --- a/hbs2-peer/app/RPC2.hs +++ b/hbs2-peer/app/RPC2.hs @@ -3,6 +3,7 @@ module RPC2 , module RPC2.RefLog , module RPC2.RefChan , module RPC2.LWWRef + , module RPC2.Mailbox ) where @@ -10,4 +11,5 @@ import RPC2.Peer import RPC2.RefLog import RPC2.RefChan import RPC2.LWWRef +import RPC2.Mailbox() diff --git a/hbs2-peer/app/RPC2/Mailbox.hs b/hbs2-peer/app/RPC2/Mailbox.hs new file mode 100644 index 00000000..9263e4eb --- /dev/null +++ b/hbs2-peer/app/RPC2/Mailbox.hs @@ -0,0 +1,110 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# Language UndecidableInstances #-} +module RPC2.Mailbox where + +import HBS2.Peer.Prelude + +import HBS2.Data.Types.Refs +import HBS2.Base58 +import HBS2.Actors.Peer +import HBS2.Data.Types.SignedBox +import HBS2.Peer.Proto +import HBS2.Peer.Proto.Mailbox +import HBS2.Peer.Proto.Mailbox.Ref +import HBS2.Peer.Proto.Mailbox.Types + +import HBS2.Storage +import HBS2.Net.Messaging.Unix +import HBS2.Misc.PrettyStuff + +import HBS2.Peer.RPC.API.Peer + +import PeerTypes + +import HBS2.Peer.RPC.Internal.Types +import HBS2.Peer.RPC.API.Mailbox + +import Data.Either +import Lens.Micro.Platform +import Control.Monad.Reader +import Control.Monad.Trans.Maybe + +type ForMailboxRPC m = ( MonadIO m + , HasRpcContext MailboxAPI RPC2Context m + ) + +instance (MonadIO m) => HandleMethod m RpcMailboxPoke where + + handleMethod key = do + debug "rpc.RpcMailboxPoke" + +instance Monad m => HasRpcContext MailboxAPI RPC2Context (ResponseM UNIX (ReaderT RPC2Context m)) where + getRpcContext = lift ask + +instance (ForMailboxRPC m) => HandleMethod m RpcMailboxCreate where + + handleMethod (puk, t) = do + AnyMailboxService mbs <- getRpcContext @MailboxAPI @RPC2Context <&> rpcMailboxService + void $ mailboxCreate @HBS2Basic mbs t puk + debug $ "rpc.RpcMailboxCreate" <+> pretty (AsBase58 puk) <+> pretty t + +instance (ForMailboxRPC m) => HandleMethod m RpcMailboxSetPolicy where + + handleMethod (puk, sbox) = do + AnyMailboxService mbs <- getRpcContext @MailboxAPI @RPC2Context <&> rpcMailboxService + debug $ "rpc.RpcMailboxSetPolicy" <+> pretty (AsBase58 puk) + mailboxSetPolicy @HBS2Basic mbs sbox + +instance (ForMailboxRPC m) => HandleMethod m RpcMailboxGetStatus where + + handleMethod puk = do + AnyMailboxService mbs <- getRpcContext @MailboxAPI @RPC2Context <&> rpcMailboxService + debug $ "rpc.RpcMailboxGetStatus" <+> pretty (AsBase58 puk) + mailboxGetStatus @HBS2Basic mbs (MailboxRefKey puk) + +instance (ForMailboxRPC m) => HandleMethod m RpcMailboxFetch where + + handleMethod puk = do + AnyMailboxService mbs <- getRpcContext @MailboxAPI @RPC2Context <&> rpcMailboxService + debug $ "rpc.RpcMailboxFetch" <+> pretty (AsBase58 puk) + mailboxFetch @HBS2Basic mbs (MailboxRefKey puk) + +instance (ForMailboxRPC m) => HandleMethod m RpcMailboxDelete where + + handleMethod puk = do + AnyMailboxService mbs <- getRpcContext @MailboxAPI @RPC2Context <&> rpcMailboxService + void $ mailboxDelete @HBS2Basic mbs puk + debug $ "rpc.RpcMailboxDelete" <+> pretty (AsBase58 puk) + +instance (ForMailboxRPC m) => HandleMethod m RpcMailboxList where + + handleMethod _ = do + AnyMailboxService mbs <- getRpcContext @MailboxAPI @RPC2Context <&> rpcMailboxService + r <- mailboxListBasic @HBS2Basic mbs + pure $ fromRight mempty r + +instance (ForMailboxRPC m) => HandleMethod m RpcMailboxSend where + + handleMethod mess = do + co <- getRpcContext @MailboxAPI @RPC2Context + let w = rpcMailboxService co + debug $ "rpc.RpcMailboxSend" + void $ mailboxSendMessage w mess + +instance (ForMailboxRPC m) => HandleMethod m RpcMailboxDeleteMessages where + + handleMethod sbox = do + co <- getRpcContext @MailboxAPI @RPC2Context + let w = rpcMailboxService co + debug $ "rpc.RpcMailboxDeleteMessages" + mailboxSendDelete w sbox + +instance (ForMailboxRPC m) => HandleMethod m RpcMailboxGet where + + handleMethod mbox = do + RPC2Context{..} <- getRpcContext @MailboxAPI @RPC2Context + debug $ "rpc.RpcMailboxGet" + getRef rpcStorage (MailboxRefKey @HBS2Basic mbox) + <&> fmap HashRef + + diff --git a/hbs2-peer/app/RefChan.hs b/hbs2-peer/app/RefChan.hs index 09cf18d9..d0ecbc5c 100644 --- a/hbs2-peer/app/RefChan.hs +++ b/hbs2-peer/app/RefChan.hs @@ -1004,8 +1004,6 @@ logMergeProcess penv env q = withPeerM penv do nref <- makeMerkle 0 pt $ \(_,_,bss) -> do void $ putBlock sto bss - -- TODO: ASAP-emit-refchan-updated-notify - -- $workflow: wip updateRef sto chanKey nref notifyOnRefChanUpdated env chanKey nref diff --git a/hbs2-peer/app/RefLog.hs b/hbs2-peer/app/RefLog.hs index d6ab5e84..334d211c 100644 --- a/hbs2-peer/app/RefLog.hs +++ b/hbs2-peer/app/RefLog.hs @@ -176,7 +176,7 @@ reflogWorker conf brains adapter = do if not (null missed) then do for_ missed $ reflogDownload adapter . fromHashRef pause @'Seconds 1 - debug $ "reflogWorker: MISSED REFS FOR" <+> pretty h <+> pretty missed + debug $ "reflogWorker: MISSED REFS FOR" <+> pretty (AsBase58 reflog) <+> pretty h <+> pretty (length missed) next else do trace $ "block" <+> pretty h <+> "is downloaded" diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 211d7d9f..78f98b75 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -18,7 +18,7 @@ common warnings common common-deps build-depends: - base, hbs2-core, hbs2-storage-simple + base, hbs2-core, hbs2-storage-simple, db-pipe , aeson , async , bytestring @@ -162,6 +162,13 @@ 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.Mailbox.Entry + HBS2.Peer.Proto.Mailbox.Ref + HBS2.Peer.Proto.Mailbox.Policy + HBS2.Peer.Proto.Mailbox.Policy.Basic HBS2.Peer.Proto.BrowserPlugin HBS2.Peer.RPC.Client @@ -173,6 +180,7 @@ library HBS2.Peer.RPC.API.RefLog HBS2.Peer.RPC.API.RefChan HBS2.Peer.RPC.API.LWWRef + HBS2.Peer.RPC.API.Mailbox HBS2.Peer.RPC.API.Storage HBS2.Peer.RPC.Client.Unix HBS2.Peer.RPC.Client.StorageClient @@ -268,6 +276,7 @@ executable hbs2-peer , RPC2.RefLog , RPC2.RefChan , RPC2.LWWRef + , RPC2.Mailbox , PeerTypes , PeerLogger , PeerConfig @@ -275,6 +284,7 @@ executable hbs2-peer , RefChan , RefChanNotifyLog , LWWRef + , MailboxProtoWorker , CheckMetrics , HttpWorker , Brains @@ -282,6 +292,7 @@ executable hbs2-peer , CLI.Common , CLI.RefChan , CLI.LWWRef + , CLI.Mailbox , Paths_hbs2_peer diff --git a/hbs2-peer/lib/HBS2/Peer/Proto.hs b/hbs2-peer/lib/HBS2/Peer/Proto.hs index bba28dd4..f19e35c2 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto.hs @@ -29,6 +29,7 @@ import HBS2.Peer.Proto.RefLog import HBS2.Peer.Proto.RefChan hiding (Notify) import HBS2.Peer.Proto.AnyRef import HBS2.Peer.Proto.LWWRef +import HBS2.Peer.Proto.Mailbox import HBS2.Actors.Peer.Types import HBS2.Net.Messaging.Unix (UNIX) @@ -155,6 +156,16 @@ instance HasProtocol L4Proto (LWWRefProto L4Proto) where encode = serialise requestPeriodLim = ReqLimPerMessage 1 + +instance HasProtocol L4Proto (MailBoxProto HBS2Basic L4Proto) where + type instance ProtocolId (MailBoxProto HBS2Basic L4Proto) = 13001 + type instance Encoded L4Proto = ByteString + decode = either (const Nothing) Just . deserialiseOrFail + encode = serialise + + -- TODO: limit-request-period + requestPeriodLim = NoLimit -- ReqLimPerMessage 1 + instance Serialise (RefChanValidate UNIX) => HasProtocol UNIX (RefChanValidate UNIX) where type instance ProtocolId (RefChanValidate UNIX) = 0xFFFA0001 type instance Encoded UNIX = ByteString diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs new file mode 100644 index 00000000..249c7645 --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs @@ -0,0 +1,330 @@ +{-# Language UndecidableInstances #-} +{-# Language AllowAmbiguousTypes #-} +module HBS2.Peer.Proto.Mailbox + ( module HBS2.Peer.Proto.Mailbox + , module HBS2.Peer.Proto.Mailbox.Message + , module HBS2.Peer.Proto.Mailbox.Types + , module HBS2.Peer.Proto.Mailbox.Ref + ) where + +import HBS2.Prelude.Plated + +import HBS2.Hash +import HBS2.Base58 +import HBS2.Data.Types.Refs +import HBS2.Data.Types.SignedBox +import HBS2.Storage +import HBS2.Actors.Peer.Types +import HBS2.Data.Types.Peer +import HBS2.Net.Auth.Credentials + + +import HBS2.Net.Proto.Sessions +import HBS2.Peer.Proto.Peer +import HBS2.Peer.Proto.Mailbox.Types +import HBS2.Peer.Proto.Mailbox.Message +import HBS2.Peer.Proto.Mailbox.Entry +import HBS2.Peer.Proto.Mailbox.Policy +import HBS2.Peer.Proto.Mailbox.Ref + +import HBS2.Misc.PrettyStuff +import HBS2.System.Logger.Simple + +import Codec.Serialise() +import Control.Monad.Trans.Cont +import Control.Monad.Trans.Maybe +import Data.Maybe +import Data.Word +import Lens.Micro.Platform + + +class ForMailbox s => IsMailboxProtoAdapter s a where + + mailboxGetCredentials :: forall m . MonadIO m => a -> m (PeerCredentials s) + + mailboxGetStorage :: forall m . MonadIO m => a -> m AnyStorage + + mailboxGetPolicy :: forall m . MonadIO m => a -> MailboxRefKey s -> m (AnyPolicy s) + + mailboxAcceptMessage :: forall m . (ForMailbox s, MonadIO m) + => a + -> Maybe (PubKey 'Sign s) -- ^ peer + -> Message s + -> MessageContent s + -> m () + + mailboxAcceptDelete :: forall m . (ForMailbox s, MonadIO m) + => a + -> MailboxRefKey s + -> DeleteMessagesPayload s + -> SignedBox (DeleteMessagesPayload s) s -- ^ we need this for proof + -> m () + +class ForMailbox s => IsMailboxService s a where + + mailboxCreate :: forall m . MonadIO m + => a + -> MailboxType + -> Recipient s + -> m (Either MailboxServiceError ()) + + mailboxSetPolicy :: forall m . MonadIO m + => a + -> SignedBox (SetPolicyPayload s) s + -> m (Either MailboxServiceError HashRef) + + mailboxDelete :: forall m . MonadIO m + => a + -> Recipient s + -> m (Either MailboxServiceError ()) + + mailboxSendMessage :: forall m . MonadIO m + => a + -> Message s + -> m (Either MailboxServiceError ()) + + + mailboxSendDelete :: forall m . MonadIO m + => a + -> SignedBox (DeleteMessagesPayload s) s + -> m (Either MailboxServiceError ()) + + mailboxListBasic :: forall m . MonadIO m + => a + -> m (Either MailboxServiceError [(MailboxRefKey s, MailboxType)]) + + mailboxGetStatus :: forall m . MonadIO m + => a + -> MailboxRefKey s + -> m (Either MailboxServiceError (Maybe (MailBoxStatusPayload s))) + + mailboxAcceptStatus :: forall m . MonadIO m + => a + -> MailboxRefKey s + -> PubKey 'Sign s -- ^ peer's key + -> MailBoxStatusPayload s + -> m (Either MailboxServiceError ()) + + mailboxFetch :: forall m . MonadIO m + => a + -> MailboxRefKey s + -> m (Either MailboxServiceError ()) + +data AnyMailboxService s = + forall a . (IsMailboxService s a) => AnyMailboxService { mailboxService :: a } + +data AnyMailboxAdapter s = + forall a . (IsMailboxProtoAdapter s a) => AnyMailboxAdapter { mailboxAdapter :: a } + +instance ForMailbox s => IsMailboxService s (AnyMailboxService s) where + mailboxCreate (AnyMailboxService a) = mailboxCreate @s a + mailboxSetPolicy (AnyMailboxService a) = mailboxSetPolicy @s a + mailboxDelete (AnyMailboxService a) = mailboxDelete @s a + mailboxSendMessage (AnyMailboxService a) = mailboxSendMessage @s a + mailboxSendDelete (AnyMailboxService a) = mailboxSendDelete @s a + mailboxListBasic (AnyMailboxService a) = mailboxListBasic @s a + mailboxGetStatus (AnyMailboxService a) = mailboxGetStatus @s a + mailboxAcceptStatus (AnyMailboxService a) = mailboxAcceptStatus @s a + mailboxFetch (AnyMailboxService a) = mailboxFetch @s a + +instance ForMailbox s => IsMailboxProtoAdapter s (AnyMailboxAdapter s) where + mailboxGetCredentials (AnyMailboxAdapter a) = mailboxGetCredentials @s a + mailboxGetPolicy (AnyMailboxAdapter a) = mailboxGetPolicy @s a + mailboxGetStorage (AnyMailboxAdapter a) = mailboxGetStorage @s a + mailboxAcceptMessage (AnyMailboxAdapter a) = mailboxAcceptMessage @s a + mailboxAcceptDelete (AnyMailboxAdapter a) = mailboxAcceptDelete @s a + + +mailboxProto :: forall e s m p a . ( MonadIO m + , Response e p m + , HasDeferred p e m + , HasGossip e p m + , IsMailboxProtoAdapter s a + , IsMailboxService s a + , Sessions e (KnownPeer e) m + , p ~ MailBoxProto s e + , s ~ Encryption e + , ForMailbox s + ) + => Bool -- ^ inner, i.e from own peer + -> a + -> MailBoxProto (Encryption e) e + -> m () + +mailboxProto inner adapter mess = deferred @p do + -- common stuff + + sto <- mailboxGetStorage @s adapter + pc <- mailboxGetCredentials @s adapter + + now <- liftIO $ getPOSIXTime <&> round + that <- thatPeer @p + se' <- find (KnownPeerKey that) id + + flip runContT pure $ callCC \exit -> do + + pip <- if inner then do + pure $ view peerSignPk pc + else do + se <- ContT $ maybe1 se' none + pure $ view peerSignKey se + + case mailBoxProtoPayload mess of + SendMessage msg -> do + + debug $ red "AAAAAA!" <+> pretty now + + -- проверить подпись быстрее, чем читать диск + let unboxed' = unboxSignedBox0 @(MessageContent s) (messageContent msg) + + -- ок, сообщение нормальное, шлём госсип, пишем, что обработали + -- TODO: increment-malformed-messages-statistics + -- $workflow: backlog + (_, content) <- ContT $ maybe1 unboxed' none + + + let h = hashObject @HbSync (serialise mess) & HashRef + + let routed = serialise (RoutedEntry h) + let routedHash = hashObject routed + + seen <- hasBlock sto routedHash <&> isJust + + unless seen $ lift do + gossip mess + let whoever = if inner then Nothing else Just pip + + -- TODO: maybe-dont-gossip-message-if-dropped-by-policy + -- сейчас policy проверяется для почтового ящика, + -- а тут мы еще не знаем, какой почтовый ящик и есть + -- ли он вообще. надо бы не рассылать, если пира + -- не поддерживаем. + -- + -- с другой стороны -- мы не поддерживаем, а другие, + -- может, поддерживают. + + mailboxAcceptMessage adapter whoever msg content + -- TODO: expire-block-and-collect-garbage + -- $class: leak + void $ putBlock sto routed + + -- NOTE: CheckMailbox-auth + -- поскольку пир не владеет приватными ключами, + -- то и подписать это сообщение он не может. + -- + -- В таком случае, и в фоновом режиме нельзя будет + -- синхронизировать ящики. + -- + -- Поскольку все сообщения зашифрованы (но не их метаданные!) + -- статус мейлобокса является открытой в принципе информацией. + -- + -- Теперь у нас два пути: + -- 1. Отдавать только авторизованными пирам (которые имеют майлобоксы) + -- для этого сделаем сообщение CheckMailboxAuth{} + -- + -- 2. Шифровать дерево с метаданными, так как нам в принципе + -- может быть известен публичный ключ шифрования автора, + -- но это сопряжено со сложностями с обновлением ключей. + -- + -- С другой стороны, если нас не очень беспокоит возможное раскрытие + -- метаданных --- то тот, кто скачает мейлобокс для анализа --- будет + -- участвовать в раздаче. + -- + -- С другой стороны, может он и хочет участвовать в раздаче, что бы каким-то + -- образом ей вредить или устраивать слежку. + -- + -- С этим всем можно бороться поведением и policy: + -- + -- например: + -- - не отдавать сообщения неизвестным пирам + -- - требовать авторизацию (CheckMailboxAuth не нужен т.к. пир авторизован + -- и так и известен в протоколе) + -- + + CheckMailbox _ k -> do + creds <- mailboxGetCredentials @s adapter + + void $ runMaybeT do + + s <- mailboxGetStatus adapter (MailboxRefKey @s k) + >>= toMPlus + >>= toMPlus + + let box = makeSignedBox @s (view peerSignPk creds) (view peerSignSk creds) s + + lift $ lift $ response @_ @p (MailBoxProtoV1 (MailboxStatus box)) + + MailboxStatus box -> do + + let r = unboxSignedBox0 @(MailBoxStatusPayload s) box + + PeerData{..} <- ContT $ maybe1 se' none + + (who, content@MailBoxStatusPayload{..}) <- ContT $ maybe1 r none + + unless ( who == _peerSignKey ) $ exit () + + -- FIXME: timeout-hardcode + -- может быть вообще не очень хорошо + -- авторизовываться по времени. + -- возможно, надо слать нонс в CheckMailbox + -- и тут его проверять + unless ( abs (now - mbsMailboxPayloadNonce) < 3 ) $ exit () + + -- NOTE: possible-poisoning-attack + -- левый пир генерирует merkle tree сообщений и посылает его. + -- чего он может добиться: добавить "валидных" сообщений, которых не было + -- в ящике изначально. (зашифрованных, подписанных). + -- + -- можно рассылать спам, ведь каждое спам-сообщение + -- будет валидно. + -- мы не можем подписывать что-либо подписью владельца ящика, + -- ведь мы не владеем его ключом. + -- + -- как бороться: в policy ограничивать число пиров, которые + -- могут отдавать статус и игнорировать статусы от прочих пиров. + -- + -- другой вариант -- каким-то образом публикуется подтверждение + -- от автора, что пир X владеет почтовым ящиком R. + -- + -- собственно, это и есть policy. + -- + -- а вот policy мы как раз можем публиковать с подписью автора, + -- он участвует в процессе обновления policy. + + void $ mailboxAcceptStatus adapter (MailboxRefKey mbsMailboxKey) who content + + DeleteMessages box -> do + + -- TODO: possible-ddos + -- посылаем левые сообщения, заставляем считать + -- подписи + -- + -- Решения: ограничивать поток сообщения от пиров + -- + -- Возможно, вообще принимать только сообщения от пиров, + -- которые содержатся в U {Policy(Mailbox_i)} + -- + -- Возможно: PoW + + let r = unboxSignedBox0 box + + (mbox, spp) <- ContT $ maybe1 r none + + let h = hashObject @HbSync (serialise mess) & HashRef + + let routed = serialise (RoutedEntry h) + let routedHash = hashObject routed + + seen <- hasBlock sto routedHash <&> isJust + + unless seen $ lift do + gossip mess + -- TODO: expire-block-and-collect-garbage + -- $class: leak + void $ putBlock sto routed + + mailboxAcceptDelete adapter (MailboxRefKey mbox) spp box + + none + diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Entry.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Entry.hs new file mode 100644 index 00000000..84987476 --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Entry.hs @@ -0,0 +1,66 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# Language UndecidableInstances #-} +{-# Language AllowAmbiguousTypes #-} + +module HBS2.Peer.Proto.Mailbox.Entry where + +import HBS2.Prelude +import HBS2.Peer.Proto.Mailbox.Types +import HBS2.Peer.Proto.Mailbox.Ref + +import Control.Applicative +import Data.Word +import Codec.Serialise +import Data.Hashable +import Data.Maybe + +data ProofOfDelete = + ProofOfDelete + { deleteMessage :: Maybe HashRef -- ^ different things? + } + deriving stock (Generic,Eq,Ord,Show) + +data ProofOfExist = + ProofOfExist + { existedPolicy :: Maybe HashRef + } + deriving stock (Generic,Eq,Ord,Show) + +instance Monoid ProofOfDelete where + mempty = ProofOfDelete mzero + +instance Semigroup ProofOfDelete where + (<>) (ProofOfDelete a1) (ProofOfDelete a2) = ProofOfDelete (a1 <|> a2) + +instance Monoid ProofOfExist where + mempty = ProofOfExist mzero + +instance Semigroup ProofOfExist where + (<>) (ProofOfExist a1) (ProofOfExist a2) = ProofOfExist (a1 <|> a2) + +data MailboxEntry = + Exists ProofOfExist HashRef + | Deleted ProofOfDelete HashRef -- ^ proof-of-message-to-validate + deriving stock (Eq,Ord,Show,Generic) + +instance Hashable MailboxEntry where + hashWithSalt salt = \case + Exists p r -> hashWithSalt salt (0x177c1a3ad45b678e :: Word64, serialise (p,r)) + Deleted p r -> hashWithSalt salt (0xac3196b4809ea027 :: Word64, serialise (p,r)) + +data RoutedEntry = RoutedEntry HashRef + deriving stock (Eq,Ord,Show,Generic) + + +instance Serialise MailboxEntry +instance Serialise RoutedEntry +instance Serialise ProofOfDelete +instance Serialise ProofOfExist + + +data MergedEntry s = MergedEntry (MailboxRefKey s) HashRef + deriving stock (Generic) + +instance ForMailbox s => Serialise (MergedEntry s) + + diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Message.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Message.hs new file mode 100644 index 00000000..ab0e5472 --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Message.hs @@ -0,0 +1,161 @@ +{-# 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.Merkle.MetaData + +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.ByteString.Lazy qualified as LBS +import Data.Text qualified as Text +import Data.Set qualified as Set +import Data.HashMap.Strict qualified as HM +import Lens.Micro.Platform +import Streaming.Prelude qualified as S +import UnliftIO + + +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) + -> [([(Text, Text)], m LBS.ByteString)] -- ^ message parts + -> ByteString -- ^ payload + -> m (Message s) +createMessage CreateMessageServices{..} flags gks sender' rcpts' parts bs = do + + 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 + + trees <- for parts $ \(meta, lbsRead)-> do + + let mt = vcat [ pretty k <> ":" <+> dquotes (pretty v) + | (k,v) <- HM.toList (HM.fromList meta) + ] + & show & Text.pack + + lbs <- lbsRead + createEncryptedTree cmStorage gks gk (DefSource mt lbs) + + let content = MessageContent @s + flags + (Set.fromList (fmap fst recipients)) + (Right gk) + (Set.fromList trees) + encrypted + + creds <- cmLoadCredentials (fst sender) + >>= orThrow (NoCredentialsFound (show $ pretty $ AsBase58 (fst sender))) + + let ssk = view peerSignSk creds + + let box = makeSignedBox @s (fst sender) ssk content + + pure $ MessageBasic box + + where + getKeys = do + S.toList_ $ for_ (sender' : rcpts') $ \case + Right si -> fromSigil Nothing si + Left hs -> do + si <- loadSigil @s cmStorage hs >>= orThrow (SigilNotFound hs) + fromSigil (Just hs) si + fromSigil h si = do + (rcpt, SigilData{..}) <- unboxSignedBox0 (sigilData si) & orThrow (MalformedSigil h) + S.yield (rcpt, sigilDataEncKey) + + +data ReadMessageServices s = + ReadMessageServices + { rmsFindGKS :: forall m . MonadIO m => GroupKey 'Symm s -> m (Maybe GroupSecret) + } + +data ReadMessageError = + ReadSignCheckFailed + | ReadNoGroupKey + | ReadNoGroupKeyAccess + deriving stock (Show,Typeable) + +instance Exception ReadMessageError + +readMessage :: forall s m . ( MonadUnliftIO m + , s ~ HBS2Basic + ) + => ReadMessageServices s + -> Message s + -> m (PubKey 'Sign s, MessageContent s, ByteString) + +readMessage ReadMessageServices{..} msg = do + + (pk, co@MessageContent{..}) <- unboxSignedBox0 (messageContent msg) + & orThrow ReadSignCheckFailed + + -- TODO: support-groupkey-by-reference + gk <- messageGK0 & orThrow ReadNoGroupKey + + gks <- rmsFindGKS gk >>= orThrow ReadNoGroupKeyAccess + + bs <- runExceptT (decryptBlockWithSecret @_ @s gks messageData) + >>= orThrowPassIO + + pure (pk, co, bs) + diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Policy.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Policy.hs new file mode 100644 index 00000000..859ce31f --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Policy.hs @@ -0,0 +1,37 @@ +{-# Language AllowAmbiguousTypes #-} +{-# Language UndecidableInstances #-} +module HBS2.Peer.Proto.Mailbox.Policy where + +import HBS2.Prelude.Plated + +import HBS2.Peer.Proto.Mailbox.Types +-- import HBS2.Peer.Proto.Mailbox + + +class ForMailbox s => IsAcceptPolicy s a where + + policyAcceptPeer :: forall m . MonadIO m + => a + -> PubKey 'Sign s -- ^ peer + -> m Bool + + + policyAcceptSender :: forall m . MonadIO m + => a + -> PubKey 'Sign s -- ^ sender + -> m Bool + + policyAcceptMessage :: forall m . MonadIO m + => a + -> Sender s + -> MessageContent s + -> m Bool + + +data AnyPolicy s = forall a . (ForMailbox s, IsAcceptPolicy s a) => AnyPolicy { thePolicy :: a } + +instance ForMailbox s => IsAcceptPolicy s (AnyPolicy s) where + policyAcceptPeer (AnyPolicy p) = policyAcceptPeer @s p + policyAcceptSender (AnyPolicy p) = policyAcceptSender @s p + policyAcceptMessage (AnyPolicy p) = policyAcceptMessage @s p + diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Policy/Basic.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Policy/Basic.hs new file mode 100644 index 00000000..c6ad52eb --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Policy/Basic.hs @@ -0,0 +1,125 @@ +{-# Language AllowAmbiguousTypes #-} +{-# Language UndecidableInstances #-} +module HBS2.Peer.Proto.Mailbox.Policy.Basic + ( module HBS2.Peer.Proto.Mailbox.Policy + , BasicPolicyAction(..) + , getAsSyntax + , parseBasicPolicy + , defaultBasicPolicy + , BasicPolicy(..) + ) where + +import HBS2.Prelude.Plated + +import HBS2.Base58 +import HBS2.Peer.Proto.Mailbox.Types +import HBS2.Peer.Proto.Mailbox.Policy +import HBS2.Net.Auth.Credentials + +import HBS2.System.Dir + +import Data.Config.Suckless.Script + +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HM +import Data.Maybe + +data BasicPolicyAction = + Allow | Deny + deriving (Eq,Ord,Show,Generic) + +data BasicPolicy s = + BasicPolicy + { bpDefaultPeerAction :: BasicPolicyAction + , bpDefaultSenderAction :: BasicPolicyAction + , bpPeers :: HashMap (PubKey 'Sign s) BasicPolicyAction + , bpSenders :: HashMap (Sender s) BasicPolicyAction + } + deriving stock (Generic,Typeable) + +deriving stock instance ForMailbox s => Eq (BasicPolicy s) + +instance ForMailbox s => Pretty (BasicPolicy s) where + pretty w = pretty (getAsSyntax @C w) + +instance ForMailbox s => IsAcceptPolicy s (BasicPolicy s) where + + policyAcceptPeer BasicPolicy{..} p = do + pure $ Allow == fromMaybe bpDefaultPeerAction (HM.lookup p bpPeers) + + policyAcceptSender BasicPolicy{..} p = do + pure $ Allow == fromMaybe bpDefaultSenderAction (HM.lookup p bpSenders) + + policyAcceptMessage BasicPolicy{..} s m = do + pure $ Allow == fromMaybe bpDefaultSenderAction (HM.lookup s bpSenders) + +getAsSyntax :: forall c s . (ForMailbox s, IsContext c) + => BasicPolicy s -> [Syntax c] +getAsSyntax BasicPolicy{..} = + [ defPeerAction + , defSenderAction + ] <> peerActions <> senderActions + where + defPeerAction = mkList [mkSym "peer", action bpDefaultPeerAction, mkSym "all"] + defSenderAction = mkList [mkSym "sender", action bpDefaultSenderAction, mkSym "all"] + + peerActions = [ mkList [mkSym "peer", action a, mkSym (show $ pretty (AsBase58 who))] + | (who, a) <- HM.toList bpPeers ] + + senderActions = [ mkList [mkSym "sender", action a, mkSym (show $ pretty (AsBase58 who))] + | (who, a) <- HM.toList bpSenders ] + + + action = \case + Allow -> mkSym "allow" + Deny -> mkSym "deny" + +defaultBasicPolicy :: forall s . (ForMailbox s) => BasicPolicy s +defaultBasicPolicy = BasicPolicy Deny Deny mempty mempty + +parseBasicPolicy :: forall s c m . (IsContext c, s ~ HBS2Basic, ForMailbox s, MonadUnliftIO m) + => [Syntax c] + -> m (Maybe (BasicPolicy s)) + +parseBasicPolicy syn = do + + tpAction <- newTVarIO Deny + tsAction <- newTVarIO Deny + tpeers <- newTVarIO mempty + tsenders <- newTVarIO mempty + + for_ syn $ \case + ListVal [SymbolVal "peer", SymbolVal "allow", SymbolVal "all"] -> do + atomically $ writeTVar tpAction Allow + + ListVal [SymbolVal "peer", SymbolVal "deny", SymbolVal "all"] -> do + atomically $ writeTVar tpAction Deny + + ListVal [SymbolVal "peer", SymbolVal "allow", SignPubKeyLike who] -> do + atomically $ modifyTVar tpeers (HM.insert who Allow) + + ListVal [SymbolVal "peer", SymbolVal "deny", SignPubKeyLike who] -> do + atomically $ modifyTVar tpeers (HM.insert who Deny) + + ListVal [SymbolVal "sender", SymbolVal "allow", SymbolVal "all"] -> do + atomically $ writeTVar tsAction Allow + + ListVal [SymbolVal "sender", SymbolVal "deny", SymbolVal "all"] -> do + atomically $ writeTVar tsAction Deny + + ListVal [SymbolVal "sender", SymbolVal "allow", SignPubKeyLike who] -> do + atomically $ modifyTVar tsenders (HM.insert who Allow) + + ListVal [SymbolVal "sender", SymbolVal "deny", SignPubKeyLike who] -> do + atomically $ modifyTVar tsenders (HM.insert who Deny) + + _ -> pure () + + a <- readTVarIO tpAction + b <- readTVarIO tsAction + c <- readTVarIO tpeers + d <- readTVarIO tsenders + + pure $ Just $ BasicPolicy @s a b c d + + diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Ref.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Ref.hs new file mode 100644 index 00000000..5c636c16 --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Ref.hs @@ -0,0 +1,43 @@ +{-# Language UndecidableInstances #-} +module HBS2.Peer.Proto.Mailbox.Ref where + + +import HBS2.Prelude + +import HBS2.Peer.Proto.Mailbox.Types + +import HBS2.Hash +import HBS2.Base58 +import HBS2.Net.Proto.Types +import HBS2.Data.Types.Refs + +import Data.Maybe (fromMaybe) +import Data.Hashable hiding (Hashed) + +newtype MailboxRefKey s = MailboxRefKey (PubKey 'Sign s) + deriving stock Generic + +instance RefMetaData (MailboxRefKey s) + +deriving stock instance IsRefPubKey s => Eq (MailboxRefKey s) + +instance (IsRefPubKey s) => Hashable (MailboxRefKey s) where + hashWithSalt s k = hashWithSalt s (hashObject @HbSync k) + +instance (IsRefPubKey s) => Hashed HbSync (MailboxRefKey s) where + hashObject (MailboxRefKey pk) = hashObject ("mailboxv1|" <> serialise pk) + +instance IsRefPubKey s => FromStringMaybe (MailboxRefKey s) where + fromStringMay s = MailboxRefKey <$> fromStringMay s + +instance IsRefPubKey s => IsString (MailboxRefKey s) where + fromString s = fromMaybe (error "bad public key base58") (fromStringMay s) + +instance Pretty (AsBase58 (PubKey 'Sign s)) => Pretty (AsBase58 (MailboxRefKey s)) where + pretty (AsBase58 (MailboxRefKey k)) = pretty (AsBase58 k) + +instance Pretty (AsBase58 (PubKey 'Sign s)) => Pretty (MailboxRefKey s) where + pretty (MailboxRefKey k) = pretty (AsBase58 k) + +instance ForMailbox s => Serialise (MailboxRefKey s) + diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs new file mode 100644 index 00000000..2dc38526 --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs @@ -0,0 +1,238 @@ +{-# Language UndecidableInstances #-} +{-# Language AllowAmbiguousTypes #-} +module HBS2.Peer.Proto.Mailbox.Types + ( ForMailbox + , MailboxKey + , MailboxType(..) + , MailBoxStatusPayload(..) + , MailboxServiceError(..) + , Recipient + , Sender + , PolicyVersion + , MailboxMessagePredicate(..) + , SimplePredicateExpr(..) + , SimplePredicate(..) + , MailBoxProto(..) + , MailBoxProtoMessage(..) + , Message(..) + , MessageContent(..) + , MessageCompression(..) + , MessageFlags(..) + , MessageTimestamp(..) + , MessageTTL(..) + , DeleteMessagesPayload(..) + , SetPolicyPayload(..) + , module HBS2.Net.Proto.Types + , HashRef + ) where + +import HBS2.Prelude.Plated + +import HBS2.Base58 +import HBS2.Hash +import HBS2.Net.Proto.Types +import HBS2.Data.Types.Refs (HashRef(..)) + +import HBS2.Data.Types.SignedBox +import HBS2.Data.Types.SmallEncryptedBlock(SmallEncryptedBlock(..)) +import HBS2.Net.Auth.GroupKeySymm + +import Codec.Serialise +import Control.Exception +import Data.ByteString (ByteString) +import Data.Maybe +import Data.Set +import Data.Set qualified as Set +import Data.Word + +data MailboxType = + MailboxHub | MailboxRelay + deriving stock (Eq,Ord,Show,Generic) + +instance Serialise MailboxType + +instance Pretty MailboxType where + pretty = \case + MailboxHub -> "hub" + MailboxRelay -> "relay" + +instance FromStringMaybe MailboxType where + fromStringMay = \case + "hub" -> Just MailboxHub + "relay" -> Just MailboxRelay + _ -> Nothing + +instance IsString MailboxType where + fromString s = fromMaybe (error "invalid MailboxType value") (fromStringMay s) + +type MailboxKey s = PubKey 'Sign s + +type Sender s = PubKey 'Sign s + +type Recipient s = PubKey 'Sign s + +type PolicyVersion = Word32 + +type ForMailbox s = ( ForGroupKeySymm s + , Ord (PubKey 'Sign s) + , ForSignedBox s + , Pretty (AsBase58 (PubKey 'Sign s)) + ) + +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) + + +instance Serialise SimplePredicate +instance Serialise SimplePredicateExpr +instance Serialise MailboxMessagePredicate + +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 SetPolicyPayload s = + SetPolicyPayload + { sppMailboxKey :: MailboxKey s + , sppPolicyVersion :: PolicyVersion + , sppPolicyRef :: HashRef -- ^ merkle tree hash of policy description file + } + deriving stock (Generic) + +-- for Hashable +deriving instance ForMailbox s => Eq (SetPolicyPayload s) + +data MailBoxStatusPayload s = + MailBoxStatusPayload + { mbsMailboxPayloadNonce :: Word64 + , mbsMailboxKey :: MailboxKey s + , mbsMailboxType :: MailboxType + , mbsMailboxHash :: Maybe HashRef + , mbsMailboxPolicy :: Maybe (SignedBox (SetPolicyPayload s) s) + } + deriving stock (Generic) + +data DeleteMessagesPayload (s :: CryptoScheme) = + DeleteMessagesPayload + { dmpPredicate :: MailboxMessagePredicate + } + deriving stock (Generic) + +data MailBoxProtoMessage s e = + SendMessage (Message s) -- already has signed box + | CheckMailbox (Maybe Word64) (MailboxKey s) + | MailboxStatus (SignedBox (MailBoxStatusPayload s) s) -- signed by peer + | DeleteMessages (SignedBox (DeleteMessagesPayload s ) s) + deriving stock (Generic) + +data MailBoxProto s e = + MailBoxProtoV1 { mailBoxProtoPayload :: MailBoxProtoMessage s e } + deriving stock (Generic) + +instance ForMailbox s => Serialise (MailBoxStatusPayload s) +instance ForMailbox s => Serialise (SetPolicyPayload s) +instance ForMailbox s => Serialise (DeleteMessagesPayload s) +instance ForMailbox s => Serialise (MailBoxProtoMessage s e) +instance ForMailbox s => Serialise (MailBoxProto s e) + +instance ForMailbox s => Pretty (MailBoxStatusPayload s) where + pretty MailBoxStatusPayload{..} = + parens $ "mailbox-status" <> line <> st + where + st = indent 2 $ + brackets $ + align $ vcat + [ parens ("nonce" <+> pretty mbsMailboxPayloadNonce) + , parens ("key" <+> pretty (AsBase58 mbsMailboxKey)) + , parens ("type" <+> pretty mbsMailboxType) + , element "mailbox-tree" mbsMailboxHash + , element "set-policy-payload-hash" (HashRef . hashObject . serialise <$> mbsMailboxPolicy) + , maybe mempty pretty spp + ] + + element el = maybe mempty ( \v -> parens (el <+> pretty v) ) + + spp = mbsMailboxPolicy >>= unboxSignedBox0 <&> snd + + +instance ForMailbox s => Pretty (SetPolicyPayload s) where + pretty SetPolicyPayload{..} = parens ( "set-policy-payload" <> line <> indent 2 (brackets w) ) + where + w = align $ + vcat [ parens ( "version" <+> pretty sppPolicyVersion ) + , parens ( "ref" <+> pretty sppPolicyRef ) + ] + + +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 + +deriving stock instance ForMailbox s => Eq (MessageContent s) +deriving stock instance ForMailbox s => Eq (Message s) + +instance Serialise MessageTimestamp +instance Serialise MessageTTL +instance Serialise MessageCompression +instance Serialise MessageFlags +instance ForMailbox s => Serialise (MessageContent s) +instance ForMailbox s => Serialise (Message s) + + +data MailboxServiceError = + MailboxCreateFailed String + | MailboxOperationError String + | MailboxSetPolicyFailed String + | MailboxAuthError String + deriving stock (Typeable,Show,Generic) + +instance Serialise MailboxServiceError +instance Exception MailboxServiceError + + diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs index a0045ea1..ac5d20a8 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs @@ -151,6 +151,7 @@ type ForRefChans e = ( Serialise (PubKey 'Sign (Encryption e)) , FromStringMaybe (PubKey 'Sign (Encryption e)) , FromStringMaybe (PubKey 'Encrypt (Encryption e)) , Signatures (Encryption e) + , Eq (Signature (Encryption e)) , Hashable (PubKey 'Encrypt (Encryption e)) , Hashable (PubKey 'Sign (Encryption e)) ) diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs b/hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs new file mode 100644 index 00000000..f2c7b7bf --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs @@ -0,0 +1,78 @@ +{-# Language UndecidableInstances #-} +module HBS2.Peer.RPC.API.Mailbox where + +import HBS2.Peer.Prelude +import HBS2.Net.Proto.Service +import HBS2.Net.Messaging.Unix (UNIX) +import HBS2.Data.Types.Refs (HashRef(..)) +import HBS2.Data.Types.SignedBox + +import HBS2.Peer.Proto.Mailbox.Types +import HBS2.Peer.Proto.Mailbox + +import Data.ByteString.Lazy ( ByteString ) +import Data.ByteString qualified as BS +import Codec.Serialise + +data RpcMailboxPoke +data RpcMailboxCreate +data RpcMailboxSetPolicy +data RpcMailboxDelete +data RpcMailboxGetStatus +data RpcMailboxFetch +data RpcMailboxList +data RpcMailboxSend +data RpcMailboxDeleteMessages +data RpcMailboxGet + +type MailboxAPI = '[ RpcMailboxPoke + , RpcMailboxCreate + , RpcMailboxSetPolicy + , RpcMailboxDelete + , RpcMailboxGetStatus + , RpcMailboxFetch + , RpcMailboxList + , RpcMailboxSend + , RpcMailboxDeleteMessages + , RpcMailboxGet + ] + +type MailboxAPIProto = 0x056091510d3b2ec9 + + +instance HasProtocol UNIX (ServiceProto MailboxAPI UNIX) where + type instance ProtocolId (ServiceProto MailboxAPI UNIX) = MailboxAPIProto + type instance Encoded UNIX = ByteString + decode = either (const Nothing) Just . deserialiseOrFail + encode = serialise + +type instance Input RpcMailboxPoke = () +type instance Output RpcMailboxPoke = () + +type instance Input RpcMailboxCreate = (PubKey 'Sign HBS2Basic, MailboxType) +type instance Output RpcMailboxCreate = () + +type instance Input RpcMailboxSetPolicy = (PubKey 'Sign HBS2Basic, SignedBox (SetPolicyPayload HBS2Basic) HBS2Basic) +type instance Output RpcMailboxSetPolicy = Either MailboxServiceError HashRef + +type instance Input RpcMailboxDelete = (PubKey 'Sign HBS2Basic) +type instance Output RpcMailboxDelete = () + +type instance Input RpcMailboxGetStatus = (PubKey 'Sign HBS2Basic) +type instance Output RpcMailboxGetStatus = Either MailboxServiceError (Maybe (MailBoxStatusPayload 'HBS2Basic)) + +type instance Input RpcMailboxFetch = (PubKey 'Sign HBS2Basic) +type instance Output RpcMailboxFetch = Either MailboxServiceError () + +type instance Input RpcMailboxList = () +type instance Output RpcMailboxList = [(MailboxRefKey 'HBS2Basic, MailboxType)] + +type instance Input RpcMailboxSend = (Message HBS2Basic) +type instance Output RpcMailboxSend = () + +type instance Input RpcMailboxDeleteMessages = (SignedBox (DeleteMessagesPayload HBS2Basic) HBS2Basic) +type instance Output RpcMailboxDeleteMessages = (Either MailboxServiceError ()) + +type instance Input RpcMailboxGet = (PubKey 'Sign HBS2Basic) +type instance Output RpcMailboxGet = (Maybe HashRef) + diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs index 36d8e0ab..720d0020 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs +++ b/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs @@ -7,18 +7,22 @@ module HBS2.Peer.RPC.Internal.Types import HBS2.Prelude import HBS2.Actors.Peer import HBS2.Net.Auth.Credentials +import HBS2.Net.Proto.Types import HBS2.Storage() import HBS2.Data.Types.Refs (HashRef) import HBS2.Data.Types.SignedBox import HBS2.Net.Messaging.Unix import HBS2.Net.Messaging.Encrypted.ByPass (ByPassStat) import HBS2.Net.Proto.Service +import HBS2.Peer.Proto.Mailbox import HBS2.Peer.RPC.Class import HBS2.Peer.Brains import Data.Config.Suckless.Syntax +import Data.Config.Suckless.Parse import Data.Kind +import Control.Monad import Control.Monad.Reader import Data.ByteString ( ByteString ) import UnliftIO @@ -26,19 +30,21 @@ import HBS2.Prelude (asyncLinked) data RPC2Context = RPC2Context - { rpcConfig :: [Syntax C] - , rpcMessaging :: MessagingUnix - , rpcPokeAnswer :: String - , rpcPeerEnv :: PeerEnv L4Proto - , rpcLocalMultiCast :: Peer L4Proto - , rpcStorage :: AnyStorage - , rpcBrains :: SomeBrains L4Proto - , rpcByPassInfo :: IO ByPassStat - , rpcProbes :: TVar [AnyProbe] - , rpcDoFetch :: HashRef -> IO () - , rpcDoRefChanHeadPost :: HashRef -> IO () - , rpcDoRefChanPropose :: (PubKey 'Sign 'HBS2Basic, SignedBox ByteString 'HBS2Basic) -> IO () - , rpcDoRefChanNotify :: (PubKey 'Sign 'HBS2Basic, SignedBox ByteString 'HBS2Basic) -> IO () + { rpcConfig :: [Syntax C] + , rpcMessaging :: MessagingUnix + , rpcPokeAnswer :: String + , rpcPeerEnv :: PeerEnv L4Proto + , rpcLocalMultiCast :: Peer L4Proto + , rpcStorage :: AnyStorage + , rpcBrains :: SomeBrains L4Proto + , rpcByPassInfo :: IO ByPassStat + , rpcProbes :: TVar [AnyProbe] + , rpcDoFetch :: HashRef -> IO () + , rpcDoRefChanHeadPost :: HashRef -> IO () + , rpcDoRefChanPropose :: (PubKey 'Sign 'HBS2Basic, SignedBox ByteString 'HBS2Basic) -> IO () + , rpcDoRefChanNotify :: (PubKey 'Sign 'HBS2Basic, SignedBox ByteString 'HBS2Basic) -> IO () + , rpcMailboxService :: AnyMailboxService HBS2Basic + , rpcMailboxAdapter :: AnyMailboxAdapter HBS2Basic } instance (Monad m, Messaging MessagingUnix UNIX (Encoded UNIX)) => HasFabriq UNIX (ReaderT RPC2Context m) where diff --git a/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs b/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs index d3b68e0e..50690231 100644 --- a/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs +++ b/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs @@ -1,6 +1,7 @@ {-# Language TemplateHaskell #-} {-# Language ScopedTypeVariables #-} {-# Language UndecidableInstances #-} +{-# Language RecordWildCards #-} module HBS2.Storage.Simple ( module HBS2.Storage.Simple , StoragePrefix(..) @@ -18,30 +19,20 @@ import HBS2.System.Logger.Simple import Control.Concurrent.Async import Control.Exception -import Control.Monad -import Control.Monad.Fix -import Control.Monad.Except import Control.Monad.Trans.Maybe import Data.ByteString.Lazy qualified as LBS -import Data.ByteString.Lazy.Char8 qualified as LBS8 import Data.ByteString qualified as BS import Data.ByteString (ByteString) -import Data.Foldable import Data.List qualified as L import Data.Maybe import Data.Map (Map) import Data.Map qualified as Map import Data.Either import Lens.Micro.Platform -import Prettyprinter import System.Directory import System.FilePath.Posix -import System.IO import System.IO.Error -import System.IO.Temp -import System.AtomicWrite.Writer.LazyByteString qualified as AwLBS import System.AtomicWrite.Writer.ByteString qualified as AwBS -import Data.Time.Clock.POSIX (getPOSIXTime) import Data.HashMap.Strict qualified as HashMap import Data.HashMap.Strict (HashMap) @@ -59,8 +50,6 @@ import Control.Concurrent.STM.TBMQueue (TBMQueue) import Control.Concurrent.STM.TVar qualified as TV import Codec.Serialise -import System.Random -import System.Mem -- NOTE: random accessing files in a git-like storage @@ -87,6 +76,7 @@ newtype StorageQueueSize = StorageQueueSize { fromQueueSize :: Int } data SimpleStorage a = SimpleStorage { _storageDir :: FilePath + , _storageProbe :: TVar AnyProbe , _storageOpQ :: TBMQueue ( IO () ) , _storageStopWriting :: TVar Bool , _storageMMaped :: TVar (HashMap (Key a) ByteString) @@ -133,15 +123,24 @@ touchForRead ss k = liftIO $ do mmaped = ss ^. storageMMaped +simpleStorageSetProbe :: forall h m . (MonadIO m, IsSimpleStorageKey h) + => SimpleStorage h + -> AnyProbe + -> m () + +simpleStorageSetProbe SimpleStorage{..} probe = do + liftIO $ atomically $ writeTVar _storageProbe probe + simpleStorageInit :: forall h m opts . (MonadIO m, Data opts, IsSimpleStorageKey h) => opts -> m (SimpleStorage h) simpleStorageInit opts = liftIO $ do let prefix = uniLastDef "." opts :: StoragePrefix - let qSize = uniLastDef 2000 opts :: StorageQueueSize -- FIXME: defaults ? + let qSize = uniLastDef 16000 opts :: StorageQueueSize -- FIXME: defaults ? stor <- SimpleStorage <$> canonicalizePath (fromPrefix prefix) + <*> newTVarIO (AnyProbe ()) <*> TBMQ.newTBMQueueIO (fromIntegral (fromQueueSize qSize)) <*> TV.newTVarIO False <*> TV.newTVarIO mempty @@ -178,11 +177,25 @@ simpleStorageStop ss = do pause ( 0.01 :: Timeout 'Seconds ) >> next simpleStorageWorker :: IsSimpleStorageKey h => SimpleStorage h -> IO () -simpleStorageWorker ss = do +simpleStorageWorker ss@SimpleStorage{..} = do lastKick <- newTVarIO =<< getTimeCoarse flip runContT pure do + ContT $ withAsync $ forever $ liftIO do + pause @'Seconds 10 + probe <- readTVarIO _storageProbe + values <- atomically do + mmapedSize <- readTVar _storageMMaped <&> HashMap.size + mmapedLRUSize <- readTVar _storageMMapedLRU <&> HashMap.size + sizeCacheSize <- Cache.sizeSTM _storageSizeCache + opQ <- TBMQ.estimateFreeSlotsTBMQueue _storageOpQ + pure $ [ ("mmapedSize", mmapedSize) + , ("mmapedLRUSize", mmapedLRUSize) + , ("sizeCacheSize", sizeCacheSize) + , ("opQueueSlots", fromIntegral opQ) + ] + acceptReport probe (fmap (over _2 fromIntegral) values) ContT $ withAsync $ forever $ do pause ( 30 :: Timeout 'Seconds ) -- FIXME: setting diff --git a/miscellaneous/fuzzy-parse/src/Data/Text/Fuzzy/SExp.hs b/miscellaneous/fuzzy-parse/src/Data/Text/Fuzzy/SExp.hs index c6e21dba..c9582a0d 100644 --- a/miscellaneous/fuzzy-parse/src/Data/Text/Fuzzy/SExp.hs +++ b/miscellaneous/fuzzy-parse/src/Data/Text/Fuzzy/SExp.hs @@ -179,7 +179,7 @@ instance MonadError SExpParseError m => MonadError SExpParseError (SExpM m) wher tokenizeSexp :: Text -> [TTok] tokenizeSexp txt = do let spec = delims " \r\t" <> comment ";" - <> punct "'{}()[]\n" + <> punct "`'{}()[]\n" <> sqq <> uw tokenize spec txt @@ -237,8 +237,13 @@ sexp s = case s of (TStrLit l : w) -> pure (String l, w) - -- so far ignored - (TPunct '\'' : rest) -> sexp rest + (TPunct '\'' : rest) -> do + (w, t) <- sexp rest + pure (List [Symbol "'", w], t) + + (TPunct '`' : rest) -> do + (w, t) <- sexp rest + pure (List [Symbol "`", w], t) (TPunct '\n' : rest) -> succLno >> sexp rest diff --git a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/File.hs b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/File.hs index e6fa848d..3e4afafc 100644 --- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/File.hs +++ b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/File.hs @@ -15,6 +15,8 @@ import System.FilePath import System.FilePattern import Data.HashSet qualified as HS +import Prettyprinter + import Lens.Micro.Platform import UnliftIO import Control.Concurrent.STM qualified as STM @@ -67,12 +69,12 @@ entries = do entry $ bindMatch "glob" $ \syn -> do (p,i,d) <- case syn of - [] -> pure (["*"], [], ".") + [] -> pure (["**/*"], ["**/.*"], ".") - [StringLike d, StringLike i, StringLike e] -> do - pure ([i], [e], d) + s@[StringLike d, ListVal (StringLikeList i) ] -> do + pure (i, [], d) - [StringLike d, ListVal (StringLikeList i), ListVal (StringLikeList e)] -> do + s@[StringLike d, ListVal (StringLikeList i), ListVal (StringLikeList e) ] -> do pure (i, e, d) _ -> throwIO (BadFormException @c nil) diff --git a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs index cd368a88..dea95478 100644 --- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs +++ b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs @@ -2,6 +2,7 @@ {-# Language UndecidableInstances #-} {-# Language PatternSynonyms #-} {-# Language ViewPatterns #-} +{-# Language RecordWildCards #-} module Data.Config.Suckless.Script.Internal ( module Data.Config.Suckless.Script.Internal , module Export @@ -16,6 +17,8 @@ import Control.Monad.Reader import Control.Monad.Writer import Data.ByteString (ByteString) import Data.ByteString.Char8 qualified as BS8 +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as LBS import Data.Data import Data.Function as Export import Data.Functor as Export @@ -30,6 +33,8 @@ import Data.String import Data.Text.IO qualified as TIO import Data.Text qualified as Text import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding.Error (ignore) import Data.Time.Clock.POSIX import GHC.Generics hiding (C) import Prettyprinter @@ -116,7 +121,7 @@ instance IsString ManDesc where instance Pretty (Man a) where pretty e = "NAME" <> line - <> indent 8 (pretty (manName e) <> fmtBrief e) + <> indent 4 (pretty (manName e) <> fmtBrief e) <> line <> fmtSynopsis <> fmtDescription @@ -131,14 +136,14 @@ instance Pretty (Man a) where Nothing -> mempty Just (ManReturns t s) -> line <> "RETURN VALUE" <> line - <> indent 8 ( + <> indent 4 ( if not (Text.null s) then (pretty t <> hsep ["","-",""] <> pretty s) <> line else pretty t ) fmtDescription = line <> "DESCRIPTION" <> line - <> indent 8 ( case manDesc e of + <> indent 4 ( case manDesc e of Nothing -> pretty (manBrief e) Just x -> pretty x) <> line @@ -157,13 +162,13 @@ instance Pretty (Man a) where es -> line <> "EXAMPLES" <> line - <> indent 8 ( vcat (fmap pretty es) ) + <> indent 4 ( vcat (fmap pretty es) ) synEntry (ManSynopsis (ManApply [])) = - indent 8 ( parens (pretty (manName e)) ) <> line + indent 4 ( parens (pretty (manName e)) ) <> line synEntry (ManSynopsis (ManApply xs)) = do - indent 8 do + indent 4 do parens (pretty (manName e) <+> hsep [ pretty n | ManApplyArg t n <- xs ] ) <> line @@ -332,18 +337,11 @@ newtype NameNotBoundException = deriving stock Show deriving newtype (Generic,Typeable) -newtype NotLambda = NotLambda Id - deriving stock Show - deriving newtype (Generic,Typeable) - -instance Exception NotLambda data BadFormException c = BadFormException (Syntax c) | ArityMismatch (Syntax c) - -newtype TypeCheckError c = TypeCheckError (Syntax c) - -instance Exception (TypeCheckError C) + | NotLambda (Syntax c) + | TypeCheckError (Syntax c) newtype BadValueException = BadValueException String deriving stock Show @@ -354,8 +352,7 @@ instance Exception NameNotBoundException instance IsContext c => Show (BadFormException c) where show (BadFormException sy) = show $ "BadFormException" <+> pretty sy show (ArityMismatch sy) = show $ "ArityMismatch" <+> pretty sy - -instance IsContext c => Show (TypeCheckError c) where + show (NotLambda sy) = show $ "NotLambda" <+> pretty sy show (TypeCheckError sy) = show $ "TypeCheckError" <+> pretty sy instance Exception (BadFormException C) @@ -434,7 +431,7 @@ opt n d = n <+> "-" <+> d examples :: ManExamples -> MakeDictM c m () -> MakeDictM c m () examples (ManExamples s) = censor (HM.map setExamples ) where - ex = ManExamples (Text.unlines $ Text.strip <$> Text.lines (Text.strip s)) + ex = ManExamples (Text.unlines $ Text.lines (Text.strip s)) ex0 = mempty { manExamples = [ex] } setExamples (Bind w x) = Bind (Just (maybe ex0 (<>ex0) w)) x @@ -485,9 +482,11 @@ apply_ :: forall c m . ( IsContext c apply_ s args = case s of ListVal [SymbolVal "builtin:lambda", SymbolVal n] -> apply n args + SymbolVal "quot" -> pure $ mkList args + SymbolVal "quasiquot" -> mkList <$> mapM evalQQ args SymbolVal what -> apply what args Lambda d body -> applyLambda d body args - e -> throwIO $ BadFormException @c s + e -> throwIO $ NotLambda e apply :: forall c m . ( IsContext c , MonadUnliftIO m @@ -496,6 +495,13 @@ apply :: forall c m . ( IsContext c => Id -> [Syntax c] -> RunM c m (Syntax c) + +apply "quot" args = do + pure $ mkList args + +apply "quasiquot" args = do + mkList <$> mapM evalQQ args + apply name args' = do -- notice $ red "APPLY" <+> pretty name what <- ask >>= readTVarIO <&> HM.lookup name @@ -507,7 +513,7 @@ apply name args' = do applyLambda argz body args' Just (BindValue _) -> do - throwIO (NotLambda name) + throwIO (NotLambda (mkSym @c name)) Nothing -> throwIO (NameNotBound name) @@ -543,6 +549,20 @@ bindBuiltins dict = do atomically do modifyTVar t (<> dict) + +evalQQ :: forall c m . ( IsContext c + , MonadUnliftIO m + , Exception (BadFormException c) + ) => Syntax c -> RunM c m (Syntax c) +evalQQ = \case + SymbolVal (Id w) | Text.isPrefixOf "," w -> do + let what = Id (Text.drop 1 w) + lookupValue what >>= eval + + List c es -> List c <$> mapM evalQQ es + + other -> pure other + eval :: forall c m . ( IsContext c , MonadUnliftIO m , Exception (BadFormException c) @@ -551,11 +571,34 @@ eval syn = handle (handleForm syn) $ do dict <- ask >>= readTVarIO + -- liftIO $ print $ show $ "TRACE EXP" <+> pretty syn + case syn of + SymbolVal (Id s) | Text.isPrefixOf ":" s -> do + pure (mkSym @c (Text.drop 1 s)) + ListVal [ w, SymbolVal ".", b] -> do pure $ mkList [w, b] + ListVal [ SymbolVal ":", b] -> do + pure $ mkList [b] + + ListVal [ SymbolVal "'", ListVal b] -> do + pure $ mkList b + + ListVal [ SymbolVal "'", StringLike x] -> do + pure $ mkSym x + + ListVal [ SymbolVal "'", x] -> do + pure x + + ListVal [ SymbolVal "`", ListVal b] -> do + mkList <$> mapM evalQQ b + + ListVal [ SymbolVal "quasiquot", ListVal b] -> do + mkList <$> mapM evalQQ b + ListVal [ SymbolVal "quot", ListVal b] -> do pure $ mkList b @@ -591,8 +634,9 @@ eval syn = handle (handleForm syn) $ do ListVal (SymbolVal name : args') -> do apply name args' - SymbolVal (Id s) | Text.isPrefixOf ":" s -> do - pure (mkSym @c (Text.drop 1 s)) + ListVal (e' : args') -> do + -- e <- eval e' + apply_ e' args' SymbolVal name | HM.member name dict -> do let what = HM.lookup name dict @@ -607,7 +651,7 @@ eval syn = handle (handleForm syn) $ do e@Literal{} -> pure e - e -> throwIO $ BadFormException @c e + e -> throwIO $ NotLambda @c e where handleForm syn = \case @@ -615,6 +659,9 @@ eval syn = handle (handleForm syn) $ do throwIO (BadFormException syn) (ArityMismatch s :: BadFormException c) -> do throwIO (ArityMismatch syn) + (TypeCheckError s :: BadFormException c) -> do + throwIO (TypeCheckError syn) + other -> throwIO other runM :: forall c m a. ( IsContext c , MonadUnliftIO m @@ -659,9 +706,9 @@ lookupValue :: forall c m . (IsContext c, MonadUnliftIO m) lookupValue i = do ask >>= readTVarIO <&> (fmap bindAction . HM.lookup i) - <&> \case - Just (BindValue s) -> s - _ -> nil + >>= \case + Just (BindValue s) -> pure s + _ -> throwIO (NameNotBound i) nil :: forall c . IsContext c => Syntax c nil = List noContext [] @@ -669,14 +716,14 @@ nil = List noContext [] nil_ :: (IsContext c, MonadIO m) => (a -> RunM c m b) -> a -> RunM c m (Syntax c) nil_ m w = m w >> pure (List noContext []) -fixContext :: (IsContext c1, IsContext c2) => Syntax c1 -> Syntax c2 +fixContext :: forall c1 c2 . (IsContext c1, IsContext c2) => Syntax c1 -> Syntax c2 fixContext = go where go = \case List _ xs -> List noContext (fmap go xs) Symbol _ w -> Symbol noContext w Literal _ l -> Literal noContext l - + OpaqueValue box -> OpaqueValue box fmt :: Syntax c -> Doc ann fmt = \case @@ -786,6 +833,23 @@ internalEntries = do z -> throwIO (BadFormException @C nil) + + entry $ bindMatch "eval" $ \syn -> do + r <- mapM eval syn + pure $ lastDef nil r + + entry $ bindMatch "id" $ \case + [ e ] -> pure e + _ -> throwIO (BadFormException @C nil) + + entry $ bindMatch "inc" $ \case + [ LitIntVal n ] -> pure (mkInt (succ n)) + _ -> throwIO (TypeCheckError @C nil) + + entry $ bindMatch "dec" $ \case + [ LitIntVal n ] -> pure (mkInt (succ n)) + _ -> throwIO (TypeCheckError @C nil) + entry $ bindMatch "map" $ \syn -> do case syn of [ListVal (SymbolVal "builtin:lambda" : SymbolVal fn : _), ListVal rs] -> do @@ -799,6 +863,16 @@ internalEntries = do _ -> do throwIO (BadFormException @C nil) + entry $ bindMatch "quot" $ \case + [ syn ] -> pure $ mkList [syn] + _ -> do + throwIO (BadFormException @C nil) + + entry $ bindMatch "quasiquot" $ \case + [ syn ] -> mkList . List.singleton <$> evalQQ syn + _ -> do + throwIO (BadFormException @C nil) + entry $ bindMatch "head" $ \case [ ListVal es ] -> pure (head es) _ -> throwIO (TypeCheckError @C nil) @@ -838,6 +912,61 @@ internalEntries = do [ sy ] -> display sy ss -> display (mkList ss) + let colorz = HM.fromList + [ ("red", pure (Red, True)) + , ("red~", pure (Red, False)) + , ("green", pure (Green, True)) + , ("green~", pure (Green, False)) + , ("yellow", pure (Yellow, True)) + , ("yellow~", pure (Yellow, False)) + , ("blue", pure (Blue, True)) + , ("blue~", pure (Blue, False)) + , ("magenta", pure (Magenta, True)) + , ("magenta~",pure (Magenta, False)) + , ("cyan", pure (Cyan, True)) + , ("cyan~", pure (Cyan, False)) + , ("white", pure (White, True)) + , ("white~", pure (White, False)) + , ("black", pure (Black, True)) + , ("black~", pure (Black, False)) + , ("_", mzero) + ] + + + let fgc fg = case join (HM.lookup fg colorz) of + Just (co, True) -> color co + Just (co, False) -> colorDull co + Nothing -> mempty + + let niceTerm f = \case + LitStrVal x -> do + let s = renderStrict $ layoutPretty defaultLayoutOptions (annotate f $ pretty x) + mkStr s + + other -> do + let s = renderStrict $ layoutPretty defaultLayoutOptions (annotate f $ pretty other) + mkStr s + + entry $ bindMatch "ansi" $ \case + [ SymbolVal fg, SymbolVal bg, term ] | HM.member fg colorz && HM.member bg colorz -> do + let b = case join (HM.lookup bg colorz) of + Just (co, True) -> bgColor co + Just (co, False) -> bgColorDull co + Nothing -> mempty + + let f = b <> fgc fg + pure $ niceTerm f term + + [ SymbolVal fg, s] | HM.member fg colorz -> do + let f = fgc fg + pure $ niceTerm f s + -- let wtf = show $ pretty s + -- let x = Text.unpack $ renderStrict $ layoutPretty defaultLayoutOptions (annotate f $ pretty wtf) + -- -- error $ show x + -- pure $ mkStr x + + _ -> throwIO (BadFormException @c nil) + brief "prints new line character to stdout" $ entry $ bindMatch "newline" $ nil_ $ \case [] -> liftIO (putStrLn "") @@ -852,7 +981,7 @@ internalEntries = do [ sy ] -> display sy >> liftIO (putStrLn "") ss -> mapM_ display ss >> liftIO (putStrLn "") - entry $ bindMatch "str:read-stdin" $ \case + entry $ bindMatch "str:stdin" $ \case [] -> liftIO getContents <&> mkStr @c _ -> throwIO (BadFormException @c nil) @@ -862,7 +991,7 @@ internalEntries = do _ -> throwIO (BadFormException @c nil) brief "reads file as a string" do - entry $ bindMatch "str:read-file" $ \case + entry $ bindMatch "str:file" $ \case [StringLike fn] -> liftIO (TIO.readFile fn) <&> mkStr _ -> throwIO (BadFormException @c nil) @@ -875,15 +1004,41 @@ internalEntries = do entry $ bindValue "space" $ mkStr " " - entry $ bindMatch "parse-top" $ \case + let doParseTop w l s = + parseTop s & either (const nil) (mkForm w . fmap ( l . fixContext) ) - [SymbolVal w, LitStrVal s] -> do - pure $ parseTop s & either (const nil) (mkForm w . fmap fixContext) + let wrapWith e = \case + List c es -> List c (e : es) + other -> other + let lwrap = \case + e@(SymbolVal x) -> wrapWith e + _ -> id - [LitStrVal s] -> do - pure $ parseTop s & either (const nil) (mkList . fmap fixContext) + brief "parses string as toplevel and produces a form" + $ desc "parse:top:string SYMBOL STRING-LIKE" + $ entry $ bindMatch "parse:top:string" $ \case - _ -> throwIO (BadFormException @c nil) + [SymbolVal w, LitStrVal s] -> do + pure $ doParseTop w id s + + [SymbolVal w, e@(SymbolVal r), LitStrVal s] -> do + pure $ doParseTop w (lwrap e) s + + _ -> throwIO (BadFormException @c nil) + + brief "parses file as toplevel form and produces a form" + $ desc "parse:top:file SYMBOL " + $ entry $ bindMatch "parse:top:file" $ \case + + [SymbolVal w, StringLike fn] -> do + s <- liftIO $ TIO.readFile fn + pure $ doParseTop w id s + + [SymbolVal w, e@(SymbolVal r), StringLike fn] -> do + s <- liftIO $ TIO.readFile fn + pure $ doParseTop w (lwrap e) s + + _ -> throwIO (BadFormException @c nil) let atomFrom = \case [StringLike s] -> pure (mkSym s) @@ -983,3 +1138,60 @@ internalEntries = do _ -> throwIO (BadFormException @c nil) + brief "decodes bytes as utf8 text" + $ desc "bytes:decode " + $ entry $ bindMatch "bytes:decode" $ \case + [ OpaqueVal box ] -> do + + let lbs' = fromOpaque @LBS.ByteString box + <|> + (LBS.fromStrict <$> fromOpaque @BS.ByteString box) + + lbs <- maybe (throwIO (UnexpectedType "unknown / ByteString")) pure lbs' + + -- TODO: maybe-throw-on-invalid-encoding + let txt = decodeUtf8With ignore (LBS.toStrict lbs) + + pure $ mkStr txt + + _ -> throwIO (BadFormException @c nil) + + + brief "reads bytes from a file" + $ desc "bytes:file FILE" + $ entry $ bindMatch "bytes:file" $ \case + [ StringLike fn ] -> do + liftIO (LBS.readFile fn) >>= mkOpaque + + _ -> throwIO (BadFormException @c nil) + + brief "reads bytes from a STDIN" + $ desc "bytes:stdin" + $ entry $ bindMatch "bytes:stdin" $ \case + [] -> do + liftIO LBS.getContents >>= mkOpaque + + _ -> throwIO (BadFormException @c nil) + + brief "writes bytes to STDOUT" + $ desc "bytes:put " + $ entry $ bindMatch "bytes:put" $ nil_ $ \case + [isOpaqueOf @LBS.ByteString -> Just s ] -> do + liftIO $ LBS.putStr s + + [isOpaqueOf @ByteString -> Just s ] -> do + liftIO $ BS.putStr s + + _ -> throwIO (BadFormException @c nil) + + brief "writes bytes to FILE" + $ desc "bytes:write " + $ entry $ bindMatch "bytes:write" $ nil_ $ \case + [StringLike fn, isOpaqueOf @LBS.ByteString -> Just s ] -> do + liftIO $ LBS.writeFile fn s + + [StringLike fn, isOpaqueOf @ByteString -> Just s ] -> do + liftIO $ BS.writeFile fn s + + _ -> throwIO (BadFormException @c nil) + diff --git a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs index f87e4189..9067aefe 100644 --- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs +++ b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs @@ -4,15 +4,24 @@ {-# LANGUAGE PatternSynonyms #-} {-# Language ViewPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} module Data.Config.Suckless.Syntax ( Syntax(..) , Id(..) , Literal(..) + , Opaque(..) , HasContext , C(..) , Context(..) , IsContext(..) , IsLiteral(..) + , ByteStringSorts(..) + , mkOpaque + , isOpaqueOf + , fromOpaque + , fromOpaqueThrow + , isByteString + , SyntaxTypeError(..) , pattern SymbolVal , pattern ListVal , pattern LitIntVal @@ -22,25 +31,35 @@ module Data.Config.Suckless.Syntax , pattern StringLike , pattern StringLikeList , pattern Nil + , pattern OpaqueVal ) where import Data.Data +import Data.Dynamic import Data.Kind import Data.String import Data.Text (Text) import Data.Scientific import GHC.Generics (Generic(..)) import Data.Maybe --- import GHC.Generics( Fixity(..) ) --- import Data.Data as Data import Data.Aeson import Data.Aeson.Key import Data.Aeson.KeyMap qualified as Aeson import Data.Vector qualified as V import Data.Traversable (forM) import Data.Text qualified as Text +import Data.ByteString (ByteString) +import Data.ByteString.Lazy qualified as LBS import Data.Function +import Data.Functor +import Control.Applicative +import Control.Exception +import Type.Reflection +import Control.Monad.IO.Class +import System.IO.Unsafe (unsafePerformIO) +import Data.IORef +import Data.Word import Prettyprinter @@ -73,6 +92,8 @@ stringLike = \case stringLikeList :: [Syntax c] -> [String] stringLikeList syn = [ stringLike s | s <- syn ] & takeWhile isJust & catMaybes +data ByteStringSorts = ByteStringLazy LBS.ByteString | ByteStringStrict ByteString + pattern StringLike :: forall {c} . String -> Syntax c pattern StringLike e <- (stringLike -> Just e) @@ -84,10 +105,25 @@ pattern StringLikeList e <- (stringLikeList -> e) pattern Nil :: forall {c} . Syntax c pattern Nil <- ListVal [] - +pattern OpaqueVal :: forall {c} . Opaque -> Syntax c +pattern OpaqueVal box <- OpaqueValue box data family Context c :: Type +isOpaqueOf :: forall a c . (Typeable a, IsContext c) => Syntax c -> Maybe a +isOpaqueOf = \case + OpaqueValue box -> fromOpaque @a box + _ -> Nothing + +isByteString :: Syntax c -> Maybe ByteStringSorts +isByteString = \case + OpaqueValue box -> do + let lbs = fromOpaque @LBS.ByteString box <&> ByteStringLazy + let bs = fromOpaque @ByteString box <&> ByteStringStrict + lbs <|> bs + + _ -> Nothing + class IsContext c where noContext :: Context c @@ -106,11 +142,68 @@ newtype Id = deriving newtype (IsString,Pretty) deriving stock (Data,Generic,Show,Eq,Ord) +type ForOpaque a = (Typeable a, Eq a) + +data Opaque = forall a. ForOpaque a => + Opaque + { opaqueProxy :: !(Proxy a) + , opaqueId :: !Word64 + , opaqueRep :: !SomeTypeRep + , opaqueDyn :: !Dynamic + } + +opaqueIdIORef :: IORef Word64 +opaqueIdIORef = unsafePerformIO (newIORef 1) +{-# NOINLINE opaqueIdIORef #-} + +mkOpaque :: forall c a m . (MonadIO m, ForOpaque a) => a -> m (Syntax c) +mkOpaque x = do + n <- liftIO $ atomicModifyIORef opaqueIdIORef (\n -> (succ n,n)) + pure $ OpaqueValue $ Opaque (Proxy :: Proxy a) n (someTypeRep (Proxy :: Proxy a)) (toDyn x) + +data SyntaxTypeError = + UnexpectedType String + deriving stock (Show,Typeable) + +instance Exception SyntaxTypeError + +fromOpaque :: forall a. Typeable a => Opaque -> Maybe a +fromOpaque (Opaque{..}) = fromDynamic opaqueDyn + +fromOpaqueThrow :: forall a m . (MonadIO m, Typeable a) => String -> Opaque -> m a +fromOpaqueThrow s (Opaque{..}) = do + let o = fromDynamic @a opaqueDyn + liftIO $ maybe (throwIO (UnexpectedType s)) pure o + +instance Eq Opaque where + (Opaque p1 _ t1 d1) == (Opaque _ _ t2 d2) = + t1 == t2 && unpack p1 d1 == unpack p1 d2 + where + unpack :: forall a . (Typeable a) => Proxy a -> Dynamic -> Maybe a + unpack _ = fromDynamic @a + +-- Partial Data implementation for Opaque +instance Data Opaque where + gfoldl _ z (Opaque{..}) = z (Opaque{..}) + + -- Can not be unfolded + gunfold _ z _ = z (Opaque (Proxy :: Proxy ()) 0 (someTypeRep (Proxy :: Proxy ())) (toDyn ())) + + toConstr _ = opaqueConstr + dataTypeOf _ = opaqueDataType + +opaqueConstr :: Constr +opaqueConstr = mkConstr opaqueDataType "Opaque" [] Prefix + +opaqueDataType :: DataType +opaqueDataType = mkDataType "Opaque" [opaqueConstr] + + data Literal = LitStr Text | LitInt Integer | LitScientific Scientific - | LitBool Bool + | LitBool Bool deriving stock (Eq,Ord,Data,Generic,Show) instance IsLiteral Text where @@ -141,13 +234,14 @@ data Syntax c = List (Context c) [Syntax c] | Symbol (Context c) Id | Literal (Context c) Literal + | OpaqueValue Opaque deriving stock (Generic,Typeable) - instance Eq (Syntax c) where (==) (Literal _ a) (Literal _ b) = a == b (==) (Symbol _ a) (Symbol _ b) = a == b (==) (List _ a) (List _ b) = a == b + (==) (OpaqueValue a) (OpaqueValue b) = a == b (==) _ _ = False deriving instance (Data c, Data (Context c)) => Data (Syntax c) @@ -157,6 +251,7 @@ instance Pretty (Syntax c) where pretty (Symbol _ s) = pretty s pretty (List _ (x:xs)) = parens $ align $ sep ( fmap pretty (x:xs) ) pretty (List _ []) = parens mempty + pretty (OpaqueValue v) = "#opaque:" <> viaShow (opaqueRep v) <> ":" <> pretty (opaqueId v) instance Pretty Literal where pretty = \case @@ -175,6 +270,7 @@ instance ToJSON Literal where toJSON (LitBool b) = Bool b instance ToJSON (Syntax c) where + toJSON (OpaqueValue{}) = Null toJSON (Symbol _ (Id "#nil")) = Null toJSON (Symbol _ (Id s)) = String s toJSON (Literal _ l) = toJSON l diff --git a/test/RT/test-basic-policy-1.baseline b/test/RT/test-basic-policy-1.baseline new file mode 100644 index 00000000..55b01cd0 --- /dev/null +++ b/test/RT/test-basic-policy-1.baseline @@ -0,0 +1,33 @@ +;; test some basic policy + +(peer deny all) +(sender deny all) +(peer allow 5tZfGUoQ79EzFUvyyY5Wh1LzN2oaqhrn9kPnfk6ByHpf) +(peer allow yFSaUfb97ZRtQqzHWdERsR7KJvN8qyWX1M8rJcxnsiu) +(peer allow 5GnroAC8FXNRL8rcgJj6RTu9mt1AbuNd5MZVnDBcCKzb) +(sender allow 5GnroAC8FXNRL8rcgJj6RTu9mt1AbuNd5MZVnDBcCKzb) + +sender yFSaUfb97ZRtQqzHWdERsR7KJvN8qyWX1M8rJcxnsiu allowed #f +sender 5GnroAC8FXNRL8rcgJj6RTu9mt1AbuNd5MZVnDBcCKzb allowed #t +peer 9mzDMTUouwoSkxuQWGwCnpP5TWR2DGKLobs2edjM5fDk allowed #f + +;; test empty policy + +(peer deny all) +(sender deny all) + +peer yFSaUfb97ZRtQqzHWdERsR7KJvN8qyWX1M8rJcxnsiu allowed #f +peer 5GnroAC8FXNRL8rcgJj6RTu9mt1AbuNd5MZVnDBcCKzb allowed #f +sender yFSaUfb97ZRtQqzHWdERsR7KJvN8qyWX1M8rJcxnsiu allowed #f +sender 5GnroAC8FXNRL8rcgJj6RTu9mt1AbuNd5MZVnDBcCKzb allowed #f + +;; test malformed policy + +(peer deny all) +(sender deny all) + +peer yFSaUfb97ZRtQqzHWdERsR7KJvN8qyWX1M8rJcxnsiu allowed #f +peer 5GnroAC8FXNRL8rcgJj6RTu9mt1AbuNd5MZVnDBcCKzb allowed #f +sender yFSaUfb97ZRtQqzHWdERsR7KJvN8qyWX1M8rJcxnsiu allowed #f +sender 5GnroAC8FXNRL8rcgJj6RTu9mt1AbuNd5MZVnDBcCKzb allowed #f + diff --git a/test/RT/test-basic-policy-1.rt b/test/RT/test-basic-policy-1.rt new file mode 100644 index 00000000..358e2585 --- /dev/null +++ b/test/RT/test-basic-policy-1.rt @@ -0,0 +1,86 @@ +(define || space) + +[define po1 [hbs2:mailbox:policy:basic:read:syntax [quot [ + (peer deny all) + (sender deny all) + (peer allow 5tZfGUoQ79EzFUvyyY5Wh1LzN2oaqhrn9kPnfk6ByHpf) + (peer allow yFSaUfb97ZRtQqzHWdERsR7KJvN8qyWX1M8rJcxnsiu) + (peer allow 5GnroAC8FXNRL8rcgJj6RTu9mt1AbuNd5MZVnDBcCKzb) + (sender allow 5GnroAC8FXNRL8rcgJj6RTu9mt1AbuNd5MZVnDBcCKzb) +]]]] + +; [hbs2:mailbox:policy:basic:dump po1] + +(define s1 yFSaUfb97ZRtQqzHWdERsR7KJvN8qyWX1M8rJcxnsiu) +(define s2 5GnroAC8FXNRL8rcgJj6RTu9mt1AbuNd5MZVnDBcCKzb) +(define s3 9mzDMTUouwoSkxuQWGwCnpP5TWR2DGKLobs2edjM5fDk) + + +(define accept:sender hbs2:mailbox:policy:basic:accept:sender) +(define accept:peer hbs2:mailbox:policy:basic:accept:peer) + +;; some policy + +println ";; test some basic policy" + +println + +hbs2:mailbox:policy:basic:dump po1 + +println + +println sender || s1 || allowed || [accept:sender s1 po1] +println sender || s2 || allowed || [accept:sender s2 po1] + +println peer || s3 || allowed || [accept:peer s3 po1] + +println + +;;; empty policy + +println ";; test empty policy" + +println + +[define po0 [hbs2:mailbox:policy:basic:read:syntax [quot []]]] + +hbs2:mailbox:policy:basic:dump po0 + +println + + +println peer || s1 || allowed || [accept:peer s1 po0] +println peer || s2 || allowed || [accept:peer s2 po0] + +println sender || s1 || allowed || [accept:sender s1 po0] +println sender || s2 || allowed || [accept:sender s2 po0] + + +define shitty-policy [hbs2:mailbox:policy:basic:read:syntax [quot [ +[shit 1] +[shit 2] +[shit 3] +bullshit +]]] + +;; malformed policy + +println + +println ";; test malformed policy" + +println + +hbs2:mailbox:policy:basic:dump shitty-policy + +println + +println peer || s1 || allowed || [accept:peer s1 shitty-policy] +println peer || s2 || allowed || [accept:peer s2 shitty-policy] + +println sender || s1 || allowed || [accept:sender s1 shitty-policy] +println sender || s2 || allowed || [accept:sender s2 shitty-policy] + + +; print :fuck +