storage w. AnyProbe

.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))
     )
 )

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 $@
 

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

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{Протокол <<Mailbox>>}
+
+\begin{document}
+
+\maketitle
+
+\section{О документе}
+
+Документ рассматривает протокол доставки данных <<Mailbox>> по паттерну $*
+\rightarrow 1$ <<email>> в P2P окружении, как подпротокола  для hbs2-peer.
+
+Протокол предполагается к использованию в ситуациях, когда между
+\term{actor}{акторами} нет общего авторизованного канала связи (в смысле
+hbs2-peer).
+
+Протокол не подразумевает нахождения акторов постоянно онлайн.
+
+Протокол не подразумевает использования механизмов вроде DNS, сертификатов PKCS
+и Authority, или каких-либо (скомпрометированных) централизованных сервисов.
+
+Протокол не подразумевает постоянной связности сети.
+
+Для адресации используются публичные ключи подписи.
+
+Для E2E шифрования используется механизм групповых ключей.
+
+Для упаковки и распространения данных используются примитивы hbs2-peer:
+\term{block}{блоки}, \term{merkle}{(шифрованные) деревья Меркла} с метаданными,
+и протоколы для работы с ними.
+
+Отличие от протоколов IMAP,SMTP,POP3 в том, что это другой протокол для другого
+окружения и исходящий из других предпосылок.
+
+Теоретически, в качестве несложного упражнения, можно поднять сервер IMAP как
+локальный фронтенд для hbs2-peer и тогда это будет IMAP-via-P2P.
+
+\section{Предпосылки}
+
+В текущей реализации HBS2 существуют следующие релевантные виды каналов
+(протоколов,\term{ref}{ссылок}):
+
+\paragraph{RefLog:}
+
+Обеспечивает коммуникацию по паттерну   $1 \rightarrow *$, то есть один -- ко
+всем, канал распространяет сообщения одного автора. Пруфом записи является
+подпись \term{ksign}{ключом подписи} автора. \term{peer}{Пиры} должны
+подписаться на канал для его распространения, распространять канал (ссылку)
+может любой любой подписанный на него \term{peer}{пир}, так как валидность
+записей проверяется подписью автора. Канал является \term{GSET}{CRDT G-SET}
+записей.
+
+Метафорой рефлога может являться твиттер-аккаунт либо канал в телеграме, с одним
+писателем и множеством подписчиков.
+
+
+\paragraph{RefChan:}
+
+Обеспечивает коммуникацию по паттерну ${A} \rightarrow {R}$, то есть определяет
+множество \term{author}{авторов} $A$ и множество \term{reader}{читателей} $R$, и
+пруфом записи является подпись \term{author}{автора}, а
+\term{permission}{разрешением} на чтение --- опциональное шифрование сообщения
+\term{GK0}{групповым ключом}, куда входят читатели $R$, то есть $GK = \{ k_i
+\}_{i \in R}$, где каждый $k_i$ --- секретный ключ, зашифрованный публичным
+ключом $r_i$ из множества $R$.
+
+Кроме того, \term{refchan}{RefChan} определяет множество пиров ${P}$, которые
+могут отправлять сообщение в данный \term{refchan}{RefChan} и принимаются только
+такие сообщения.
+
+Данное ограничение необходимо для борьбы с атакой Сивиллы в случае, если \Peer{}
+игнорирует настройки ${A}$.
+
+Кроме того, у \term{refchan}{рефчана} есть владелец, который может менять
+настройки $A,R$, а блок настроек представляет собой \term{lww}{CRDT LWW регистр}
+со ссылкой на блок настроек, подписанный ключом владельца.
+
+Как видно, распространять сообщения из \term{refchan}{рефчана} могут только пиры
+$p_i \in P$
+
+То есть, распространять транзакции может кто угодно, т.к каждая транзакция
+подписана ключом \term{peer}{пира}, но вот при запросе состояния будут
+учитываться только ответы пиров $p_i \in P$.
+
+Метафорой \term{refchan}{рефчана} является модерируемый чат с ограниченным
+множеством участников и администраторами.
+
+Таким образом, при наличии этих протоколов, мы можем
+
+\begin{enumerate}
+
+\item посылать сообщения от одного автора всему миру, то есть тем пирам, которые
+  слушают (подписаны) на данный рефлог или
+
+\item осуществлять коммуникацию между ограниченными множествами пиров и
+  авторов/читателей.
+
+\end{enumerate}
+
+Общим является то, что бы получать обновления рефлога или рефчана, мы (как пир)
+должны быть на них \term{subscribed}{подписаны}, т.е мы должны знать, что такие
+\term{ref}{ссылки} существуют и явно на них подписаться.
+
+
+Возникает вопрос, как можно обеспечить коммуникацию между произвольными
+\term{actor}{акторами} Алиса и Боб, у которых нет общего канала.
+
+Куда писать Алисе, что бы её сообщение достигло Боба? Рефчана, куда бы входили
+бы и Алиса и Боб в общем случае еще не существует, канал связи отсутствует.
+
+Алиса может быть подписана на какую-то ссылку Боба, но Боб не подписан на каналы
+Алисы. Или наоборот.
+
+Предлагается ввести новый протокол, \term{mailbox}{Mailbox}, который будет
+обеспечивать коммуникацию по паттерну $ * \rightarrow 1 $, то есть кто угодно
+может отправлять сообщения в почтовый ящик получателя.
+
+Получатель проверяет почтовый ящик и забирает оттуда сообщения.
+
+При этом обеспечивается отправка и доставка в условиях, когда \term{peer}{пиры}
+получателя и отправителя  не находятся онлайн всё время.
+
+Данный протокол может быть полезен при установлении канала связи (например,
+создании общего рефчана), или просто оффлайн обмене сообщениями в условиях
+необязательного наличия каналов, например, при рассылке патчей и пулл/мерж
+реквестов в git или создании тикетов или для отсылки \textit{реакций}, в общем
+---  в любом случае, когда между акторами нет какого-то прямого канала.
+
+Важным является то, что получатель подписан только на свои, известные ему
+каналы, куда все (при выполнении определённых условий) могут отправлять
+сообщения.
+
+
+\section{Протокол}
+
+Протокол является подпротоколом \textit{hbs2-peer} и в отношении него верно всё,
+что верно для семейства этих протоколов --- авторизация и аутентификация пиров,
+черные и белые списки пиров, транспортное шифрование сообщений через ByPass и
+так далее.
+
+Идентификаторами являются публичные ключи подписи и шифрования.
+
+Для e2e шифрования используется тот же механизм групповых ключей.
+
+Передаваемыми единицами являются либо короткие сообщения
+\texttt{SmallEncryptedBlock} либо \term{merkle}{деревья Меркла} с шифрованием и
+метаданными.
+
+Протокол использует примитивы \textit{hbs2-core} и \textit{hbs2-peer}, как
+минимум:
+
+\begin{itemize}
+  \item[-] SignedBox
+  \item[-] SmallEncryptedBlock
+  \item[-] MerkleTree
+\end{itemize}
+
+Протокол определяет служебные сообщения, специфичные для него, однако обмен
+данными идёт через обычные протоколы (GetBlock,GetBlockSize).
+
+Короткие сообщения могут доставляться непосредственно через (сигнальные)
+сообщения протокола.
+
+\subsection{Участники}
+
+\paragraph{Пир} Узел hbs2, поддерживающий данный протокол
+
+\paragraph{Актор} также \term{dude}{Dude}.  Отправители и получатели сообщений.
+
+Требуется определить, что явлется идентификатором, или идентификаторами \Dude{}.
+
+\paragraph{Message} Сообщение.
+
+Определяется отправителем, получателем (получателями?), и содержимым.
+Видится,что сообщения могут быть двух классов: \textit{маленькое}, где всё
+сообщение вместе со служебной информацией помещается в один пакет и может быть
+доставлено непосредственно через коммуникационный протокол (GOSSIP), и
+\textit{большое}, когда \Peer{} поддерживающий данный протокол -- будет
+выкачивать все ссылки на части сообщения (большой текст, аттачменты и т.п.)
+
+\paragraph{Mailbox} Единица хранения и распространения сообщений.
+
+Mailbox бывают видов \term{Relay}{Relay} и \term{Accumulator}{Accumulator}.
+
+Разница между ними в том, что \Relay{} просто принимает и выкачивает сообщения,
+пришедшие по протоколу, и не пытается опрашивать соседей и объединять все
+известные сообщения дла \Dude{} в общее множество.
+
+Назначание \Relay{} --- временное хранение сообщений, пока их не заберёт один из
+\term{acc}{аккумуляторов}. \Mailbox{} \Relay{} занимает фиксированное, заранее
+определенное место на диске
+
+Поскольку мы в общем не знаем, забрали ли сообщение или нет, видится так, что
+\Relay{} организует ограниченную очередь сообщений, и при исчерпании лимита
+места, отведённого под почтовый ящик -- просто удаляет наиболее старые сообщения
+из очереди.
+
+Назначание \Acc{} -- хранить все сообщения для своего \Dude{}, т.е это его
+<<распределённый почтовый аккаунт>>.
+
+То есть, \Acc{} образуют \term{GSET}{CRDT G-SET} сообщений, и постепенно
+сходятся к одному значению (объединению всех сообщений всех \Acc{}).
+
+Очевидно, нужно предусмотреть или записи вида \textit{Tomb}, или иной способ
+удаления сообщений, например, через команду протокола.
+
+\Acc{} опрашивает всех соседей, получает ссылки на \term{merkle}{деревья~Меркла}
+сообщений, выкачивает сообщения и объединяет их в общее множество.
+
+\subsection{Примеры}
+
+\subsection*{Минимальная конфигурация}
+
+Два пира при условии наличия прямой сетевой доступности в обоих направлениях.
+
+\begin{figure}[h!]
+\centering
+\begin{tikzpicture}[ every label/.style={font=\scriptsize},
+                     every node/.style={font=\scriptsize},
+                     handle/.style={ draw=black
+                                   , circle
+                                   , inner sep=2pt
+                                   },
+                     box/.style={ draw=black
+                                , rounded corners,
+                                , anchor=base
+                                , font=\scriptsize
+                                , minimum height=1.5cm
+                                , text width=1.5cm
+                                , align=center
+                                },
+                   ]
+
+  \node[box,minimum height=2cm,label={below:{hbs2-peer}}] (dudeA) {{\underline{Dude~A}}\\ \Acc{}};
+  \node[ box
+       , minimum height=2cm
+       , label={below:{hbs2-peer}}
+       , right=2.5cm of dudeA
+       ] (dudeB) {{\underline{Dude~B}}\\ \Acc{}};
+
+  \draw[<->] (dudeA) -- (dudeB)
+              node[midway,above] {Mailbox}
+              node[midway,below] {GOSSIP};
+
+
+\end{tikzpicture}
+\caption{минимальная конфигурация}
+\end{figure}
+
+\pagebreak
+
+\begin{itemize}
+ \item[-] Обмен сообщениями возможен только при одновременном нахождении обоих
+   пиров онлайн и наличия между ними связи
+
+ \item[-] При потере узла Dude~A или Dude~B теряют все адресованные им сообщения
+\end{itemize}
+
+
+\subsection*{Примерно оптимальная конфигурация}
+
+\begin{figure}[h!]
+\centering
+\begin{tikzpicture}[ every label/.style={font=\scriptsize},
+                     every node/.style={font=\scriptsize},
+                     handle/.style={ draw=black
+                                   , circle
+                                   , inner sep=2pt
+                                   },
+                     box/.style={ draw=black
+                                , rounded corners,
+                                , anchor=base
+                                , font=\scriptsize
+                                , minimum height=1.5cm
+                                , text width=1.5cm
+                                , align=center
+                                },
+                   ]
+
+  \node[box,minimum height=2cm,label={below:{hbs2-peer}}] (dudeA) {{\underline{Dude~A}}\\ \Acc{}};
+
+  \node[ box
+       , minimum height=2cm
+       , label={below:{hbs2-peer}}
+       , right=1.5cm of dudeA
+       ] (relayA) {{\underline{Relay~1}}\\ \Relay{}};
+
+  \node[ box
+       , minimum height=2cm
+       , label={below:{hbs2-peer}}
+       , below=1.5cm of dudeA
+       ] (A1) {{\underline{A1}}\\ \Acc{}};
+
+  \node[ box
+       , minimum height=2cm
+       , label={below:{hbs2-peer}}
+       , right=1.5cm of relayA
+       ] (relayB) {{\underline{Relay~2}}\\ \Relay{}};
+
+  \node[ box
+       , minimum height=2cm
+       , label={below:{hbs2-peer}}
+       , right=1.5cm of relayB
+       ] (dudeB) {{\underline{Dude~B}}\\ \Acc{}};
+
+  \node[ box
+       , minimum height=2cm
+       , label={below:{hbs2-peer}}
+       , below=1.5cm of dudeB
+       ] (B1) {{\underline{B1}}\\ \Acc{}};
+
+  \node[ box, circle, draw, dashed
+       , minimum size=2.5cm
+       , minimum height=2.5cm
+       , yshift=-0.5cm
+       , right=2.75cm of A1
+       , label={below: protocol}
+       ] (gossip) {{\underline{Mailbox}}\\GOSSIP };
+
+
+  \draw[<->,dashed] (dudeA) -- (relayA);
+  \draw[<->,dashed] (dudeB) -- (relayB);
+  \draw[<->,dashed] (dudeA) -- (A1);
+  \draw[<->,dashed] (dudeB) -- (B1);
+
+  \draw[<->,dashed] (dudeA) -- (gossip);
+  \draw[<->,dashed] (dudeB) -- (gossip);
+  \draw[<->,dashed] (relayA) -- (gossip);
+  \draw[<->,dashed] (relayB) -- (gossip);
+  \draw[<->,dashed] (A1) -- (gossip);
+  \draw[<->,dashed] (B1) -- (gossip);
+
+\end{tikzpicture}
+\caption{Примерно оптимальная конфигурация}
+\end{figure}
+
+\begin{itemize}
+\item[-] Каждый Dude имеет некоторое количество Mailbox типа \Acc{} и \Relay{}.
+
+\item[-] Часть из них находится на пирах, которые большую часть времени
+  доступны.
+
+\item[-] Часть доступных пиров имеет между собой прямую связь по GOSSIP.
+
+\item[-] Не требуется полная связность сети между Dude~A и Dude~B, достаточно,
+  что бы была цепочка соединений, доступных хотя бы время от времени.
+
+\item[-] Сообщения Dude~A и Dude~B реплицированы между узлами типа \Acc{} (для
+  каждого Dude -- свои мейлбоксы, естественно) и сообщения будут утрачены
+    только в случае полной одновременной утраты всех узлов такого типа или если
+    на всех этих узлах будут удалены \term{mailbox}{мейлбоксы} для Dude~A или
+    Dude~B.
+\end{itemize}
+
+\pagebreak
+
+\section{Структуры данных}
+
+\subsection{Message}
+
+\begin{figure}[h!]
+\centering
+\begin{tikzpicture}[ every label/.style={font=\scriptsize},
+                     every node/.style={font=\scriptsize},
+                     handle/.style={ draw=black
+                                   , circle
+                                   , inner sep=2pt
+                                   },
+                     box/.style={ draw=black
+                                , rounded corners,
+                                , anchor=base
+                                , font=\scriptsize
+                                , minimum height=1.5cm
+                                , text width=1.5cm
+                                , align=center
+                                },
+                   ]
+
+  \node[ draw
+       , minimum height=2cm
+       , minimum width=12cm
+       % , label={[yshift=5mm]south:SignedBox}
+       ] (msg)  {};
+
+
+   \node[draw,below=5mm of msg.north west,anchor=north west,xshift=2mm
+       ] (sender) {$Sender$};
+
+  \node[above=1.5cm of sender.north west, anchor = south west, text width=1.8cm] (label1) {Публичный ключ отправителя};
+
+  \draw[->] (label1.south) -- ($(sender.north west)!(label1.south)!(sender.north east)$);
+
+  % \node[draw,below=5mm of msg.north west,anchor=north west,xshift=2mm
+  \node[draw,right=5mm of sender
+       ] (flags) {$\{F\}$};
+
+  \node[draw,right=1mm of flags
+       ] (rcpt) {$\{Recipients\}$};
+
+  \node[draw,right=1mm of rcpt
+       ] (gk) {$GK^*$};
+
+  \node[draw,right=1mm of gk
+       ] (ref) {$\{Ref\}$};
+
+  \node[draw,right=1mm of ref,minimum width=4cm
+       ] (payload) {$Payload$};
+
+
+  \node[above=1.5cm of payload.north west, anchor = south west, text width=2cm]
+     (labelP) {SmallEncryptedBlock};
+
+  \draw[->] (labelP.south) -- ($(payload.north west)!(labelP.south)!(payload.north east)$);
+
+  \node[ draw
+       , above=2mm of flags.north west, xshift=-2.5mm
+       , anchor=north west
+       , minimum width = 10cm
+       , minimum height = 1.1cm
+       , label={[yshift=-1mm]south:SignedBox}
+       ] (box) {};
+
+
+\end{tikzpicture}
+\caption{Структура сообщения}
+\end{figure}
+
+\paragraph{Sender:}  Публичный (адрес) ключ подписи отправителя
+
+\paragraph{F:} Флаги (опции) сообщения. Например, TTL. TBD.
+
+\paragraph{Recipients:} Публичные ключи подписи (адреса) получателей
+
+Так как \term{peer}{пиру} нужно знать, в какой \Mailbox{} положить сообщение
+
+
+\paragraph{GK:} (Опционально) групповой ключ шифрования, которым зашифровано
+сообщение
+
+\paragraph{Refs:} Ссылки на части сообщения, (зашифрованные)
+\term{merkle}{деревья} с метаданными
+
+\paragraph{Payload:} Непосредственное короткое сообщение
+
+
+\section{Сообщения протокола}
+
+\subsection{SEND}
+
+Пир~A \Dude~A посылает сообщение \Dude~B или списку \Dude{} через Пир~X.
+
+Если Пир~X не поддерживает протокол -- то сообщение не обрабатывается.
+
+Если Пир~X поддерживает протокол -- то сообщение пересылается соседям Пир~X.
+
+Если Пир~X имеет \Mailbox{} для одного из получателей (\Dude{}) --- то сообщение
+кладётся в \Mailbox{}.
+
+Если это \Acc{} -- то просто кладётся. Если задана квота на размер и размер
+\Mailbox{} превышен (переполнен), то сообщение может игнорироваться.
+
+Если это \Relay{} то кладётся, если квота размера не превышена. Если превышена,
+то удаляются наиболее старые сообщения, пока не освободится достаточно места на
+диске.
+
+Если не удалось, то сообщение удаляется.
+
+Если сообщение содержит хэш-ссылки (вложения), то они скачиваются в соответствии
+с политиками (размеры,etc).
+
+Каждая ссылка сообщения проверяется на целостность, скачивание продолжается,
+пока оно не станет целостным или до тех пор, пока (определяется политикой).
+
+Если пир \Dude~A не имеет блоков, на которые ссылается сообщениe --- то мы
+прекращаем скачивать зависимости. Возможно, такое сообщение стоит дропнуть.
+
+Авторизация: сообщение SEND подписано \Dude~A, отправителем сообщения.
+
+\subsection{CHECK-MAIL}
+
+Получатель (владелец \Mailbox{}) запрашивает хэш \term{merkle}{дерева Меркла} сообщений,
+содержащихся в \Mailbox{}.
+
+Авторизация: сообщение SEND подписано \Dude --- владельцем \Mailbox{}.
+
+\subsection{MAIL-STATUS}
+
+Ответ на сообщение \texttt{CHECK-MAIL}, содержит хэш ссылку
+\term{merkle}{дерева Меркла} сообщений, содержащихся в \Mailbox{}
+или признак отсутствия сообщений.
+
+Поведение. Получаем сообщения из дерева, пишем в результат только валидные.
+
+Если затесались невалидные -- то это повод для каких-то действий в отношении
+пира, который обслуживает \Mailbox{}.
+
+Авторизация: сообщение подписано \Dude --- владельцем  \Mailbox{}.
+
+\subsection{DELETE}
+
+Удалить сообщение для \Mailbox{}.
+
+Содержит признак рассылать по GOSSIP или нет, допустим, оно адресовано только
+одному конкретному узлу.
+
+Содержит предикат, какие сообщения удалять (все, для определенного отправителя,
+старше, чем X, больше, чем X, и т.п.). TBD.
+
+Полезно для освобождения ресурсов и экономии сетевого трафика.
+
+Опциональное.
+
+Авторизация: сообщение подписано \Dude --- владельцем  \Mailbox{}.
+
+\subsection{SET-POLICY}
+
+Устанавливает политики обработки сообщений и \Mailbox{}.
+
+Параметры: GOSSIP (да/нет)
+
+Данные: \term{term}{дерево Меркла} текстового файла с инструкциями.
+
+Авторизация: сообщение подписано \Dude --- владельцем  \Mailbox{}.
+
+Инструкции: TBD, расширяемо.
+
+Возможный примерный вид:
+
+\begin{verbatim}
+
+dudes drop *
+peers drop *
+
+dudes accept GmtNGbawvxqykjDaBiT3LsqP7xqDPHVTxqfBqoFQ6Mre
+
+dudes accept 3WtddmcE8zzgBAPR7Bu7mKMaVMTN423NNXSPUJp3Hx42
+
+dudes delete G5K9QvFaomXdP4Y9HcYEt3diS2cCWyU8nBd2eTzrcq1j
+
+dude set-pow-factor 94wrDGvcnSitP8a6rxLSTPBhXSwdGYrQqkuk2FcuiM3T 10
+
+peer set-pow-factor Gu5FxngYYwpRfCUS9DJBGyH3tvtjXFbcZ7CbxmJPWEGH 10
+
+peers accept yFSaUfb97ZRtQqzHWdERsR7KJvN8qyWX1M8rJcxnsiu
+
+peer cooldown * 120
+peer cooldown yFSaUfb97ZRtQqzHWdERsR7KJvN8qyWX1M8rJcxnsiu  60
+
+dude cooldown * 120
+dude cooldown G5K9QvFaomXdP4Y9HcYEt3diS2cCWyU8nBd2eTzrcq1j 300
+
+\end{verbatim}
+
+
+\section{Возможные атаки и противодействие им}
+
+\subsection{Спам}
+
+Массовые нежелательные рассылки.
+
+\paragraph{Тактика борьбы:}
+
+\begin{itemize}
+ \item[-] Отвергать сообщения с множеством реципиентов.
+ \item[-] Вводить cooldown периоды для пиров и \Dude{}.
+ \item[-] Вводить (общие) белые списки и принимать сообщения только от них.
+ \item[-] Сделать ненулевой стоимость попадания в белые списки.
+ \item[-] Ввести иструменты репутации и т.п.
+ \item[-] Ввести регулируемый PoW на сообщения.
+\end{itemize}
+
+\subsubsection{DoS}
+
+Атаки на работоспособность пира и сети в целом.
+
+\subsubsection{Посылка огромных данных}
+
+TBD
+
+\subsubsection{Посылка невалидных данных}
+
+TBD
+
+\subsubsection{Ссылки на отсутствующие данные}
+
+TBD
+
+\subsubsection{Анализ метаданных, построение графа взаимодействий}
+
+Поскольку \texttt{GOSSIP} проходит через пиров и имеет открытые метаданные,
+можно сохранять граф коммуникаций и запоминать публичные ключи.
+
+Что бы этому противодействовать -- можно только взаимодействовать с заведомо
+надёжными пирами через, возможно, отдельную сеть.
+
+К сожалению.
+
+Для по-настоящему анонимного и неотслеживаемого общения нужно использовать
+другие механизмы.
+
+\section{Примеры применения}
+
+\subsection{Issues/Pull requests}
+
+
+\begin{figure}[h!]
+\centering
+\begin{tikzpicture}[ every label/.style={font=\scriptsize},
+                     every node/.style={font=\scriptsize},
+                     handle/.style={ draw=black
+                                   , circle
+                                   , inner sep=2pt
+                                   },
+                     box/.style={ draw=black
+                                , rounded corners,
+                                , anchor=base
+                                , font=\scriptsize
+                                , minimum height=1.5cm
+                                , text width=1.5cm
+                                , align=center
+                                },
+                     db/.style={ cylinder
+                               , draw
+                               , fill=gray!10
+                               , minimum height=1cm
+                               , minimum width=1.5cm
+                               , shape border rotate=90
+                               , aspect=0.5
+                               }
+                   ]
+
+  \node[box] (hbs2-peer1) {hbs2-peer1};
+  \node[box,right=3cm of hbs2-peer1] (hbs2-peer2) {\underline{hbs2-peer2}\\Relay};
+  \node[box,below=3cm of hbs2-peer2]
+      (hbs2-peerN)
+      {\underline{hbs2-peerN}\\\Acc{}};
+
+  \draw[->] (hbs2-peer1) -- (hbs2-peer2)
+    node[below,midway] {MAILBOX:SEND}
+    node[above,midway] {PR~Message};
+
+  \draw[->] (hbs2-peer2) -- (hbs2-peerN)
+    node[left,midway] {MAILBOX:SEND}
+    node[left,midway,yshift=4mm] {PR~Message};
+
+  \node[box,right=2cm of hbs2-peerN] (process) {filter-process};
+
+  \node[box,right=2cm of process] (fixme) {fixme};
+
+  \node[db,right=1cm of fixme,anchor=west,yshift=-4mm] (db) {fixme-state};
+
+  \draw[->] (process.150) -- ($(hbs2-peerN.north east)!(process.150)!(hbs2-peerN.south east)$)
+      node[midway,above] {MAIL-CHECK};
+
+  \draw[->] (process.180) -- ($(hbs2-peerN.north east)!(process.180)!(hbs2-peerN.south east)$)
+      node[midway,above] {READ};
+
+  \draw[->] (process) -- (fixme)
+    node[above,midway] {import};
+
+  \draw[->]  (fixme.south) -- ($(fixme.south) - (0,+2cm)$) -| (hbs2-peerN.south)
+    node[below,near start] {refchan:export};
+
+  \draw[->] (fixme.east) -- (db.152);
+
+
+\end{tikzpicture}
+\end{figure}
+
+Пользователь формирует сообщение специального вида (plaintext/fixme) которое
+посылается по протоколу MAILBOX получателю -- владельцу мейлобокса, который
+указан в manifest проекта, как контакт для посылки подобных сообщений.
+
+На некоем хосте существует процесс, который время от времени проверяет
+\Mailbox{} и при обнаружении новых сообщений экспортирует их в fixme,
+который, в свою очередь, помещает их в RefChan делая доступными и видимыми
+для подписчиков этого рефчана.
+
+Обновления данного Issue/PR возможны, если в качестве fixme-key выбран некий
+уникальный идентификатор, который и будет указан в каждом сообщении.
+
+
+\end{document}
+
+

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)

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

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

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 ()
 

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
+<blank>
+message text...
+<EOF>
+
+;;
+
+supported fields:
+
+sender     <SIGIL-HASH>
+recipient  <SIGIL-HASH>
+
+    |]
+    $ 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)
+

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
+  entry $ bindMatch "hbs2:peer:storage:block:size" $ \case
-    [StringLike s] -> do
+    [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

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,27 +79,48 @@ 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
+;; creates from keyring, uses first encryption key if found
-      [ StringLike s ] -> pure (fmap snd . headMay, s)
-      [ StringLike p, StringLike s ] -> pure ( findKey p, s)
-      [ LitIntVal n, StringLike s ] -> pure ( L.lookup n, s)
 
-      _ -> 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))
+hbs2:sigil:create:from-keyring KEYRING-FILE N
-               `orDie` "bad keyring data"
 
-    let es = zip [0..]
+;; creates from keyring, uses encryption key wit prefix S if found
-                 [ p | KeyringEntry p _ _
-                     <- view peerKeyring cred
-                 ]
 
-    enc <- pure (fst args es)
+hbs2:sigil:create:from-keyring KEYRING-FILE S
-           `orDie` "key not found"
+
+   |]
+   $ entry $ bindMatch "hbs2:sigil:create:from-keyring" $ \syn -> do
+
+      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"
@@ -108,9 +128,8 @@ sigilEntries = do
       pure $ mkStr (show $ pretty $ AsBase58 sigil)
 
     where
-    findKey s xs = headMay [ k
+      findKey s xs = headMay [ e
-                           | e@(_,k) <- xs
+                             | e@(KeyringEntry k _ _) <- xs
                              , L.isPrefixOf s (show $ pretty (AsBase58 k))
                              ]
 
-

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)
+
+

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)
                       )
 

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)
 

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)
                   )
 

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

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

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,12 +205,15 @@ 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
+    replicateM_ 2 do
+      ContT $ withAsync do
         q <- withDashBoardEnv env $ asks _pipeline
         forever do
           liftIO (atomically $ readTQueue q) & liftIO . join
@@ -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
+    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
+      -- 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

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 :: (MonadIO m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> DBPipeM m ()
-updateForks lww = withState do
+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,20 +864,20 @@ 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
+    root <- lift (lift (getRootTree lww co)) >>= toMPlus
-    (trees, blobs) <- lift $ getTreeRecursive lww co
+    (trees, blobs) <- lift $ lift $ getTreeRecursive lww co
 
     -- lift $ addJob $ liftIO $ withDashBoardEnv env do
 
-    lift $ withState $ transactional do
+    -- lift $ withState do
-
+    lift do
       insert @RepoCommitTable $
         onConflictIgnore @RepoCommitTable (RepoLww lww, RepoCommit co)
 
@@ -876,7 +903,7 @@ updateRepoData lww co  = do
                      , 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
+  doneCommits <- listCommitsProcessed lww <&> HS.fromList
-    done <- checkCommitProcessed lww co
+
-    let skip = done && not ignoreCaches
+  commits <- listCommits lww <&> filter (not . flip HS.member doneCommits)
-    guard (not skip)
+  let chunks = chunksOf 100 commits
-    lift $ addJob $ withDashBoardEnv env (updateRepoData lww co)
+
+  for_ chunks $ \chunk -> do
+    -- addJob $ withDashBoardEnv env do
+      withState $  transactional do
+        for_ chunk $ \co -> do
+          updateRepoData lww co
+
+  unless (List.null chunks) do
+    withState $ transactional $ do updateForks lww
 
   -- FIXME: check-names-with-spaces
 

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
 

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"

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
+
+

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
+
+

hbs2-git-dashboard/hbs2-git-dashboard.cabal

@@ -114,6 +114,7 @@ library hbs2-git-dashboard-core
       , skylighting-lucid
       , stm
       , streaming
+      , split
       , temporary
       , text
       , time

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
+
+|]
+
+

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
+
+

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)
       ]

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()
 

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
+
+

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
 

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"

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
 

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

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
+

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)
+
+

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)
+

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
+

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
+
+

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)
+

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
+
+

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))
                      )

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)
+

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
@@ -39,6 +43,8 @@ data RPC2Context =
   , 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

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

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) -> do
-  (TPunct '\'' : rest) -> sexp rest
+    (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
 

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
+                 s@[StringLike d, ListVal (StringLikeList i) ] -> do
-                    pure ([i], [e], d)
+                    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)

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)
-
+                        | NotLambda (Syntax c)
-newtype TypeCheckError c = TypeCheckError (Syntax c)
+                        | TypeCheckError (Syntax c)
-
-instance Exception (TypeCheckError 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
-
+  show (NotLambda sy) = show $ "NotLambda" <+> pretty sy
-instance IsContext c => Show (TypeCheckError c) where
   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
+      ListVal (e' : args') -> do
-        pure (mkSym @c (Text.drop 1 s))
+        -- 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
+       >>= \case
-          Just (BindValue s) -> s
+          Just (BindValue s) -> pure s
-          _  -> nil
+          _  -> 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,13 +1004,39 @@ 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) )
+
+    let wrapWith e = \case
+          List c es -> List c (e : es)
+          other     -> other
+    let lwrap = \case
+          e@(SymbolVal x) -> wrapWith e
+          _ -> id
+
+    brief "parses string as toplevel and produces a form"
+     $ desc "parse:top:string SYMBOL STRING-LIKE"
+     $ entry $ bindMatch "parse:top:string" $ \case
 
         [SymbolVal w, LitStrVal s] -> do
-        pure $  parseTop s & either (const nil) (mkForm w . fmap fixContext)
+          pure $  doParseTop w id s
 
-      [LitStrVal s] -> do
+        [SymbolVal w, e@(SymbolVal r), LitStrVal s] -> do
-        pure $  parseTop s & either (const nil) (mkList . fmap fixContext)
+          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 <FILENAME>"
+     $ 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)
 
@@ -983,3 +1138,60 @@ internalEntries = do
       _ -> throwIO (BadFormException @c nil)
 
 
+    brief "decodes bytes as utf8 text"
+     $ desc "bytes:decode <BYTES>"
+     $ 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 <BYTES>"
+     $ 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 <FILE> <BYTES>"
+     $ 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)
+

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,6 +142,63 @@ 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
@@ -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

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
+

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
+