LICENSE to hbs2-storage-ncq3

This reverts commit 2ab1535802.

.envrc

@@ -1,3 +1,4 @@
+## wtf
 if [ -f .envrc.local ]; then
   source_env .envrc.local
 fi

.fixme-new/.gitignore

@@ -0,0 +1,2 @@
+state.db
+config.local

.fixme-new/config

@@ -0,0 +1,78 @@
+
+; fixme-files **/*.hs docs/devlog.md
+
+; no-debug
+; debug
+
+fixme-prefix     FIXME:
+fixme-prefix     TODO:
+fixme-prefix     PR:
+fixme-prefix     REVIEW:
+fixme-prefix     PATCH:
+
+fixme-attribs assigned workflow :class
+
+fixme-attribs class
+
+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 ui
+
+; fixme-value-set cat bug feat refactor
+
+fixme-value-set scope mvp-0 mvp-1 backlog
+
+fixme-files **/*.txt docs/devlog.md
+fixme-files **/*.hs
+fixme-exclude **/.**
+fixme-exclude dist-newstyle
+fixme-exclude miscellaneous
+
+fixme-file-comments "*.scm" ";"
+
+fixme-comments ";" "--"
+
+(define-template short
+  (quot
+    (simple
+         (trim 10  $fixme-key) " "
+
+         (if (~ FIXME $fixme-tag)
+          (then (fgd red (align 6  $fixme-tag))  )
+          (else (if (~ TODO $fixme-tag)
+                  (then (fgd green (align 6  $fixme-tag)))
+                  (else (align 6  $fixme-tag)) ) )
+          )
+
+
+         (align 10  ("[" $workflow "]"))  " "
+         (align 8  $class)  " "
+         (align 12 $assigned)  " "
+         (align 20 (trim 20 $committer-name)) " "
+         (trim 40  ($fixme-title)) " "
+         (nl))
+    )
+)
+
+(set-template default short)
+
+(define (ls) (report))
+
+(define (lss s) (report workflow ~ s))
+
+(define (done s) (modify s workflow :done))
+(define (wip s) (modify s workflow :wip))
+(define (test s) (modify s workflow :test))
+(define (new s) (modify s workflow :new))
+(define (backlog s) (modify s workflow :backlog))
+(define (ready s) (modify s workflow :ready))
+(define (merged s) (modify s workflow :merged))
+(define (assign s who) (modify s :assigned who))
+
+;; refchan settings
+refchan 3WtddmcE8zzgBAPR7Bu7mKMaVMTN423NNXSPUJp3Hx42
+source ./refchan.local
+
+

.fixme/config

@@ -20,8 +20,7 @@ fixme-files docs/notes/**/*.txt
 
 fixme-files-ignore .direnv/** dist-newstyle/**
 
-fixme-id-show-len 10
-
+fixme-id-show-len 12
 
 fixme-attribs assigned workflow resolution cat scope
 

.fixme/log

@@ -1,2 +1,3 @@
 
 (fixme-set "workflow" "done" "RsTry2C5Gk")
+(fixme-set "workflow" "done" "DYfcfsNCrU")

.gitattributes

@@ -0,0 +1,2 @@
+.fixme-new/log merge=fixme-log-merge
+.fixme-new/fixme.log merge=fixme-log-merge

.gitignore

@@ -1,12 +1,7 @@
-dist-newstyle
+.fixme-new/refchan.local
+dist-newstyle/
+bin/
 .direnv/
-.fixme/state.db
-result
-# VS Code
-settings.json
+.hbs2-git3/
 
-cabal.project.local
-
-*.key
-
-.backup/
+temp/

.hbs2-git/manifest

@@ -1,5 +0,0 @@
-title: "hbs2 project repo"
-author: "Dmitry Zuikov"
-public: yes
-
-Project description TBD

CHANGELOG.md

@@ -1,3 +1,4 @@
 
-# 0.24.1.1  2024-04-02
-  - Don't do HTTP redirect on /ref/XXXXXXXXXX requests; show content directly
+# 0.24.1.2  2024-04-27
+  - Bump scotty version
+

LICENSE

@@ -0,0 +1,31 @@
+Copyright (c) 2023, 2024
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of  nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+

Makefile

@@ -5,22 +5,52 @@ SHELL := bash
 MAKEFLAGS += --warn-undefined-variables
 MAKEFLAGS += --no-builtin-rules
 
-GHC_VERSION := 9.4.8
+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 := \
+	bf6                \
   hbs2               \
   hbs2-peer          \
   hbs2-keyman        \
-	hbs2-fixer         \
-	hbs2-git-subscribe \
-  git-remote-hbs2    \
-  git-hbs2           \
+  hbs2-cli           \
+  hbs2-sync          \
+  fixme-new          \
+	hbs2-git3 \
+	git-remote-hbs23 \
+	ncq3 \
+	hbs2-obsolete \
+	tcq \
+	test-ncq \
+
+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 $@
 
@@ -32,11 +62,15 @@ symlinks: $(BIN_DIR)
 >		path=`find dist-newstyle -type f -name $$bin -path "*$(GHC_VERSION)*" | head -n 1`; \
 >		if [ -n "$$path" ]; then \
 >			echo "Creating symlink for $$bin"; \
->			ln -sf $$PWD/$$path $(BIN_DIR)/$$bin; \
+>			ln -sfn $$PWD/$$path $(BIN_DIR)/$$bin; \
+#>			cp $$PWD/$$path $(BIN_DIR)/$$bin; \
 >		else \
 >			echo "Binary $$bin for GHC $(GHC_VERSION) not found"; \
 >		fi; \
 >	done
+> ln -sfn ../hbs2-git3/bf6/git-hbs2 bin/git-hbs2
+> ln -sfn ../hbs2-git3/bf6/hbs2-git bin/hbs2-git
+> ln -sfn ../bf6/hbs2 bin/hbs2
 
 
 .PHONY: build
@@ -52,8 +86,8 @@ test-raft:
 > nix develop -c ghcid -c 'cabal repl' raft-algo -T RaftAlgo.Proto.devTest
 
 README.md:
-	pandoc README.md -t gfm -s -o README1.md --table-of-contents
-	@mv README1.md README.md
-	@echo Remove old TOC before publishing!
+>	pandoc README.md -t gfm -s -o README1.md --table-of-contents
+>	@mv README1.md README.md
+>	@echo Remove old TOC before publishing!
 
 

README.md

@@ -142,6 +142,8 @@ We’re using it for our non-public projects.
 
 ## How to install
 
+### nix flakes
+
 Assuming you know what the Nix and Nix flakes are ( See
 [nixos.org](https://nixos.org) if you don’t )
 
@@ -158,6 +160,54 @@ Alternative option:
     --substituters http://nix.hbs2.net:6000 \
     --trusted-public-keys git.hbs2.net-1:HYIYU3xWetj0NasmHrxsWQTVzQUjawOE8ejZAW2xUS4=
 
+### Home Manager module
+
+The following snippet of code tries to show how to bring the HBS2 flake
+from the flake input and use its packages with Home Manager.
+
+Don’t forget to replace exampleName with your username!
+
+```nix
+# flake.nix
+
+{
+  inputs = {
+    nixpkgs.url = "github:NixOS/nixpkgs/nixos-unstable";
+
+    home-manager = {
+      url = "github:nix-community/home-manager";
+      inputs.nixpkgs.follows = "nixpkgs";
+    };
+
+    hbs2.url = "git+https://git.hbs2.net/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP";
+  };
+
+  outputs = {nixpkgs, home-manager, hbs2, ...}: {
+    homeConfigurations."exampleName" =
+    let system = "x86_64-linux"; # use your system here
+    in home-manager.lib.homeManagerConfiguration {
+      pkgs = nixpkgs.legacyPackages.${system};
+
+      modules = [
+        hbs2.homeManagerModules.${system}.default
+        {
+          services.hbs2 = {
+            enable = true;
+            git-dashboard.enable = true; # optional
+          };
+        }
+        # ...
+      ];
+    };
+  };
+}
+```
+
+Option `services.hbs2.enable` will add all hbs2 binaries into your environment and
+create `hbs2-peer` user service to run it automatically at the background.
+
+Option `services.hbs2.git-dashboard.enable` will create `hbs2-git-dashboard` user service.
+
 ## How to generate peer’s key?
 
     hbs2 keyring-new > new-peer-key.key

bf6/hbs2

@@ -0,0 +1,206 @@
+#! /usr/bin/env -S hbs2-cli file
+
+; # println *args
+
+; # (println (grep (sym "-g") *args))
+
+(define (--help)
+  (begin
+    (println [concat
+
+"hbs2-cli wrapper"           chr:lf
+"supported commands list:"   chr:lf
+"  "
+
+             ])
+  )
+)
+
+(match *args
+
+  ( (list? [sym? store] ...)
+    (begin
+      (local optdef
+        `( [-g          1 GROUPKEY]
+           [--group-key 1 GROUPKEY] ))
+
+      (local split (cli:split optdef ...))
+      (local opts (nth 0 split))
+      (local args (nth 1 split))
+
+      (local gk (@? GROUPKEY opts))
+      (local fname (head args))
+
+      (local kwa `[ ,(if gk [list :gk gk] '() ) ])
+
+      ; (display kwa)
+
+      (println
+        (if fname
+          (hbs2:tree:metadata:file kwa fname)
+          (hbs2:tree:metadata:stdin kwa)))
+    )
+  )
+
+  ( (list? [sym? hash] ...)
+    (begin
+      (local what (if (eq? (type ...) :list) ... '()))
+      (display (eval `(hbs2:hash ,@what)))
+    )
+  )
+
+  ( (list? [sym? has] hash)
+    (begin
+      (local s (hbs2:peer:storage:block:size hash))
+      (cond
+        ( (eq? :no-block s) (die))
+        ( _ (print s))
+      ))
+  )
+
+  ( (list? [sym? cat] ...)
+
+      (begin
+
+        (local optdef `( [-H           0 HASHES]
+                         [--raw        0 RAW]
+                         [--metadata   0 META]
+                         [--m          0 META]
+                       ))
+
+        (local parsed (cli:split optdef ...))
+        (local opts (nth 0 parsed))
+        (local hash (head (nth 1 parsed)))
+
+        (if (@? HASHES opts)
+          (begin
+            (iterate [fn x . println x] [tail [hbs2:tree:scan:deep hash]])
+            (quit)
+        ))
+
+
+        (if (@? RAW    opts)
+          (begin
+            (bytes:put (hbs2:peer:storage:block:get hash))
+            (quit)
+          )
+        )
+
+        (if (@? META opts)
+          (begin
+            (display (hbs2:tree:metadata:get hash))
+            (quit)
+          )
+        )
+
+        (hbs2:tree:read:stdout hash)
+
+      )
+  )
+
+  ( (list? [sym? del] ...)
+
+      (begin
+
+        (local optdef `( [-y       0 YES]
+                         [-r       0 REC]
+                       ))
+
+        (local parsed (cli:split optdef ...))
+        (local opts (nth 0 parsed))
+        (local hash (head (nth 1 parsed)))
+
+        (local hashes
+          (cond
+            ( (@? REC opts)  (hbs2:tree:scan:deep hash) )
+            ( _              (hbs2:tree:scan hash)  )
+          )
+        )
+
+        (define (ask ha)
+            (if (@? YES opts) true
+            (begin
+              (print "deleting " ha " ")
+              (print "sure [y/n]? ") (flush:stdout)
+              (local answ (str:getchar:stdin))
+              (newline)
+              (eq? (upper answ) "Y")
+            ))
+        )
+
+        (cond
+          ( (and (@? YES opts) (@? REC opts)) (hbs2:tree:delete hash))
+          ( _
+            (for (reverse hashes)
+              [fn ha .
+                  [begin
+                    (local y (or (@? YES opts) (ask ha)))
+                    (if y
+                      (begin
+                        (hbs2:peer:storage:block:del ha)
+                     ))
+                  ]])
+          )
+        )
+
+
+      )
+
+  )
+
+  ( (list? [sym? keyring] [sym? new] ...)
+      (begin
+
+        (local optdef `( [-n       1 NUM]
+                         [--number 1 NUM]
+                       ))
+
+        (local opts (nth 0 (cli:split optdef ...)))
+        ;  (println opts)
+        (print (hbs2:keyring:new (@? NUM opts)))
+      )
+  )
+
+  ( (list? [sym? reflog] [sym? get] hash)
+    (display (hbs2:reflog:get hash))
+  )
+
+  ( (list? [sym? reflog] [sym? fetch] hash)
+    (hbs2:reflog:fetch hash)
+  )
+
+  ( (list? [sym? metadata] [sym? dump] hash)
+    (display (hbs2:tree:metadata:get hash))
+  )
+
+  ( (list? [sym? deps] hash)
+    (iterate println (hbs2:tree:scan:deep hash) )
+  )
+
+  ( (list? [sym? fsck] [sym? -h])
+    (begin
+      (println "usage: hbs2 fsck <PATH>")
+      (println "default for <PATH> is hbs2-peer storage path")
+    )
+  )
+
+  ( (list? [sym? fsck] ...)
+    (begin
+      (local sto1 (if (eq? (type ...) :list) (car ...) '()))
+      (if sto1
+        (run:proc:attached tcq ncq:fsck (concat sto1 :/ :0))
+        (begin
+          (local answ (fallback #f '(call:proc hbs2-peer poke)))
+          (unless answ (die "hbs2-peer seems down, but you may pass storage directory manually"))
+          (local sto (lookup:uw storage: answ))
+          (println (ansi :red _ "check") space sto)
+          (run:proc:attached tcq ncq:fsck (concat sto :/ :0))
+        )
+      )
+    )
+  )
+
+  ( _  (--help) )
+)
+
+; vim: filetype=scheme syntax=scheme

bf6/ncq-migrate.ss

@@ -0,0 +1,75 @@
+
+(define STORAGE (path:join (env HOME) .local/share/hbs2 ))
+(define REFS    (path:join STORAGE  refs)  )
+(define BLOCKS  (path:join STORAGE  blocks)  )
+(define NEW     (path:join (env HOME) tmp/ncq0))
+
+
+(define refs   (glob REFS '[*/**]  ))
+(define blocks (glob BLOCKS '[*/**]  ))
+
+(define (readref x)
+  (begin
+    (local ref    (concat (reverse (take 2 (reverse (split :/ x))))))
+    (local refval (str:file x))
+    `(,(sym ref) ,(sym refval))))
+
+(define (readhash x)
+  (sym (concat (reverse (take 2 (reverse (split :/ x))))))
+)
+
+(local zu (map readref refs))
+
+; (println zu)
+
+(println STORAGE)
+(println NEW)
+
+; debug
+(define ncq (ncq:open NEW))
+
+(define (writeref x)
+  (match x
+    ( (list? a b )
+      (begin
+        (ncq:set:ref ncq a b)
+        (println ref space a space b)
+      )
+    )
+    (_ '())
+ ))
+
+(define (import-refs) (for zu writeref))
+
+(define (import-blocks)
+  (begin
+    ; (local (write x) (ncq:put ncq (bytes:file x)))
+    (for blocks (fn x .
+      (begin
+        (local h0 (sym (readhash x)))
+        (local here  (ncq:has ncq h0))
+        (if (not here)
+          (begin
+            (local ha (sym (ncq:put ncq (bytes:strict:file x))))
+            (local s  (coalesce "" (ncq:has ncq ha)))
+            (local ok (if (eq? ha h0) (ansi :green _ ok) (ansi :red _ fail)))
+            (println block space ok space (align -6 (str s)) space ha space h0 space )
+            ; (println block space ok space space ha space h0 space )
+            (if (not (eq? ha h0)) (die "*** block import error:" ha space h0)))
+
+          (println "block" space (ansi :yellow _ "skip") space h0)
+        )
+    )))
+  )
+)
+
+(import-blocks)
+(import-refs)
+
+(debug)
+
+(ncq:fossilize ncq)
+
+(println done)
+
+

cabal.project

@@ -1,9 +1,20 @@
 packages: **/*.cabal
   examples/*/*.cabal
+  **/*/*.cabal
 
 allow-newer: all
 
+constraints:
+    pandoc >=3.1.11
+  , suckless-conf >= 0.1.2.7
+  , http-client >=0.7.16 && <0.8
+  , typed-process >= 0.2.13.0
+
+
+debug-info: True
 -- executable-static: True
 -- profiling: True
--- library-profiling: False
+--library-profiling: False
+debug-info: True
+
 

docs/devlog.md

@@ -1,3 +1,7 @@
+## 2024-12-02
+
+Пробуем новую структуру репозитория
+
 ## 2024-02-24
 
 wtf?

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-git-doc-0.24.1.tex

@@ -668,8 +668,8 @@ Cloning into '8vFu9S79ysdWag4wek53YWXbC5nCRLF7arGp6181G4js'...
 git hbs2 export --encrypted ./gk-new.key  C6tTuapmG7sE8QktQo4q4tBr8kNWKvBruNb36HYThpuy
 \end{verbatim}
 
-Для обновления манифеста --- редактировать файл \texttt{.hbs2-git/manifest} и сделать
-git commit/push либо же вызвать \texttt{git hbs2 export <LWWREF>}
+Для обновления манифеста --- редактировать файл \texttt{.hbs2-git/manifest}
+ и вызвать \texttt{git hbs2 manifest update <LWWREF>}
 
 \subsubsection{Смотреть групповой ключ}
 

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

docs/todo/download-exponential-backoff.txt

@@ -0,0 +1,8 @@
+TODO: asap-exponential-backoff-on-download
+  Увеличивать таймаут между запросами блока с
+  какой-то степенью; достаточно пологой
+
+TODO: download-drop-cli-command
+  Сделать команду hbs2-peer download drop
+  которая удалит все активные скачивания из очереди
+

docs/todo/fixme-new-web.txt

@@ -0,0 +1,30 @@
+TODO: fixme-refchan-to-manifest
+  добавить настройку рефчана для fixme в манифест проекта
+
+TODO: fixme-refchan-allow
+  добавить настройку для разрешения fixme для проекта.
+  только если разрешено --- пир подписывается на этот рефчан
+  и тянет из него issues
+
+TODO: fixme-init
+  инициализация fixme в каталоге репозитория.
+  проконтроллировать, что нормально работает с bare
+  репо
+
+TODO: fixme-refchan-import
+  встроить обновление стейта fixme в
+  конвейры hbs2-git-dashboard
+  (видимо, отдельным конвейром)
+
+
+FIXME: poll-fixme-refchans
+  сейчас новые рефчаны с fixme будут подтянуты
+  только при перезапуске. надо встроить явный
+  poll
+
+
+FIXME: commit-and-blob-catch-inconsistency
+ похоже, возникают ситуации, когда fixme-new захватывает
+ blob и commit некорректно (из разных коммитов?), и
+ hbs2-git-dashboard, бывает, не может найти blob в индексе.
+

docs/todo/hbs2-git-dashboard.txt

@@ -0,0 +1,34 @@
+FIXME: poll-fixme-refchans
+  поллить рефчаны fixme и обновлять
+  в случае изменений.
+
+  Сейчас не обновляются
+
+FIXME: commit-cache-inconsistency
+
+  Встретилась ситуация, когда commit помечен, как processed, но не все блобы
+  из него попали в кэш.
+
+  Похожие ситуации возникают и в hbs2-git.
+
+  Похоже, надо как-то инвертировать подход: когда искомые данные
+  встречаются в кэше --- отдаём из него, а когда нет --- ищем
+  в источнике (рефчане, дереве, репозитории).
+
+  Значит, в этих источниках должен быть некий индекс.
+
+  В git он есть.
+
+  В hbs2-git он вроде бы тоже есть.
+
+  Возможно, это будет незначительно медленнее при выдаче,
+  но сильно быстрее при индексации и система будет, типа,
+  самовосстанавливающаяся.
+
+  Возможно, это приведёт к тому, что все схемы выродятся
+  в таблицу "object", для ускорения доступа к которой
+  будут создаваться индексные таблицы (aka materialized view)
+  на её же основе только средствами sqlite.
+
+
+

docs/todo/hbs2-peer-queues.txt

@@ -0,0 +1,29 @@
+TODO: hbs2-peer-queues
+  $workflow: backlog
+
+  Сделать механизм очередей ( циклических FIFO буферов )
+  с управлением ( put/get ) по RPC
+
+  hbs2-peer постоянно в памяти;
+
+  Тогда мы решаем проблемы блокировок в sqlite:
+
+  Процесс продюсер -- пишет в очередь через hbs2-peer ( на диск )
+
+  Процесс консьюмер -- читает оттуда и обновляет БД, когда к этому
+  готов.
+
+  Таким образом, мы избегаем проблем с блокировками и
+  получаем понятный асинхронный механизм взаимодействия
+  между разными программами из hbs2.
+
+  Технически их можно сделать на основе компактов, в каждый
+  compact пишутся сообщения в формате (n, bytestring), после
+  чтения консьюмером -- сообщения удаляются.
+
+  По превышению файлом компакта некоего размера --
+  производим компактизацию, т.е начинаем писать в новый
+  файл, а старый удаляем, как только в нём не останется
+  ничего для чтения... Ну или как-то так.
+
+

docs/todo/hbs2-peer.txt

@@ -0,0 +1,39 @@
+TODO: ASAP-bloom-filter-of-blocks
+
+  Каждый пир поддерживает фильтр Блума для блоков и раздаёт этот фильтр по
+  протоколу.
+
+  Протокол подразумевает как отдачу всего фильтра целиком ( тут подходит
+  держать его в LWWRef)
+
+  Так и просто запросы к нему.
+
+  Запрос должен пролезать в UDP, таким образом, выглядит так, что это
+  список чисел с номерами бит, т.е в худшем случае (8 байт на число)
+  один запрос это проверка 128 блоков за раз. Поскольку CBOR у нас
+  кодирует числа с переменной длиной, можно ожидать, что в среднем
+  будет получше.
+
+  Это ускорит, возможно, на порядок поиск блоков, который тем хуже,
+  чем больше в системе пиров.
+
+  Открытые вопросы:
+
+  - Параметры фильтра Блума? Зашитые в систему, или зависящие от
+    пира (и тогда мы пересчитываем их)
+
+  - Надо ли качать фильтры целиком (кажется, что нет, но можно
+    запоминать/обновлять для каждого пира, и время от времени
+    чистить)
+
+  - Если параметры фильтра могут меняться для пира, как
+    согласовывать хэш функции? Если их зашивать и менять только
+    коэффициенты, то не слишком ли плохие будут хэш функции?
+
+  - Какие атаки может вызвать?
+
+  - Как эффективно хранить?
+
+
+
+

docs/todo/hbs2-sync.txt

@@ -0,0 +1,37 @@
+FIXME: race-on-large-files
+  добавляем большой файл ( ~4GB )
+  делаем hbs2-sync run на хосте A
+  делаем hbs2-sync run на хосте B
+  результат: файл удалён (tomb transaction)
+  вероятно, гонка по какой-то причине.
+
+  кажется, это backup-mode гадит
+
+TODO: hbs2-sync-recovery
+  сделать команды для получения всех
+  меркл-деревьев (игнорировать tomb-ы)
+
+  сделать команду для постинга транзакции с
+  новым таймстемпом (восстановить файл из tomb-а не копируя его)
+
+
+TODO: hbs2-sync-group-key-policy
+  сейчас на каждый файл генерируется новый групповой
+  ключ.
+
+  это хорошо, но если добавить большой файл
+  удалить большой файл
+  добавить большой файл обратно --- получится
+  адовое дублирование данных.
+
+  Возможное решение --- держать групповой ключ в кэше,
+  и устраивать его ротацию время от времени.
+
+
+TODO: hbs2-sync-whole-state
+  сейчас будет выкачан весь рефчан, включая удалённые данные (tombs)
+  там, где они не нужны.
+
+  это плохо для файлопомойки.
+
+  нужно найти решения для проблемы

docs/todo/static-binaries.txt

@@ -0,0 +1,7 @@
+PR: Initial support for static builds using nix
+  Still work in progress.
+  Suddenly, I didn't manage to make flake that is able to build
+  both static and dynamic binaries.
+
+  To run static builds use `nix build .#static` command at the project's root
+  commit: be86429c4b806fe20069e8efbf921c20b9e17ee3

examples/dns-example-1/dns.ss

@@ -0,0 +1,92 @@
+
+;; all key ids are PUBLIC
+
+(define hosts
+   ;; host-id sign-key encrypt-key
+  `[
+     (minime  4Z1ebkksoiZ9j4vZE9jnghxPDmc1ihXdNC6cX39phkLD
+              9Fp8Y5c9Fp612sjby3bL8P3SnUjjK2bz4F38nmVASpzb)
+
+     (expert  CxJaFMBykhTdUiXxgdWF2pjxV5cWtw3yjDozNniUYRRC
+              Hg6XD19KGQrVjMYrCNeuaGfhTn7BCCUGR8c3brSWnzQi)
+
+     (minipig 44onTKSrAjXQ42Ahu6Z8d5X35g23pTTbSgRudNow9ZEn
+              D17PC8RGELG2wvTUoeAVhZvpf5R2txQHdwtYxGAJ9M1h)
+
+   ]
+)
+
+(define (sign-key host)
+  (str (nth 1 (assoc host hosts))))
+
+(define (encrypt-key host)
+  (str (nth 2 (assoc host hosts))))
+
+(define my-refchan-head
+  `[
+
+(version 2)
+(quorum 1)
+(wait 10)
+(peer "CVDMz8BiSvRsgWNbJ4u9vRwXthN8LoF8XbbbjoL2cNFd" 1)
+(peer "5GnroAC8FXNRL8rcgJj6RTu9mt1AbuNd5MZVnDBcCKzb" 1)
+(peer "J8dFP5TbUQxUpVbVqZ3NKKPwrhvUCTQKC6xrVWUGkrR6" 1)
+(author ,(sign-key minime))
+(author ,(sign-key expert))
+(author ,(sign-key minipig))
+
+(reader ,(encrypt-key minime))
+(reader ,(encrypt-key expert))
+(reader ,(encrypt-key minipig))
+   ]
+)
+
+(define (create-refchan)
+  [hbs2:refchan:create my-refchan-head]
+)
+
+;; created once by create-refchan
+(define REFCHAN :Aze8PNNexhfz629UfaE79oyRW8Rf7fTGSVoJW4qD95Z7)
+(define HOST  [car [car [call:proc hostname]]])
+
+(define (update-refchan)
+  [hbs2:refchan:head:update REFCHAN my-refchan-head]
+)
+
+(define (create:name:update host)
+  (begin
+    (local pk (sign-key host))
+    (local tx (hbs2:refchan:tx:raw:create pk [unwords :name host]))
+    tx
+  )
+)
+
+(define (post:name:update)
+  (begin
+    (local tx (create:name:update HOST))
+    (hbs2:refchan:tx:propose REFCHAN tx)
+  )
+)
+
+(define (state:get)
+  (begin
+    ; won't work on ipv6 address 'cause of their stupid : as separator
+    (local (strip x) [sym [car [split :: [last [split :// x]]]]] )
+    (local self [list [sym [car [cdr [car [ grep peer-key [hbs2:peer:poke] ]]]]] :127.0.0.1])
+    (local txs (grep :propose (hbs2:refchan:tx:raw:list REFCHAN)))
+    (local (hostname e)  (car (cdr (car (top:string (bytes:decode [nth 4 _1]))))) )
+    (local peers (map (lambda [x] [car [cdr x]]) (car (call:proc hbs2-peer do peer-info))))
+
+    (local peers2 (map [fn 1  [list (lookup:uw :key _1) (strip (lookup:uw :addr _1))]] peers))
+    (local peers3 (filter [fn 1 [not (eq? [nth 1 _1] :192.168.1.1)]] peers2))
+
+    (local state (map [fn 1 [list [nth 2 _1] [hostname _1] ]] txs))
+
+    (local (entry e) [list [lookup:uw [nth 0 e] (cons self peers3)] [nth 1 e] ])
+    (local res [map [fn 1 [entry _1]]  state])
+
+    res
+  )
+)
+
+

examples/refchan-qblf/app/Main.hs

@@ -0,0 +1,6 @@
+module Main where
+
+import RefChanQBLF.CLI qualified as CLI
+
+main :: IO ()
+main = CLI.main

examples/refchan-qblf/app/RefChanQBLFMain.hs

@@ -1,806 +0,0 @@
-{-# Language TemplateHaskell #-}
-{-# Language UndecidableInstances #-}
-{-# Language AllowAmbiguousTypes #-}
-module Main where
-
-import HBS2.Prelude
-import HBS2.Defaults
-import HBS2.Merkle
-import HBS2.Hash
-import HBS2.Clock
-import HBS2.Base58
-import HBS2.OrDie
-import HBS2.Data.Types.Refs
-import HBS2.Net.Proto.Types
-import HBS2.Actors.Peer
-import HBS2.Peer.Proto.RefChan
-import HBS2.Peer.Proto.AnyRef
-import HBS2.Data.Types.SignedBox
-import HBS2.Net.Messaging.Unix
-import HBS2.Data.Bundle
-import HBS2.Net.Auth.Credentials
-import HBS2.Data.Detect
-import HBS2.Actors.Peer.Types()
-
-import HBS2.Storage.Simple
-
-import HBS2.System.Logger.Simple
-
-import HBS2.Net.Proto.QBLF
-
-import Demo.QBLF.Transactions
-import Data.Config.Suckless
-
-import Control.Monad.Trans.Maybe
-import Codec.Serialise
-import Control.Monad.Reader
-import Data.ByteString(ByteString)
-import Data.ByteString.Char8 qualified as BS
-import Data.ByteString.Lazy qualified as LBS
-import Data.List qualified as List
-import Lens.Micro.Platform hiding ((.=))
-import Options.Applicative hiding (info)
-import Options.Applicative qualified as O
-import System.Directory
-import Data.HashSet qualified as HashSet
-import Data.HashMap.Strict (HashMap)
-import Data.HashMap.Strict qualified as HashMap
-import Data.Maybe
-import Data.Word
-import System.Random
-import UnliftIO
-
-import Web.Scotty hiding (request,header)
-import Network.HTTP.Types.Status
-import Data.Cache (Cache)
-import Data.Cache qualified as Cache
-
-import Control.Monad.Except
-
-{- HLINT ignore "Use newtype instead of data" -}
-
--- TODO: config
---  сделать конфиг, а то слишком много уже параметров в CLI
-
-data HttpPortOpt
-data RefChanOpt
-data SocketOpt
-data ActorOpt
-data DefStateOpt
-data StateRefOpt
-
-data QBLFRefKey
-type MyRefKey = AnyRefKey QBLFRefKey HBS2Basic
-
-instance Monad m => HasCfgKey HttpPortOpt (Maybe Int) m where
-  key = "http"
-
-
-instance {-# OVERLAPPING #-} (HasConf m, HasCfgKey HttpPortOpt (Maybe Int) m) => HasCfgValue HttpPortOpt (Maybe Int) m where
-  cfgValue  = val <$> getConf
-    where
-      val syn = lastMay [ fromIntegral e
-                | ListVal (Key s [LitIntVal e]) <- syn, s == key @HttpPortOpt @(Maybe Int) @m
-                ]
-
-instance Monad m => HasCfgKey RefChanOpt (Maybe String) m where
-  key = "refchan"
-
-instance Monad m => HasCfgKey SocketOpt (Maybe String) m where
-  key = "socket"
-
-instance Monad m => HasCfgKey ActorOpt (Maybe String) m where
-  key = "actor"
-
-instance Monad m => HasCfgKey DefStateOpt (Maybe String) m where
-  key = "default-state"
-
-instance Monad m => HasCfgKey StateRefOpt (Maybe String) m where
-  key = "state-ref"
-
-class ToBalance e tx where
-  toBalance :: tx -> [(Account e, Amount)]
-
-tracePrefix :: SetLoggerEntry
-tracePrefix  = toStderr . logPrefix "[trace] "
-
-debugPrefix :: SetLoggerEntry
-debugPrefix  = toStderr . logPrefix "[debug] "
-
-errorPrefix :: SetLoggerEntry
-errorPrefix  = toStderr . logPrefix "[error] "
-
-warnPrefix :: SetLoggerEntry
-warnPrefix   = toStderr . logPrefix "[warn] "
-
-noticePrefix :: SetLoggerEntry
-noticePrefix = toStderr . logPrefix "[notice] "
-
-infoPrefix :: SetLoggerEntry
-infoPrefix = toStdout . logPrefix ""
-
-silently :: MonadIO m => m a -> m ()
-silently m = do
-  setLoggingOff @DEBUG
-  setLoggingOff @INFO
-  setLoggingOff @ERROR
-  setLoggingOff @WARN
-  setLoggingOff @NOTICE
-  void m
-
-withLogging :: MonadIO m => m a -> m ()
-withLogging m = do
-
-  -- setLogging @TRACE  tracePrefix
-  setLogging @DEBUG  debugPrefix
-  setLogging @INFO   infoPrefix
-  setLogging @ERROR  errorPrefix
-  setLogging @WARN   warnPrefix
-  setLogging @NOTICE noticePrefix
-
-  m
-
-  setLoggingOff @DEBUG
-  setLoggingOff @INFO
-  setLoggingOff @ERROR
-  setLoggingOff @WARN
-  setLoggingOff @NOTICE
-
-data MyEnv =
-  MyEnv
-  { mySelf  :: Peer UNIX
-  , myFab   :: Fabriq UNIX
-  , myChan  :: RefChanId UNIX
-  , myRef   :: MyRefKey
-  , mySto   :: AnyStorage
-  , myCred  :: PeerCredentials HBS2Basic
-  , myHttpPort :: Int
-  , myFetch :: Cache HashRef ()
-  }
-
-newtype App m a = App { fromApp :: ReaderT MyEnv m a }
-                  deriving newtype ( Functor
-                                   , Applicative
-                                   , Monad
-                                   , MonadIO
-                                   , MonadUnliftIO
-                                   , MonadReader MyEnv
-                                   , MonadTrans
-                                   )
-
-runApp :: (MonadIO m, PeerMessaging UNIX) => MyEnv -> App m a -> m a
-runApp env m = runReaderT (fromApp  m) env
-
-instance Monad m => HasFabriq UNIX (App m) where
-  getFabriq = asks myFab
-
-instance Monad m => HasOwnPeer UNIX (App m) where
-  ownPeer = asks mySelf
-
-instance Monad m => HasStorage (App m) where
-  getStorage = asks mySto
-
-data ConsensusQBLF
-
-data StateQBLF = StateQBLF { fromStateQBLF :: HashRef }
-
-data MyError =
-  DeserializationError | SignatureError | TxUnsupported | SomeOtherError
-  deriving stock (Eq,Ord,Show)
-
-check :: MonadIO m => MyError -> Either e a -> ExceptT MyError m a
-check w  = \case
-  Right x -> ExceptT $ pure (Right x)
-  Left{}  -> ExceptT $ pure (Left w)
-
-fiasco :: MonadIO m => MyError -> ExceptT MyError m a
-fiasco x = ExceptT $ pure $ Left x
-
-ok :: MonadIO m => a -> ExceptT MyError m a
-ok x = ExceptT $ pure $ Right x
-
-
-type ForConsensus m = (MonadIO m, Serialise (QBLFMessage ConsensusQBLF))
-
-instance Serialise (QBLFMerge ConsensusQBLF)
-instance Serialise (QBLFMessage ConsensusQBLF)
-instance Serialise (QBLFAnnounce ConsensusQBLF)
-instance Serialise (QBLFCommit ConsensusQBLF)
-
-instance Monad m => HasTimeLimits UNIX (RefChanNotify UNIX) (App m) where
-  tryLockForPeriod _ _ = pure True
-
-instance (ForConsensus m, MonadUnliftIO m)  => IsQBLF ConsensusQBLF (App m) where
-  type QBLFActor ConsensusQBLF = Actor L4Proto
-  type QBLFTransaction ConsensusQBLF = QBLFDemoToken L4Proto
-  type QBLFState ConsensusQBLF = DAppState
-
-  qblfMoveForward _ s1 = do
-    env <- ask
-    fetchMissed env s1
-    pure True
-
-  qblfNewState (DAppState h0) txs = do
-    sto <- asks mySto
-    chan <- asks myChan
-    self <- asks mySelf
-    creds <- asks myCred
-    let sk = view peerSignSk creds
-    let pk = view peerSignPk creds
-
-    -- основная проблема в том, что мы пересортировываем весь state
-    -- однако, если считать его уже отсортированным, то, может быть,
-    -- все будет не так уж плохо.
-    -- так-то мы можем вообще его на диске держать
-
-    root <- if List.null txs then do
-              pure h0
-            else do
-              hashes <- liftIO $ mapM (putBlock sto . serialise) txs <&> catMaybes
-
-              current <- readLog (getBlock sto) h0
-
-              let new = HashSet.fromList ( current <> fmap HashRef hashes )
-
-              let pt = toPTree (MaxSize 256) (MaxNum 256) (HashSet.toList new)
-
-              -- пробуем разослать бандлы с транзакциями
-              runMaybeT do
-                ref <- MaybeT $ createBundle sto (fmap HashRef hashes)
-                let refval = makeBundleRefValue @L4Proto pk sk (BundleRefSimple ref)
-                r <- MaybeT $ liftIO $ putBlock sto (serialise refval)
-                lift $ request self (ActionRequest @UNIX chan (RefChanAnnounceBlock (HashRef r)))
-
-              r <- makeMerkle 0 pt $ \(hx,_,bs) -> do
-                th <- liftIO (enqueueBlock sto bs)
-                debug $ "WRITE TX" <+> pretty hx
-
-              request self (ActionRequest @UNIX chan (RefChanAnnounceBlock (HashRef r)))
-
-              pure (HashRef r)
-
-    debug $ "PROPOSED NEW STATE:" <+> pretty root
-    pure $ DAppState root
-
-  qblfCommit s0 s1 = do
-    debug $ "COMMIT:" <+> pretty s0 <+> pretty s1
-    sto <- asks mySto
-    chan <- asks myChan
-    ref  <- asks myRef
-
-    debug $ "UPDATING REF" <+> pretty ref <+> pretty s1
-    liftIO $ updateRef sto ref (fromHashRef (fromDAppState s1))
-    pure ()
-
-  qblfBroadCast msg = do
-      self <- asks mySelf
-      creds <- asks myCred
-      chan <- asks myChan
-
-      let sk = view peerSignSk creds
-      let pk = view peerSignPk creds
-      nonce <- randomIO @Word64 <&> serialise <&> LBS.toStrict
-      let box = makeSignedBox @UNIX pk sk (LBS.toStrict (serialise msg) <> nonce)
-      let notify = Notify @UNIX chan box
-      request self notify
-
-      case msg of
-        QBLFMsgAnn _ (QBLFAnnounce _ _) -> do
-          -- TODO: maybe-announce-new-state-here
-          pure ()
-
-        _ -> none
-
-  -- TODO: optimize-qblf-merge
-  --   будет нормально работать до десятков/сотен тысяч транз,
-  --   а потом помрёт.
-  --   варианты:
-  --     1. перенести логику в БД
-  --     2. кэшировать всё, что можно
-  qblfMerge s0 s1 = do
-    chan <- asks myChan
-    self <- asks mySelf
-
-    creds <- asks myCred
-    let sk = view peerSignSk creds
-    let pk = view peerSignPk creds
-
-    debug $ "MERGE. Proposed state:" <+> pretty s1
-
-    sto <- asks mySto
-    let readFn = liftIO . getBlock sto
-
-    tx1 <- mapM (readLog readFn) (fmap fromDAppState s1) <&> mconcat
-    tx0 <- readLog readFn (fromDAppState s0) <&> HashSet.fromList
-
-    let txNew = HashSet.fromList tx1 `HashSet.difference` tx0
-
-    if List.null txNew then do
-      pure s0
-    else do
-      debug $ "READ TXS" <+> pretty s1 <+> pretty (length tx1)
-
-      r <- forM tx1 $ \t -> runMaybeT do
-
-              -- игнорируем ранее добавленные транзакции
-              guard (not (HashSet.member t tx0))
-
-              bs <- MaybeT $ liftIO $ getBlock sto (fromHashRef t)
-
-              tx <- MaybeT $ pure $ deserialiseOrFail @(QBLFDemoToken L4Proto) bs & either (const Nothing) Just
-
-              case tx of
-                Emit box -> do
-                  (pk, e@(EmitTx a q _)) <- MaybeT $ pure $ unboxSignedBox0 @(EmitTx L4Proto) box
-                  guard ( chan == pk )
-                  debug $ "VALID EMIT TRANSACTION" <+> pretty t <+> pretty (AsBase58 a) <+> pretty q
-                  pure ([(t,e)], mempty)
-
-                (Move box) -> do
-                  (_, m@(MoveTx _ _ qty _)) <- MaybeT $ pure $ unboxSignedBox0 @(MoveTx L4Proto) box
-
-                  guard (qty > 0)
-                  debug $ "MOVE TRANSACTION" <+> pretty t
-                  pure (mempty, [(t,m)])
-
-      let parsed = catMaybes r
-
-      let emits = foldMap (view _1) parsed
-
-      let moves = foldMap (view _2) parsed & List.sortOn fst
-
-      bal0 <- balances (fromDAppState s0)
-
-      -- баланс с учётом новых emit
-      let balE = foldMap (toBalance @L4Proto . snd) emits
-                        & HashMap.fromListWith (+)
-                        & HashMap.unionWith (+) bal0
-
-      let moves' = updBalances @L4Proto balE moves
-
-      let merged = fmap fst emits <> fmap fst moves'
-
-      let pt = toPTree (MaxSize 256) (MaxNum 256) (HashSet.toList (tx0 <> HashSet.fromList merged))
-
-      root <- makeMerkle 0 pt $ \(_,_,bs) -> do
-                void $ liftIO (putBlock sto bs)
-
-      let new = DAppState (HashRef root)
-
-      -- FIXME: garbage-collect-discarded-states
-
-      async $ void $ balances (fromDAppState new)
-      debug $ "MERGED" <+> pretty new
-
-      pure new
-
-
-instance HasStorage (ReaderT AnyStorage IO) where
-  getStorage = ask
-
-
-
-instance ToBalance e (EmitTx e) where
-  toBalance (EmitTx a qty _) = [(a, qty)]
-
-instance ToBalance e (MoveTx e) where
-  toBalance (MoveTx a1 a2 qty _) = [(a1, -qty), (a2, qty)]
-
-balances :: forall e s m . ( e ~ L4Proto
-                           , MonadIO m
-                           , HasStorage m
-                           -- , FromStringMaybe (PubKey 'Sign s)
-                           , s ~ Encryption e
-                           , ToBalance L4Proto (EmitTx L4Proto)
-                           , ToBalance L4Proto (MoveTx L4Proto)
-                           , Pretty (AsBase58 (PubKey 'Sign s))
-                           )
-         => HashRef
-         -> m (HashMap (Account e) Amount)
-
-balances root = do
-  sto <- getStorage
-
-  let pk = SomeRefKey (HashRef "6ChGmfYkwM6646oKkj8r8MAjdViTsdtZSi6tgqk3tbh", root)
-
-  cached <- runMaybeT do
-    rval <- MaybeT $ liftIO $ getRef sto pk
-    val  <- MaybeT $ liftIO $ getBlock sto rval
-    MaybeT $ deserialiseOrFail @(HashMap (Account e) Amount) val
-          & either (const $ pure Nothing) (pure . Just)
-
-  case cached of
-    Just bal -> pure bal
-    Nothing -> do
-
-      txs <- readLog (liftIO . getBlock sto) root
-
-      r <- forM txs $ \h -> runMaybeT do
-        blk <- MaybeT $ liftIO $ getBlock sto (fromHashRef h)
-        tx  <- MaybeT $ pure $ deserialiseOrFail @(QBLFDemoToken L4Proto) blk & either (const Nothing) Just
-
-        case tx of
-          Emit box -> do
-            (_, emit) <- MaybeT $ pure $  unboxSignedBox0 @(EmitTx L4Proto) box
-            pure $ toBalance @e emit
-
-          Move box -> do
-            (_, move) <- MaybeT $ pure $  unboxSignedBox0 @(MoveTx L4Proto) box
-            pure $ toBalance @e move
-
-      let val = catMaybes r & mconcat & HashMap.fromListWith (+)
-
-      runMaybeT do
-        checkComplete sto root >>= guard
-        rv <- MaybeT $ liftIO $ putBlock sto (serialise val)
-        liftIO $ updateRef sto pk rv
-
-      pure val
-
-
--- TODO: optimize-upd-balances
---  можно сгруппировать по аккаунтам
---  и проверять только те транзакции, которые относятся
---  к связанной (транзакциями) группе аккаунтов.
---  то есть, разбить на кластеры, у которых отсутствуют пересечения по
---  аккаунтам и проверять независимо и параллельно, например
---  причем, прямо этой функцией
---
--- updBalances :: HashMap (Account L4Proto) Amount
---              -> [(tx, b)]
---              -> [(tx, b)]
-
-updBalances :: forall e a tx . (ForRefChans e, ToBalance e tx)
-            => HashMap (Account e) Amount
-            -> [(a, tx)]
-            -> [(a, tx)]
-
-updBalances = go
-  where
-    go bal [] = empty
-
-    go bal (t:rest) =
-
-      if good then
-        t : go nb rest
-      else
-        go bal rest
-
-      where
-        nb = HashMap.unionWith (+) bal (HashMap.fromList (toBalance @e (snd t)))
-        good = HashMap.filter (<0) nb & HashMap.null
-
-
-fetchMissed :: forall e w m . ( MonadIO m
-                              , Request e (RefChanNotify e) m
-                              , e ~ UNIX
-                              , w ~ ConsensusQBLF
-                              )
-            => MyEnv
-            -> QBLFState w
-            -> m ()
-
-fetchMissed env s = do
-  let tube = mySelf env
-  let chan = myChan  env
-  let cache = myFetch env
-  let sto = mySto env
-
-  let href = fromDAppState s
-
-  here <- liftIO $ hasBlock sto (fromHashRef href) <&> isJust
-  wip <- liftIO $ Cache.lookup cache href <&> isJust
-
-  when here do
-    liftIO $ Cache.delete cache href
-
-  unless (here || wip) do
-    debug $ "We might be need to fetch" <+> pretty s
-    liftIO $ Cache.insert cache href ()
-    request @UNIX tube (ActionRequest @UNIX chan (RefChanFetch (fromDAppState s)))
-
-runMe :: ForConsensus IO => Config -> IO ()
-runMe conf = withLogging $ flip runReaderT conf do
-
-  debug $ "runMe" <+> pretty conf
-
-  kr    <- cfgValue @ActorOpt @(Maybe String) `orDie` "actor's key not set"
-  chan' <- cfgValue @RefChanOpt @(Maybe String) `orDie` "refchan not set"
-  sa    <- cfgValue @SocketOpt @(Maybe String) `orDie` "socket not set"
-  pno   <- cfgValue @HttpPortOpt @(Maybe Int) <&> fromMaybe 3011
-  ds    <- cfgValue @DefStateOpt @(Maybe String)
-
-  ref   <- ( cfgValue @StateRefOpt @(Maybe String)
-                <&>  maybe Nothing fromStringMay
-           ) `orDie` "state-ref not set"
-
-  sc <- liftIO $ BS.readFile kr
-  creds <- pure (parseCredentials @HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
-
-  chan  <- pure (fromStringMay @(RefChanId L4Proto) chan') `orDie` "invalid REFCHAN"
-
-  here <- liftIO $ doesFileExist sa
-
-  when here do
-    liftIO $ removeFile sa
-
-  server <- newMessagingUnixOpts [MUNoFork] True 1.0 sa
-
-  abus <- async $ runMessagingUnix server
-
-  let tube = fromString sa
-
-  -- FIXME: fix-default-storage
-  xdg <- liftIO $ getXdgDirectory XdgData defStorePath <&> fromString
-  sto' <- simpleStorageInit @HbSync [StoragePrefix xdg]
-
-  let sto = AnyStorage sto'
-  sw <- liftIO $ replicateM 4 $ async $ simpleStorageWorker sto'
-
-  -- FIXME: fix-hardcoded-timeout
-  fetches <- liftIO $ Cache.newCache (Just (toTimeSpec (TimeoutSec 30)))
-
-  let myEnv = MyEnv tube
-                    (Fabriq server)
-                    chan
-                    ref
-                    sto
-                    creds
-                    pno
-                    fetches
-
-  let dss = ds >>= fromStringMay
-
-  s0 <- readOrCreateStateRef dss sto ref
-
-  debug $ "STATE0:" <+> pretty s0
-
-  -- получить голову
-  -- из головы получить акторов
-
-  headBlk <- getRefChanHead @L4Proto sto (RefChanHeadKey chan) `orDie` "can't read head block"
-
-  let self = view peerSignPk creds & Actor @L4Proto
-
-  let actors = view refChanHeadAuthors headBlk
-                  & HashSet.toList
-                  & fmap (Actor @L4Proto)
-
-  runApp myEnv do
-
-    -- FIXME: timeout-hardcode
-    let w = realToFrac 5
-
-    -- FIXME: use-actors-asap
-    qblf <- qblfInit @ConsensusQBLF self actors (DAppState (HashRef s0)) w
-
-    consensus <- async do
-                   pause @'Seconds 0.5
-                   qblfRun qblf
-
-
-    -- FIXME: web-port-to-config
-    web <- async $ liftIO $ scotty (fromIntegral (myHttpPort myEnv)) $ do
-             post "/tx" $ do
-
-              r <- runExceptT do
-
-                bin <- lift body
-                let hBin = hashObject @HbSync bin
-
-                debug $ "GOT TX" <+> pretty hBin
-
-                tok <- check DeserializationError =<< pure (deserialiseOrFail @(QBLFDemoToken L4Proto) bin)
-
-                tx <- case tok of
-                        (Emit box) -> do
-                          (sign, tx) <- maybe (ExceptT $ pure $ Left SignatureError) pure $  unboxSignedBox0 box
-
-                          if sign == chan then
-                            pure hBin
-                          else
-                            fiasco SignatureError
-
-                        (Move box) -> do
-                          (sign, tx) <- maybe (ExceptT $ pure $ Left SignatureError) pure $  unboxSignedBox0 box
-                          pure hBin
-
-                qblfEnqueue qblf tok
-                pure hBin
-
-              case r of
-                Left SignatureError -> do
-                  err $ viaShow SignatureError
-                  status status401
-
-                Left e -> do
-                  err $ viaShow e
-                  status status400
-
-                Right tx -> do
-                  debug $ "TX ENQUEUED OK" <+> pretty tx
-                  status status200
-
-    link web
-
-    runProto $ List.singleton $ makeResponse (myProto myEnv qblf chan)
-
-  void $ waitAnyCatchCancel $ [abus] <> sw
-
-  where
-
-    myProto :: forall e m . ( MonadIO m
-                            , Request e (RefChanNotify e) m
-                            , e ~ UNIX
-                            )
-                       => MyEnv
-                       -> QBLF ConsensusQBLF
-                       -> RefChanId e
-                       -> RefChanNotify e
-                       -> m ()
-
-    myProto _ qblf _ (ActionRequest{}) = do
-      pure ()
-
-    myProto env qblf chan (Notify _ msg) = do
-
-      let sto = mySto env
-      let tube = mySelf env
-
-      let coco = hashObject @HbSync $ serialise msg
-      void $ runMaybeT do
-        (_, wrapped) <- MaybeT $ pure $ unboxSignedBox0 @ByteString @UNIX msg
-        qbmess <- MaybeT $ pure $ deserialiseOrFail @(QBLFMessage ConsensusQBLF) (LBS.fromStrict wrapped)
-                                              & either (const Nothing) Just
-
-        states <- case qbmess of
-          QBLFMsgAnn _ (QBLFAnnounce s0 s1) -> do
-            pure [s0, s1]
-
-          QBLFMsgHeartBeat _ _ s0 _-> do
-            pure  [s0]
-
-          _ -> do
-            pure mempty
-
-        -- FIXME: full-download-guarantee
-        lift $ forM_ states (fetchMissed env)
-
-        qblfAcceptMessage qblf qbmess
-        -- debug $ "RefChanQBLFMain(3)" <+> "got message" <+> pretty (AsBase58 chan) <+> pretty coco
-
-    readOrCreateStateRef mbDs sto ref = do
-      debug $ "MyRef:" <+> pretty (hashObject @HbSync ref)
-      fix \spin -> do
-                mbref <- liftIO $ getRef @_ @HbSync sto ref
-                case mbref of
-                  Nothing -> do
-                    debug "STATE is empty"
-                    maybe1 mbDs none $ \ds -> do
-                      debug $ "UPDATE REF" <+> pretty (hashObject @HbSync ref) <+> pretty (HashRef ds)
-                      liftIO $ updateRef sto ref ds
-
-                    pause @'Seconds 0.25
-
-                    spin
-
-                  Just val -> do
-                    pure val
-
-type Config = [Syntax MegaParsec]
-
-main :: IO ()
-main = join . customExecParser (prefs showHelpOnError) $
-  O.info (helper <*> globalOptions)
-  (  fullDesc
-  <> header "refchan-qblf-worker"
-  <> progDesc "for test and demo purposed"
-  )
-  where
-
-    globalOptions = applyConfig <$> commonOpts <*> cli
-
-    applyConfig :: Maybe FilePath -> (Config -> IO ()) -> IO ()
-    applyConfig config m = do
-      maybe1 config (m mempty) $ \conf -> do
-        top <- readFile conf <&> parseTop <&> either (pure mempty) id
-        m top
-
-    commonOpts = optional $ strOption (long "config" <> short 'c' <> help "Config file")
-
-    cli = hsubparser (  command "run" (O.info pRun (progDesc "run qblf servant" ) )
-                     <> command "gen" (O.info pGen (progDesc "generate transcation") )
-                     <> command "post" (O.info pPostTx (progDesc "post transaction") )
-                     <> command "check" (O.info pCheckTx (progDesc "check transaction") )
-                     <> command "balances" (O.info pBalances (progDesc "show balances") )
-                     )
-
-    pRun = do
-      pure runMe
-
-    pGen = hsubparser
-           (   command "tx-emit" ( O.info pGenEmit (progDesc "generate emit") )
-            <> command "tx-move" ( O.info pGenMove (progDesc "generate move") )
-           )
-
-    pGenEmit = do
-      kr    <- strOption   ( long "keyring"  <> short 'k' <> help "keyring file" )
-      amnt <- option @Amount auto ( long "amount" <> short 'n' <> help "amount" )
-      dest <- strArgument ( metavar "ADDRESS" )
-      pure $ const $ silently do
-        sc <- BS.readFile kr
-        creds <- pure (parseCredentials @HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
-        let pk = view peerSignPk creds
-        let sk = view peerSignSk creds
-        acc <- pure (fromStringMay @(RefChanId L4Proto) dest) `orDie` "bad account address"
-        tx <- makeEmitTx @L4Proto pk sk acc amnt
-        LBS.putStr $ serialise tx
-
-    pGenMove = do
-      kr    <- strOption   ( long "wallet"  <> short 'w' <> help "wallet (keyring) file" )
-      amnt <- option @Amount auto ( long "amount" <> short 'n' <> help "amount" )
-      dest <- strArgument ( metavar "ADDRESS" )
-      pure $ const $ silently do
-        sc <- BS.readFile kr
-        creds <- pure (parseCredentials @HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
-        let pk = view peerSignPk creds
-        let sk = view peerSignSk creds
-        acc <- pure (fromStringMay @(RefChanId L4Proto) dest) `orDie` "bad account address"
-        tx <- makeMoveTx @L4Proto pk sk acc amnt
-        LBS.putStr $ serialise tx
-
-    pCheckTx = do
-      kr    <- strOption   ( long "keyring"  <> short 'k' <> help "keyring file" )
-      pure $ const do
-        sc <- BS.readFile kr
-        creds <- pure (parseCredentials @HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
-        let pk = view peerSignPk creds
-        let sk = view peerSignSk creds
-
-        tx <- LBS.getContents <&> deserialise @(QBLFDemoToken L4Proto)
-
-        case tx of
-          Emit box -> do
-            void $ pure (unboxSignedBox0 @(EmitTx L4Proto) @L4Proto box) `orDie` "bad emit tx"
-
-          Move box -> do
-            void $ pure (unboxSignedBox0 @(MoveTx L4Proto) @L4Proto box) `orDie` "bad move tx"
-
-        pure ()
-
-    pPostTx  = pure $ const do
-      error "not supported anymore / TODO via http"
-      -- rc <- strArgument ( metavar "REFCHAN" )
-      -- sa <- strArgument ( metavar "UNIX-SOCKET" ) <&> fromString
-      -- pure $ withLogging do
-      --   rchan <- pure (fromStringMay @(RefChanId L4Proto) rc) `orDie` "bad refchan"
-      --   print "JOPA"
-      --   -- FIXME: wrap-client-boilerplate
-      --   inbox <- newMessagingUnix False 1.0 sa
-      --   wInbox <- async $ runMessagingUnix inbox
-      --   let env = MyEnv (fromString sa) (Fabriq inbox) rchan
-      --   msg <- (LBS.getContents <&> deserialiseOrFail) `orDie` "transaction decode error"
-      --   runApp env do
-      --     request (mySelf env) (msg  :: QBLFDemoTran UNIX)
-      --     pause @'Seconds 0.1
-        -- cancel wInbox
-
-    pBalances = do
-      state <- strArgument ( metavar "STATE" )
-      pure $ const $ withLogging do
-
-        xdg <- liftIO $ getXdgDirectory XdgData defStorePath <&> fromString
-        sto' <- simpleStorageInit @HbSync [StoragePrefix xdg]
-
-        let sto = AnyStorage sto'
-        sw <- liftIO $ replicateM 4 $ async $ simpleStorageWorker sto'
-
-        root <- pure (fromStringMay @HashRef state) `orDie` "Bad STATE reference"
-
-        flip runReaderT sto $ do
-          debug $ "calculating balances for" <+> pretty root
-          bal <- balances root
-
-          forM_ (HashMap.toList bal) $ \(acc, qty) -> do
-            liftIO $ print $ pretty (AsBase58 acc) <+> pretty qty
-

examples/refchan-qblf/lib/Demo/QBLF/Transactions.hs

@@ -1,131 +0,0 @@
-{-# Language UndecidableInstances #-}
-module Demo.QBLF.Transactions where
-
-import HBS2.Prelude.Plated
-import HBS2.Hash
-import HBS2.Base58
-import HBS2.Peer.Proto
-import HBS2.Data.Types.Refs (HashRef(..))
-import HBS2.Data.Types.SignedBox
-import HBS2.Net.Auth.Credentials
-import HBS2.Net.Messaging.Unix (UNIX)
-
-import Data.Hashable(Hashable(..))
-import Codec.Serialise
-import Data.ByteString.Lazy (ByteString)
-import Data.Word (Word64)
-import System.Random
-
-newtype Actor e =
-  Actor { fromActor :: PubKey 'Sign (Encryption e) }
-  deriving stock (Generic)
-
-deriving stock instance Eq (PubKey 'Sign (Encryption e)) => Eq (Actor e)
-deriving newtype instance Hashable (PubKey 'Sign (Encryption e)) => Hashable (Actor e)
-
-instance Pretty (AsBase58 (PubKey 'Sign (Encryption e))) => Pretty (Actor e) where
-  pretty (Actor a) = pretty (AsBase58 a)
-
-type Account e = PubKey 'Sign (Encryption e)
-
-newtype Amount = Amount Integer
-                deriving stock (Eq,Show,Ord,Data,Generic)
-                deriving newtype (Read,Enum,Num,Integral,Real,Pretty)
-
-newtype DAppState = DAppState { fromDAppState :: HashRef }
-                deriving stock (Eq,Show,Ord,Data,Generic)
-                deriving newtype (Hashable,Pretty)
-
-instance Hashed HbSync DAppState where
-  hashObject (DAppState (HashRef h)) = h
-
-data EmitTx e = EmitTx (Account e) Amount Word64
-                deriving stock (Generic)
-
-data MoveTx e = MoveTx (Account e) (Account e) Amount Word64
-                deriving stock (Generic)
-
-data QBLFDemoToken e =
-    Emit (SignedBox (EmitTx e) e)  --  proof: owner's  key
-  | Move (SignedBox (MoveTx e) e)  --  proof: wallet's key
-  deriving stock (Generic)
-
-instance ForRefChans e => Serialise (Actor e)
-
-instance Serialise DAppState
-
-instance Serialise Amount
-
-instance Serialise (PubKey 'Sign (Encryption e)) => Serialise (EmitTx e)
-
-instance Serialise (PubKey 'Sign (Encryption e)) => Serialise (MoveTx e)
-
-instance (Serialise (Account e), ForRefChans e) => Serialise (QBLFDemoToken e)
-
-type ForQBLFDemoToken e = ( Eq (PubKey 'Sign (Encryption e))
-                          , Eq (Signature (Encryption e))
-                          , Pretty (AsBase58 (PubKey 'Sign (Encryption e)))
-                          , ForSignedBox e
-                          , FromStringMaybe (PubKey 'Sign (Encryption e))
-                          , Serialise (PubKey 'Sign (Encryption e))
-                          , Serialise (Signature (Encryption e))
-                          , Hashable (PubKey 'Sign (Encryption e))
-                          )
-
-deriving stock instance (ForQBLFDemoToken e) => Eq (QBLFDemoToken e)
-
-instance ForQBLFDemoToken e => Hashable (QBLFDemoToken e) where
-  hashWithSalt salt = \case
-    Emit box  -> hashWithSalt salt box
-    Move box  -> hashWithSalt salt box
-
-newtype QBLFDemoTran e =
-  QBLFDemoTran (SignedBox (QBLFDemoToken e) e)
-  deriving stock Generic
-
-instance ForRefChans e => Serialise (QBLFDemoTran e)
-
-deriving newtype instance
-  (Eq (PubKey 'Sign (Encryption e)), Eq (Signature (Encryption e)))
-  => Eq (QBLFDemoTran e)
-
-deriving newtype instance
-  (Eq (Signature (Encryption e)), ForRefChans e)
-    => Hashable (QBLFDemoTran e)
-
-instance Serialise (QBLFDemoTran UNIX) => HasProtocol UNIX (QBLFDemoTran UNIX) where
-  type instance ProtocolId (QBLFDemoTran UNIX) = 0xFFFF0001
-  type instance Encoded UNIX = ByteString
-  decode = either (const Nothing) Just . deserialiseOrFail
-  encode = serialise
-
-makeEmitTx :: forall e m . ( MonadIO m
-                           , ForRefChans e
-                           , Signatures (Encryption e)
-                           )
-           => PubKey 'Sign (Encryption e)
-           -> PrivKey 'Sign (Encryption e)
-           -> Account e
-           -> Amount
-           -> m (QBLFDemoToken e)
-
-makeEmitTx pk sk acc amount = do
-  nonce <- randomIO
-  let box = makeSignedBox @e pk sk (EmitTx @e acc amount nonce)
-  pure (Emit @e box)
-
-makeMoveTx :: forall e m . ( MonadIO m
-                           , ForRefChans e
-                           , Signatures (Encryption e)
-                           )
-           => PubKey 'Sign (Encryption e)  -- from pk
-           -> PrivKey 'Sign (Encryption e) -- from sk
-           -> Account e
-           -> Amount                       -- amount
-           -> m (QBLFDemoToken e)
-
-makeMoveTx pk sk acc amount = do
-  nonce <- randomIO
-  let box = makeSignedBox @e pk sk (MoveTx @e pk acc amount nonce)
-  pure (Move @e box)
-

examples/refchan-qblf/lib/RefChanQBLF/App.hs

@@ -0,0 +1,182 @@
+module RefChanQBLF.App where
+
+import Codec.Serialise
+import Control.Monad.Cont
+import Control.Monad.Trans.Maybe
+import Data.ByteString qualified as BS
+import Data.ByteString.Lazy qualified as LBS
+import Data.Cache qualified as Cache
+import Data.HashSet qualified as HashSet
+import HBS2.Actors.Peer
+import HBS2.Actors.Peer.Types ()
+import HBS2.Clock
+import HBS2.Data.Types.Refs
+import HBS2.Data.Types.SignedBox
+import HBS2.Defaults
+import HBS2.Hash
+import HBS2.Net.Auth.Credentials
+import HBS2.Net.Messaging.Unix
+import HBS2.Net.Proto.QBLF
+import HBS2.Net.Proto.Service
+import HBS2.OrDie
+import HBS2.Peer.Proto.RefChan
+import HBS2.Prelude
+import HBS2.Storage.Simple
+import HBS2.System.Logger.Simple
+import Lens.Micro.Platform hiding ((.=))
+import System.Directory
+
+import RefChanQBLF.Common
+import RefChanQBLF.Impl
+import RefChanQBLF.RPCServer
+import RefChanQBLF.Transactions
+
+data QBLFAppConf = QBLFAppConf
+    { qapActorKeyring :: FilePath
+    , qapRefchanID :: RefChanId L4Proto
+    , qapSocket :: FilePath
+    , qapAppSocket :: FilePath
+    , qapDefState :: Maybe (Hash HbSync)
+    , qapStateRef :: MyRefKey
+    }
+
+withSimpleAnyStorage :: FilePath -> (AnyStorage -> IO r) -> IO r
+withSimpleAnyStorage storepath go = do
+    -- FIXME: fix-default-storage
+    xdg <- getXdgDirectory XdgData storepath <&> fromString
+    sto' <- simpleStorageInit @HbSync [StoragePrefix xdg]
+    flip runContT go do
+        replicateM 4 $ contAsync $ simpleStorageWorker sto'
+        pure $ AnyStorage sto'
+
+loadCreds :: FilePath -> IO (PeerCredentials 'HBS2Basic)
+loadCreds fpath = do
+    bs <- BS.readFile fpath
+    pure (parseCredentials @'HBS2Basic (AsCredFile bs)) `orDie` "bad keyring file"
+
+runQBLFApp :: (ForConsensus IO) => QBLFAppConf -> IO ()
+runQBLFApp QBLFAppConf {..} = withLogging do
+    creds <- loadCreds qapActorKeyring
+
+    whenM (doesFileExist qapSocket) $ removeFile qapSocket
+
+    -- FIXME: fix-hardcoded-timeout
+    fetches <- Cache.newCache (Just (toTimeSpec (TimeoutSec 30)))
+
+    flip runContT pure do
+        sto <- ContT $ withSimpleAnyStorage defStorePath
+
+        server <- newMessagingUnixOpts [MUNoFork] True 1.0 qapSocket
+        contAsync $ runMessagingUnix server
+
+        s0 <- lift $ readOrCreateStateRef qapDefState sto qapStateRef
+        debug $ "STATE0:" <+> pretty s0
+
+        let myEnv =
+                MyEnv
+                    { mySelf = fromString qapSocket -- Peer UNIX
+                    , myFab = (Fabriq server) -- Fabriq UNIX
+                    , myChan = qapRefchanID -- RefChanId UNIX
+                    , myRef = qapStateRef -- MyRefKey
+                    , mySto = sto -- AnyStorage
+                    , myCred = creds -- PeerCredentials 'HBS2Basic
+                    -- , myAppSoPath = appso                   -- TODO ?
+                    , myFetch = fetches -- Cache HashRef ()
+                    }
+
+        lift $ runMyAppT myEnv do
+            -- FIXME: timeout-hardcode
+            let w = realToFrac 5
+
+            -- получить голову
+            -- из головы получить акторов
+            headBlk <-
+                getRefChanHead @L4Proto sto (RefChanHeadKey qapRefchanID)
+                    `orDie` "can't read head block"
+
+            -- FIXME: use-actors-asap
+            let self = Actor $ view peerSignPk creds
+            let actors = fmap Actor $ HashSet.toList $ view refChanHeadAuthors headBlk
+            qblf <- qblfInit @ConsensusQBLF self actors (DAppState (HashRef s0)) w
+
+            flip runContT pure do
+                contAsync do
+                    pause @'Seconds 0.5
+                    qblfRun qblf
+
+                do
+                    srv <- liftIO $ newMessagingUnix True 1.0 qapAppSocket
+                    contAsync $ runMessagingUnix srv
+                    let qenv =
+                            QRPCEnv
+                                { qrpcenvQConsensus = qblf
+                                , qrpcenvRefchanId = qapRefchanID
+                                , qrpcenvFabriq = Fabriq srv
+                                , qrpcenvOwnPeer = fromString qapAppSocket
+                                }
+
+                    contAsync $ liftIO $ runQRPCT qenv do
+                        runProto @UNIX
+                            [ makeResponse (makeServer @QBLFAppRPC)
+                            ]
+
+                lift $ runProto [makeResponse (myProto myEnv qblf qapRefchanID)]
+  where
+    myProto
+        :: forall e m
+         . ( MonadIO m
+           , Request e (RefChanNotify e) m
+           , e ~ UNIX
+           )
+        => MyEnv
+        -> QBLF ConsensusQBLF
+        -> RefChanId e
+        -> RefChanNotify e
+        -> m ()
+
+    myProto _ _qblf _ (ActionRequest {}) = do
+        pure ()
+    myProto env qblf _chan (Notify _ msg) = do
+        void $ runMaybeT do
+            (_, wrapped) <- MaybeT $ pure $ unboxSignedBox0 msg
+            qbmess <-
+                MaybeT $
+                    pure $
+                        deserialiseOrFail @(QBLFMessage ConsensusQBLF) (LBS.fromStrict wrapped)
+                            & either (const Nothing) Just
+
+            states <- case qbmess of
+                QBLFMsgAnn _ (QBLFAnnounce s0 s1) -> do
+                    pure [s0, s1]
+                QBLFMsgHeartBeat _ _ s0 _ -> do
+                    pure [s0]
+                _ -> do
+                    pure mempty
+
+            -- FIXME: full-download-guarantee
+            lift $ forM_ states (fetchMissed env)
+
+            qblfAcceptMessage qblf qbmess
+    -- debug $ "RefChanQBLFMain(3)" <+> "got message" <+> pretty (AsBase58 chan) <+> pretty coco
+
+    readOrCreateStateRef :: Maybe (Hash HbSync) -> AnyStorage -> MyRefKey -> IO (Hash HbSync)
+    readOrCreateStateRef mbDs sto ref = do
+        debug $ "MyRef:" <+> pretty (hashObject @HbSync ref)
+        fix \spin -> do
+            mbref <- readStateHashMay sto ref
+            case mbref of
+                Nothing -> do
+                    debug "STATE is empty"
+                    mbDs & maybe none \ds -> do
+                        debug $ "UPDATE REF" <+> pretty (hashObject @HbSync ref) <+> pretty (HashRef ds)
+                        updateRef sto ref ds
+
+                    pause @'Seconds 0.25
+
+                    spin
+                Just val -> do
+                    pure val
+
+readStateHashMay :: AnyStorage -> MyRefKey -> IO (Maybe (Hash HbSync))
+readStateHashMay sto ref =
+    getRef @_ @HbSync sto ref

examples/refchan-qblf/lib/RefChanQBLF/CLI.hs

@@ -0,0 +1,214 @@
+module RefChanQBLF.CLI where
+
+import HBS2.Actors.Peer
+import HBS2.Actors.Peer.Types ()
+import HBS2.Base58
+import HBS2.Clock
+import HBS2.Data.Types.Refs
+import HBS2.Data.Types.SignedBox
+import HBS2.Defaults
+import HBS2.Hash
+import HBS2.Net.Auth.Credentials
+import HBS2.Net.Messaging.Unix
+import HBS2.Net.Proto.Service
+import HBS2.OrDie
+import HBS2.Peer.Proto.AnyRef
+import HBS2.Peer.Proto.RefChan
+import HBS2.Prelude
+import HBS2.Storage.Simple
+import HBS2.System.Logger.Simple
+
+import Codec.Serialise
+import Control.Arrow hiding ((<+>))
+import Control.Monad.Cont
+import Control.Monad.Except
+import Control.Monad.Reader
+import Data.ByteString qualified as BS
+import Data.ByteString.Char8 qualified as BS8
+import Data.ByteString.Lazy qualified as LBS
+import Data.Config.Suckless
+import Data.HashMap.Strict qualified as HashMap
+import Data.String.Conversions (cs)
+import Lens.Micro.Platform hiding ((.=))
+import Options.Applicative hiding (info)
+import Options.Applicative qualified as O
+import System.Directory
+import System.Exit qualified as Exit
+import UnliftIO
+
+import RefChanQBLF.App
+import RefChanQBLF.Common
+import RefChanQBLF.Impl
+import RefChanQBLF.RPCServer
+import RefChanQBLF.Transactions
+
+
+type Config = [Syntax C]
+
+main :: IO ()
+main = join . customExecParser (prefs showHelpOnError) $
+  O.info (helper <*> globalOptions)
+  (  fullDesc
+  <> header "refchan-qblf-worker"
+  <> progDesc "for test and demo purposed"
+  )
+  where
+
+    globalOptions = applyConfig <$> commonOpts <*> cli
+
+    applyConfig :: Maybe FilePath -> (Config -> IO ()) -> IO ()
+    applyConfig config m = do
+      maybe1 config (m mempty) $ \conf -> do
+        top <- readFile conf <&> parseTop <&> either (pure mempty) id
+        m top
+
+    commonOpts = optional $ strOption (long "config" <> short 'c' <> help "Config file")
+
+    cli = hsubparser (  command "run" (O.info pRun (progDesc "run qblf servant" ) )
+                     <> command "gen" (O.info pGen (progDesc "generate transcation") )
+                     <> command "post" (O.info pPostTx (progDesc "post transaction") )
+                     <> command "check" (O.info pCheckTx (progDesc "check transaction") )
+                     <> command "balances" (O.info pBalances (progDesc "show balances") )
+                     )
+
+    pGen = hsubparser
+           (   command "tx-emit" ( O.info pGenEmit (progDesc "generate emit") )
+            <> command "tx-move" ( O.info pGenMove (progDesc "generate move") )
+           )
+
+    pGenEmit = do
+      kr    <- strOption   ( long "keyring"  <> short 'k' <> help "keyring file" )
+      amnt <- option @Amount auto ( long "amount" <> short 'n' <> help "amount" )
+      dest <- strArgument ( metavar "ADDRESS" )
+      pure $ const $ silently do
+        sc <- BS.readFile kr
+        creds <- pure (parseCredentials @'HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
+        let pk = view peerSignPk creds
+        let sk = view peerSignSk creds
+        acc <- pure (fromStringMay @(RefChanId L4Proto) dest) `orDie` "bad account address"
+        tx <- makeEmitDemoToken @_ @L4Proto pk sk acc amnt
+        LBS.putStr $ serialise tx
+
+    pGenMove = do
+      kr    <- strOption   ( long "wallet"  <> short 'w' <> help "wallet (keyring) file" )
+      amnt <- option @Amount auto ( long "amount" <> short 'n' <> help "amount" )
+      dest <- strArgument ( metavar "ADDRESS" )
+      pure $ const $ silently do
+        sc <- BS.readFile kr
+        creds <- pure (parseCredentials @'HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
+        let pk = view peerSignPk creds
+        let sk = view peerSignSk creds
+        acc <- pure (fromStringMay @(RefChanId L4Proto) dest) `orDie` "bad account address"
+        tx <- makeMoveDemoToken @_ @L4Proto pk sk acc amnt
+        LBS.putStr $ serialise tx
+
+    pCheckTx = do
+      pure $ const do
+        tx <- either (Exit.die . ("QBLFDemoToken deserialise error: " <>) . show) pure
+              . deserialiseOrFail @(QBLFDemoToken 'HBS2Basic)
+            =<< LBS.getContents
+
+        case tx of
+          Emit box ->
+            BS8.hPutStrLn stderr . cs . show . pretty . first AsBase58
+                =<< pure (unboxSignedBox0 box) `orDie` "bad emit tx"
+
+          Move box ->
+            BS8.hPutStrLn stderr . cs . show . pretty . first AsBase58
+                =<< pure (unboxSignedBox0 box) `orDie` "bad move tx"
+
+        pure ()
+
+pBalances :: Parser (Config -> IO ())
+pBalances = do
+    mstateref <- optional do
+        option (fromStringP @HashRef "qblf state hash")
+            (long "state-hash" <> metavar "HASH-REF")
+    pure \syn -> withLogging do
+        bal <- flip runContT pure do
+            sto <- ContT $ withSimpleAnyStorage defStorePath
+            lift do
+                stateHashRef :: HashRef
+                    <- mstateref & flip maybe pure do
+                      either Exit.die pure =<< runExceptT do
+                        stref <- (flip runReader syn $ cfgValue @StateRefOpt @(Maybe String))
+                            & orE "state-ref key not found in config"
+                            <&> fromStringMay
+                            & orEM "state-ref key parse error"
+                        HashRef <$> do
+                          liftIO (readStateHashMay sto stref)
+                            & orEM "State is not created yed"
+                flip runReaderT sto $ do
+                    debug $ "calculating balances for" <+> pretty stateHashRef
+                    balances stateHashRef
+
+        forM_ (HashMap.toList bal) $ \(acc, qty) -> do
+            liftIO $ print $ pretty (AsBase58 acc) <+> pretty qty
+
+fromStringP :: (FromStringMaybe a) => String -> ReadM a
+fromStringP msg = eitherReader $
+      maybe (Left ("Can not parse " <> msg)) Right . fromStringMay . cs
+
+refchanP :: ReadM (RefChanId L4Proto)
+refchanP = fromStringP "refchan id"
+
+pPostTx :: Parser (Config -> IO ())
+pPostTx = do
+    pure \syn -> withLogging do
+        debug $ "runQBLFApp" <+> pretty syn
+
+        appsopath <- maybe (Exit.die "app-socket path not found in config") pure do
+            flip runReader syn do
+                cfgValue @AppSocketOpt @(Maybe String)
+
+        tx <- either (Exit.die . ("QBLFDemoToken deserialise error: " <>) . show) pure
+              . deserialiseOrFail @(QBLFDemoToken 'HBS2Basic)
+            =<< LBS.getContents
+
+        messagingUnix :: MessagingUnix <- newMessagingUnix False 1.0 appsopath
+        ep <- makeServiceCaller @QBLFAppRPC @UNIX (msgUnixSelf messagingUnix)
+        flip runContT pure do
+          contAsync $ runMessagingUnix messagingUnix
+          contAsync $ runReaderT (runServiceClient ep) messagingUnix
+          lift do
+
+            maybe (Exit.die "RPC server is not available") pure
+                =<< callRpcWaitMay @PingRPC (TimeoutSec 0.42) ep ()
+
+            r :: Text
+                <- callRpcWaitMay @PostTxRPC (TimeoutSec 3) ep tx
+                & peelMWith Exit.die do
+                      orE "RPC server timeout" >>> leftEM show >>> leftEM show
+
+            LBS.putStr . cs $ r
+
+pRun :: Parser (Config -> IO ())
+pRun = pure \conf -> withLogging do
+    debug $ "runQBLFApp" <+> pretty conf
+    runQBLFApp =<< (either Exit.die pure . parseQBLFAppConf) conf
+
+parseQBLFAppConf :: Config -> Either String QBLFAppConf
+parseQBLFAppConf = runReaderT do
+    qapActorKeyring <- cfgValue @ActorOpt @(Maybe String)
+        & orEM "actor's key not set"
+
+    qapRefchanID <- cfgValue @RefChanOpt @(Maybe String)
+        & orEM "refchan not set"
+        <&> fromStringMay @(RefChanId L4Proto)
+        & orEM "invalid REFCHAN value in config"
+
+    qapSocket <- cfgValue @SocketOpt @(Maybe String)
+        & orEM "socket not set"
+
+    qapAppSocket <- cfgValue @AppSocketOpt @(Maybe String)
+        & orEM "app socket not set"
+
+    qapDefState <- cfgValue @DefStateOpt @(Maybe String)
+        <&> (>>= fromStringMay)
+
+    qapStateRef <- cfgValue @StateRefOpt @(Maybe String)
+        & orEM "state-ref key not found in config"
+        <&> fromStringMay
+        & orEM "state-ref key parse error"
+
+    pure QBLFAppConf {..}

examples/refchan-qblf/lib/RefChanQBLF/Common.hs

@@ -0,0 +1,58 @@
+module RefChanQBLF.Common where
+
+import HBS2.Data.Types
+import HBS2.Peer.RPC.Client.Unix ()
+
+import Control.Monad.Cont
+import Control.Monad.Except
+import Data.Bool
+import Data.Text (Text)
+import GHC.Generics (Generic)
+import Prettyprinter
+import UnliftIO
+
+data MyError
+    = DeserializationError
+    | SignatureError
+    | SignerDoesNotMatchRefchan Text Text
+    | TxUnsupported
+    | SomeOtherError
+    deriving stock (Generic, Show)
+instance Serialise MyError
+instance Exception MyError
+
+whenM :: (Monad m) => m Bool -> m () -> m ()
+whenM mb mu = bool (pure ()) mu =<< mb
+
+contAsync :: (MonadUnliftIO m) => m a -> ContT r m ()
+contAsync = (link =<<) . ContT . withAsync
+
+orE :: (MonadError e m) => e -> Maybe b -> m b
+orE msg = maybe (throwError msg) pure
+
+orEM :: (MonadError e m) => e -> m (Maybe b) -> m b
+orEM msg mb = orE msg =<< mb
+
+leftE :: (MonadError e m) => (a -> e) -> Either a b -> m b
+leftE toe = either (throwError . toe) pure
+
+leftEM :: (MonadError e m) => (a -> e) -> m (Either a b) -> m b
+leftEM toe meab = leftE toe =<< meab
+
+peelMWith
+    :: (Monad m)
+    => (e -> m a)
+    -> (b -> Either e a)
+    -> m b
+    -> m a
+peelMWith ema bea mb = either ema pure . bea =<< mb
+
+newtype PrettyEither e a = PrettyEither (Either e a)
+
+instance
+    (Pretty e, Pretty a)
+    => Pretty (PrettyEither e a)
+    where
+    pretty (PrettyEither ea) = case ea of
+        Left e -> "Left" <+> pretty e
+        Right a -> "Right" <+> pretty a

examples/refchan-qblf/lib/RefChanQBLF/Impl.hs

@@ -0,0 +1,476 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# Language TemplateHaskell #-}
+{-# Language UndecidableInstances #-}
+{-# Language AllowAmbiguousTypes #-}
+module RefChanQBLF.Impl where
+
+import HBS2.Actors.Peer
+import HBS2.Actors.Peer.Types()
+import HBS2.Base58
+import HBS2.Data.Bundle
+import HBS2.Data.Detect
+import HBS2.Data.Types.Refs
+import HBS2.Data.Types.SignedBox
+import HBS2.Hash
+import HBS2.Merkle
+import HBS2.Net.Auth.Credentials
+import HBS2.Net.Messaging.Unix
+import HBS2.Net.Proto.QBLF
+import HBS2.Peer.Proto.AnyRef
+import HBS2.Peer.Proto.RefChan
+import HBS2.Prelude
+import HBS2.Storage.Simple
+import HBS2.System.Logger.Simple
+
+import RefChanQBLF.Common
+import RefChanQBLF.Transactions
+import Data.Config.Suckless
+import Control.Monad.Except
+import Control.Monad.Trans.Maybe
+import Codec.Serialise
+import Control.Monad.Reader
+import Data.ByteString.Lazy qualified as LBS
+import Data.List qualified as List
+import Lens.Micro.Platform hiding ((.=))
+import Options.Applicative hiding (info)
+import Data.HashSet qualified as HashSet
+import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HashMap
+import Data.Maybe
+import Data.Word
+import System.Random
+import UnliftIO
+
+import Data.Cache (Cache)
+import Data.Cache qualified as Cache
+
+{- HLINT ignore "Use newtype instead of data" -}
+
+-- TODO: config
+--  сделать конфиг, а то слишком много уже параметров в CLI
+
+data AppSocketOpt
+data RefChanOpt
+data SocketOpt
+data ActorOpt
+data DefStateOpt
+data StateRefOpt
+
+data QBLFRefKey
+type MyRefKey = AnyRefKey QBLFRefKey 'HBS2Basic
+
+instance HasCfgKey AppSocketOpt (Maybe String) where
+  key = "app-socket"
+
+instance HasCfgKey RefChanOpt (Maybe String)  where
+  key = "refchan"
+
+instance HasCfgKey SocketOpt (Maybe String)  where
+  key = "socket"
+
+instance HasCfgKey ActorOpt (Maybe String)  where
+  key = "actor"
+
+instance HasCfgKey DefStateOpt (Maybe String) where
+  key = "default-state"
+
+instance HasCfgKey StateRefOpt (Maybe String) where
+  key = "state-ref"
+
+class ToBalance s tx where
+  toBalance :: tx -> [(Account s, Amount)]
+
+tracePrefix :: SetLoggerEntry
+tracePrefix  = toStderr . logPrefix "[trace] "
+
+debugPrefix :: SetLoggerEntry
+debugPrefix  = toStderr . logPrefix "[debug] "
+
+errorPrefix :: SetLoggerEntry
+errorPrefix  = toStderr . logPrefix "[error] "
+
+warnPrefix :: SetLoggerEntry
+warnPrefix   = toStderr . logPrefix "[warn] "
+
+noticePrefix :: SetLoggerEntry
+noticePrefix = toStderr . logPrefix "[notice] "
+
+infoPrefix :: SetLoggerEntry
+infoPrefix = toStdout . logPrefix ""
+
+silently :: MonadIO m => m a -> m ()
+silently m = do
+  setLoggingOff @DEBUG
+  setLoggingOff @INFO
+  setLoggingOff @ERROR
+  setLoggingOff @WARN
+  setLoggingOff @NOTICE
+  void m
+
+withLogging :: MonadIO m => m a -> m ()
+withLogging m = do
+
+  -- setLogging @TRACE  tracePrefix
+  setLogging @DEBUG  debugPrefix
+  setLogging @INFO   infoPrefix
+  setLogging @ERROR  errorPrefix
+  setLogging @WARN   warnPrefix
+  setLogging @NOTICE noticePrefix
+
+  m
+
+  setLoggingOff @DEBUG
+  setLoggingOff @INFO
+  setLoggingOff @ERROR
+  setLoggingOff @WARN
+  setLoggingOff @NOTICE
+
+data MyEnv =
+  MyEnv
+  { mySelf  :: Peer UNIX
+  , myFab   :: Fabriq UNIX
+  , myChan  :: RefChanId UNIX
+  , myRef   :: MyRefKey
+  , mySto   :: AnyStorage
+  , myCred  :: PeerCredentials 'HBS2Basic
+  -- , myHttpPort :: Int
+  , myFetch :: Cache HashRef ()
+  }
+
+newtype MyAppT m a = MyAppT { fromQAppT :: ReaderT MyEnv m a }
+                  deriving newtype ( Functor
+                                   , Applicative
+                                   , Monad
+                                   , MonadIO
+                                   , MonadUnliftIO
+                                   , MonadReader MyEnv
+                                   , MonadTrans
+                                   )
+
+runMyAppT :: (MonadIO m, PeerMessaging UNIX) => MyEnv -> MyAppT m a -> m a
+runMyAppT env m = runReaderT (fromQAppT m) env
+
+instance Monad m => HasFabriq UNIX (MyAppT m) where
+  getFabriq = asks myFab
+
+instance Monad m => HasOwnPeer UNIX (MyAppT m) where
+  ownPeer = asks mySelf
+
+instance Monad m => HasStorage (MyAppT m) where
+  getStorage = asks mySto
+
+data ConsensusQBLF
+
+data StateQBLF = StateQBLF { fromStateQBLF :: HashRef }
+
+check :: MonadIO m => MyError -> Either e a -> ExceptT MyError m a
+check w  = \case
+  Right x -> ExceptT $ pure (Right x)
+  Left{}  -> ExceptT $ pure (Left w)
+
+fiasco :: MonadIO m => MyError -> ExceptT MyError m a
+fiasco x = ExceptT $ pure $ Left x
+
+ok :: MonadIO m => a -> ExceptT MyError m a
+ok x = ExceptT $ pure $ Right x
+
+
+type ForConsensus m = (MonadIO m, Serialise (QBLFMessage ConsensusQBLF))
+
+instance Serialise (QBLFMerge ConsensusQBLF)
+instance Serialise (QBLFMessage ConsensusQBLF)
+instance Serialise (QBLFAnnounce ConsensusQBLF)
+instance Serialise (QBLFCommit ConsensusQBLF)
+
+instance Monad m => HasTimeLimits UNIX (RefChanNotify UNIX) (MyAppT m) where
+  tryLockForPeriod _ _ = pure True
+
+instance (ForConsensus m, MonadUnliftIO m)  => IsQBLF ConsensusQBLF (MyAppT m) where
+  type QBLFActor ConsensusQBLF = Actor 'HBS2Basic
+  type QBLFTransaction ConsensusQBLF = QBLFDemoToken 'HBS2Basic
+  type QBLFState ConsensusQBLF = DAppState
+
+  qblfMoveForward _ s1 = do
+    env <- ask
+    fetchMissed env s1
+    pure True
+
+  qblfNewState (DAppState h0) txs = do
+    sto <- asks mySto
+    chan <- asks myChan
+    self <- asks mySelf
+    creds <- asks myCred
+    let sk = view peerSignSk creds
+    let pk = view peerSignPk creds
+
+    -- основная проблема в том, что мы пересортировываем весь state
+    -- однако, если считать его уже отсортированным, то, может быть,
+    -- все будет не так уж плохо.
+    -- так-то мы можем вообще его на диске держать
+
+    root <- if List.null txs then do
+              pure h0
+            else do
+              hashes <- liftIO $ mapM (putBlock sto . serialise) txs <&> catMaybes
+
+              current <- readLogThrow (getBlock sto) h0
+
+              let new = HashSet.fromList ( current <> fmap HashRef hashes )
+
+              let pt = toPTree (MaxSize 256) (MaxNum 256) (HashSet.toList new)
+
+              -- пробуем разослать бандлы с транзакциями
+              runMaybeT do
+                ref <- MaybeT $ createBundle sto (fmap HashRef hashes)
+                let refval = makeBundleRefValue @'HBS2Basic pk sk (BundleRefSimple ref)
+                r <- MaybeT $ liftIO $ putBlock sto (serialise refval)
+                lift $ request self (ActionRequest @UNIX chan (RefChanAnnounceBlock (HashRef r)))
+
+              r <- makeMerkle 0 pt $ \(hx,_,bs) -> do
+                _th <- liftIO (enqueueBlock sto bs)
+                debug $ "WRITE TX" <+> pretty hx
+
+              request self (ActionRequest @UNIX chan (RefChanAnnounceBlock (HashRef r)))
+
+              pure (HashRef r)
+
+    debug $ "PROPOSED NEW STATE:" <+> pretty root
+    pure $ DAppState root
+
+  qblfCommit s0 s1 = do
+    debug $ "COMMIT:" <+> pretty s0 <+> pretty s1
+    sto <- asks mySto
+    _chan <- asks myChan
+    ref  <- asks myRef
+
+    debug $ "UPDATING REF" <+> pretty ref <+> pretty s1
+    liftIO $ updateRef sto ref (fromHashRef (fromDAppState s1))
+    pure ()
+
+  qblfBroadCast msg = do
+      self <- asks mySelf
+      creds <- asks myCred
+      chan <- asks myChan
+
+      let sk = view peerSignSk creds
+      let pk = view peerSignPk creds
+      nonce <- randomIO @Word64 <&> serialise <&> LBS.toStrict
+      let box = makeSignedBox pk sk (LBS.toStrict (serialise msg) <> nonce)
+      let notify = Notify @UNIX chan box
+      request self notify
+
+      case msg of
+        QBLFMsgAnn _ (QBLFAnnounce _ _) -> do
+          -- TODO: maybe-announce-new-state-here
+          pure ()
+
+        _ -> none
+
+  -- TODO: optimize-qblf-merge
+  --   будет нормально работать до десятков/сотен тысяч транз,
+  --   а потом помрёт.
+  --   варианты:
+  --     1. перенести логику в БД
+  --     2. кэшировать всё, что можно
+  qblfMerge s0 s1 = do
+    chan <- asks myChan
+    _self <- asks mySelf
+
+    creds <- asks myCred
+    let _sk = view peerSignSk creds
+    let _pk = view peerSignPk creds
+
+    debug $ "MERGE. Proposed state:" <+> pretty s1
+
+    sto <- asks mySto
+    let readFn = liftIO . getBlock sto
+
+    tx1 <- mapM (readLogThrow readFn) (fmap fromDAppState s1) <&> mconcat
+    tx0 <- readLogThrow readFn (fromDAppState s0) <&> HashSet.fromList
+
+    let txNew = HashSet.fromList tx1 `HashSet.difference` tx0
+
+    if List.null txNew then do
+      pure s0
+    else do
+      debug $ "READ TXS" <+> pretty s1 <+> pretty (length tx1)
+
+      r <- forM tx1 $ \t -> runMaybeT do
+
+              -- игнорируем ранее добавленные транзакции
+              guard (not (HashSet.member t tx0))
+
+              bs <- MaybeT $ liftIO $ getBlock sto (fromHashRef t)
+
+              tx <- MaybeT $ pure $ deserialiseOrFail @(QBLFDemoToken 'HBS2Basic) bs & either (const Nothing) Just
+
+              case tx of
+                Emit box -> do
+                  (pk', e@(EmitTx a q _)) <- MaybeT $ pure $ unboxSignedBox0 @(EmitTx 'HBS2Basic) box
+                  guard ( chan == pk' )
+                  debug $ "VALID EMIT TRANSACTION" <+> pretty t <+> pretty (AsBase58 a) <+> pretty q
+                  pure ([(t,e)], mempty)
+
+                (Move box) -> do
+                  (_, m@(MoveTx _ _ qty _)) <- MaybeT $ pure $ unboxSignedBox0 @(MoveTx 'HBS2Basic) box
+
+                  guard (qty > 0)
+                  debug $ "MOVE TRANSACTION" <+> pretty t
+                  pure (mempty, [(t,m)])
+
+      let parsed = catMaybes r
+
+      let emits = foldMap (view _1) parsed
+
+      let moves = foldMap (view _2) parsed & List.sortOn fst
+
+      bal0 <- balances (fromDAppState s0)
+
+      -- баланс с учётом новых emit
+      let balE = foldMap (toBalance @'HBS2Basic. snd) emits
+                        & HashMap.fromListWith (+)
+                        & HashMap.unionWith (+) bal0
+
+      let moves' = updBalances @L4Proto balE moves
+
+      let merged = fmap fst emits <> fmap fst moves'
+
+      let pt = toPTree (MaxSize 256) (MaxNum 256) (HashSet.toList (tx0 <> HashSet.fromList merged))
+
+      root <- makeMerkle 0 pt $ \(_,_,bs) -> do
+                void $ liftIO (putBlock sto bs)
+
+      let new = DAppState (HashRef root)
+
+      -- FIXME: garbage-collect-discarded-states
+
+      async $ void $ balances (fromDAppState new)
+      debug $ "MERGED" <+> pretty new
+
+      pure new
+
+
+instance HasStorage (ReaderT AnyStorage IO) where
+  getStorage = ask
+
+
+
+instance ToBalance e (EmitTx e) where
+  toBalance (EmitTx a qty _) = [(a, qty)]
+
+instance ToBalance e (MoveTx e) where
+  toBalance (MoveTx a1 a2 qty _) = [(a1, -qty), (a2, qty)]
+
+balances :: forall e s m . ( e ~ L4Proto
+                           , MonadIO m
+                           , HasStorage m
+                           -- , FromStringMaybe (PubKey 'Sign s)
+                           , s ~ Encryption e
+                           , ToBalance s (EmitTx s)
+                           , ToBalance s (MoveTx s)
+                           , Pretty (AsBase58 (PubKey 'Sign s))
+                           )
+         => HashRef
+         -> m (HashMap (Account s) Amount)
+
+balances root = do
+  sto <- getStorage
+
+  let pk = SomeRefKey (HashRef "6ChGmfYkwM6646oKkj8r8MAjdViTsdtZSi6tgqk3tbh", root)
+
+  cached <- runMaybeT do
+    rval <- MaybeT $ liftIO $ getRef sto pk
+    val  <- MaybeT $ liftIO $ getBlock sto rval
+    MaybeT $ deserialiseOrFail @(HashMap (Account s) Amount) val
+          & either (const $ pure Nothing) (pure . Just)
+
+  case cached of
+    Just bal -> pure bal
+    Nothing -> do
+
+      txs <- readLogThrow (liftIO . getBlock sto) root
+
+      r <- forM txs $ \h -> runMaybeT do
+        blk <- MaybeT $ liftIO $ getBlock sto (fromHashRef h)
+        tx  <- MaybeT $ pure $ deserialiseOrFail @(QBLFDemoToken s) blk & either (const Nothing) Just
+
+        case tx of
+          Emit box -> do
+            (_, emit) <- MaybeT $ pure $  unboxSignedBox0 @(EmitTx s) box
+            pure $ toBalance @s emit
+
+          Move box -> do
+            (_, move) <- MaybeT $ pure $  unboxSignedBox0 @(MoveTx s) box
+            pure $ toBalance @s move
+
+      let val = catMaybes r & mconcat & HashMap.fromListWith (+)
+
+      runMaybeT do
+        checkComplete sto root >>= guard
+        rv <- MaybeT $ liftIO $ putBlock sto (serialise val)
+        liftIO $ updateRef sto pk rv
+
+      pure val
+
+
+-- TODO: optimize-upd-balances
+--  можно сгруппировать по аккаунтам
+--  и проверять только те транзакции, которые относятся
+--  к связанной (транзакциями) группе аккаунтов.
+--  то есть, разбить на кластеры, у которых отсутствуют пересечения по
+--  аккаунтам и проверять независимо и параллельно, например
+--  причем, прямо этой функцией
+--
+-- updBalances :: HashMap (Account L4Proto) Amount
+--              -> [(tx, b)]
+--              -> [(tx, b)]
+
+updBalances :: forall e s a tx . (ForRefChans e, ToBalance s tx, s ~ Encryption e)
+            => HashMap (Account s) Amount
+            -> [(a, tx)]
+            -> [(a, tx)]
+
+updBalances = go
+  where
+    go _bal [] = empty
+
+    go bal (t:rest) =
+
+      if good then
+        t : go nb rest
+      else
+        go bal rest
+
+      where
+        nb = HashMap.unionWith (+) bal (HashMap.fromList (toBalance @s (snd t)))
+        good = HashMap.filter (<0) nb & HashMap.null
+
+
+fetchMissed :: forall e w m . ( MonadIO m
+                              , Request e (RefChanNotify e) m
+                              , e ~ UNIX
+                              , w ~ ConsensusQBLF
+                              )
+            => MyEnv
+            -> QBLFState w
+            -> m ()
+
+fetchMissed env s = do
+  let tube = mySelf env
+  let chan = myChan  env
+  let cache = myFetch env
+  let sto = mySto env
+
+  let href = fromDAppState s
+
+  here <- liftIO $ hasBlock sto (fromHashRef href) <&> isJust
+  wip <- liftIO $ Cache.lookup cache href <&> isJust
+
+  when here do
+    liftIO $ Cache.delete cache href
+
+  unless (here || wip) do
+    debug $ "We might be need to fetch" <+> pretty s
+    liftIO $ Cache.insert cache href ()
+    request @UNIX tube (ActionRequest @UNIX chan (RefChanFetch (fromDAppState s)))
+

examples/refchan-qblf/lib/RefChanQBLF/RPCServer.hs

@@ -0,0 +1,141 @@
+{-# LANGUAGE StrictData #-}
+
+module RefChanQBLF.RPCServer where
+
+import HBS2.Actors.Peer
+import HBS2.Base58
+import HBS2.Data.Types.SignedBox
+import HBS2.Hash
+import HBS2.Net.Messaging.Unix
+import HBS2.Net.Proto.QBLF
+import HBS2.Net.Proto.Service
+import HBS2.System.Logger.Simple
+
+import Codec.Serialise
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.Reader
+import Data.ByteString.Lazy (ByteString)
+import Data.Function
+import Data.String.Conversions (cs)
+import Data.Text (Text)
+import Data.Text qualified as T
+import GHC.Generics (Generic)
+import Prettyprinter
+import UnliftIO
+
+import RefChanQBLF.Common
+import RefChanQBLF.Impl
+import RefChanQBLF.Transactions
+
+data PingRPC
+data PostTxRPC
+
+type QBLFAppRPC =
+    '[ PingRPC
+     , PostTxRPC
+     ]
+
+instance HasProtocol UNIX (ServiceProto QBLFAppRPC UNIX) where
+    type ProtocolId (ServiceProto QBLFAppRPC UNIX) = 0x0B1F0B1F
+    type Encoded UNIX = ByteString
+    decode = either (const Nothing) Just . deserialiseOrFail
+    encode = serialise
+
+type instance Input PingRPC = ()
+type instance Output PingRPC = Text
+
+type instance Input PostTxRPC = QBLFDemoToken 'HBS2Basic
+type instance Output PostTxRPC = Either RPCServerError (Either MyError Text)
+
+data QRPCEnv = QRPCEnv
+    { qrpcenvQConsensus :: QBLF ConsensusQBLF
+    , qrpcenvRefchanId :: PubKey 'Sign 'HBS2Basic
+    , qrpcenvFabriq :: Fabriq UNIX
+    , qrpcenvOwnPeer :: Peer UNIX
+    }
+
+newtype QRPCAppT m a = QRPCAppT {fromQRPCAppT :: ReaderT QRPCEnv m a}
+    deriving newtype
+        ( Functor
+        , Applicative
+        , Monad
+        , MonadIO
+        , MonadUnliftIO
+        , MonadReader QRPCEnv
+        , MonadTrans
+        )
+
+instance (Monad m) => HasFabriq UNIX (QRPCAppT m) where
+    getFabriq = asks qrpcenvFabriq
+
+instance (Monad m) => HasOwnPeer UNIX (QRPCAppT m) where
+    ownPeer = asks qrpcenvOwnPeer
+
+instance (Monad m) => HasQBLFEnv (ResponseM UNIX (QRPCAppT m)) where
+    getQBLFEnv = lift ask
+
+runQRPCT
+    :: (MonadIO m, PeerMessaging UNIX)
+    => QRPCEnv
+    -> QRPCAppT m a
+    -> m a
+runQRPCT env m = runReaderT (fromQRPCAppT m) env
+
+class HasQBLFEnv m where
+    getQBLFEnv :: m QRPCEnv
+
+data RPCServerError = RPCServerError Text
+    deriving (Generic, Show)
+instance Serialise RPCServerError
+
+wrapErrors :: (MonadUnliftIO m) => m a -> m (Either RPCServerError a)
+wrapErrors =
+    UnliftIO.tryAny >=> flip either (pure . Right) \e -> do
+        debug $ "RPC ServerError" <+> viaShow e
+        pure $ (Left . RPCServerError . T.pack . show) e
+
+instance (MonadIO m, HasQBLFEnv m) => HandleMethod m PingRPC where
+    handleMethod _ = do
+        debug $ "RPC PING"
+        pure "pong"
+
+instance
+    ( MonadUnliftIO m
+    , HasQBLFEnv m
+    )
+    => HandleMethod m PostTxRPC
+    where
+    handleMethod tok = wrapErrors $ UnliftIO.try do
+        let txhash = (hashObject @HbSync . serialise) tok
+            ptok = pretty tok
+
+        debug $ "RPC got post tx" <+> pretty txhash <+> ptok
+
+        refchanId <- qrpcenvRefchanId <$> getQBLFEnv
+        validateQBLFToken refchanId tok
+            & either throwIO pure
+
+        qblf <- qrpcenvQConsensus <$> getQBLFEnv
+        qblfEnqueue qblf tok
+
+        debug $ "TX ENQUEUED OK" <+> ptok
+        pure $ "Enqueued: " <> (cs . show) ptok
+
+validateQBLFToken
+    :: (MonadError MyError m)
+    => PubKey 'Sign 'HBS2Basic
+    -> QBLFDemoToken 'HBS2Basic
+    -> m ()
+validateQBLFToken chan = \case
+    Emit box -> do
+        (signer, _tx) <- orE SignatureError $ unboxSignedBox0 box
+        unless (signer == chan) do
+            throwError
+                ( SignerDoesNotMatchRefchan
+                    ((cs . show . pretty . AsBase58) signer)
+                    ((cs . show . pretty . AsBase58) chan)
+                )
+    Move box -> do
+        (_sign, _tx) <- orE SignatureError $ unboxSignedBox0 box
+        pure ()

examples/refchan-qblf/lib/RefChanQBLF/Transactions.hs

@@ -0,0 +1,199 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module RefChanQBLF.Transactions where
+
+import Data.String.Conversions (cs)
+import HBS2.Base58
+import HBS2.Data.Types.Refs (HashRef (..))
+import HBS2.Data.Types.SignedBox
+import HBS2.Hash
+import HBS2.Net.Auth.Credentials
+import HBS2.Net.Messaging.Unix (UNIX)
+import HBS2.Peer.Proto
+import HBS2.Prelude.Plated
+
+import Codec.Serialise
+import Control.Arrow hiding ((<+>))
+import Data.ByteString.Lazy (ByteString)
+import Data.Hashable (Hashable (..))
+import Data.Word (Word64)
+import System.Random
+
+import RefChanQBLF.Common
+
+newtype Actor s = Actor {fromActor :: PubKey 'Sign s}
+    deriving stock (Generic)
+
+deriving stock instance (Eq (PubKey 'Sign s)) => Eq (Actor s)
+deriving newtype instance (Hashable (PubKey 'Sign s)) => Hashable (Actor s)
+
+instance (Pretty (AsBase58 (PubKey 'Sign s))) => Pretty (Actor s) where
+    pretty (Actor a) = pretty (AsBase58 a)
+
+type Account s = PubKey 'Sign s
+
+newtype Amount = Amount Integer
+    deriving stock (Eq, Show, Ord, Data, Generic)
+    deriving newtype (Read, Enum, Num, Integral, Real, Pretty)
+
+newtype DAppState = DAppState {fromDAppState :: HashRef}
+    deriving stock (Eq, Show, Ord, Data, Generic)
+    deriving newtype (Hashable, Pretty)
+
+instance Hashed HbSync DAppState where
+    hashObject (DAppState (HashRef h)) = h
+
+data EmitTx s = EmitTx (Account s) Amount Word64
+    deriving stock (Generic)
+
+instance (Pretty (AsBase58 (PubKey 'Sign s))) => Pretty (EmitTx s) where
+    pretty (EmitTx acc amount n) =
+        "Emit"
+            <+> "to:"
+            <> pretty (AsBase58 acc)
+                <+> "amount:"
+            <> pretty amount
+                <+> "nonce:"
+            <> pretty n
+
+data MoveTx s = MoveTx (Account s) (Account s) Amount Word64
+    deriving stock (Generic)
+
+instance (Pretty (AsBase58 (PubKey 'Sign s))) => Pretty (MoveTx s) where
+    pretty (MoveTx accfrom accto amount n) =
+        "Move"
+            <+> "from:"
+            <> pretty (AsBase58 accfrom)
+                <+> "to:"
+            <> pretty (AsBase58 accto)
+                <+> "amount:"
+            <> pretty amount
+                <+> "nonce:"
+            <> pretty n
+
+data QBLFDemoToken s
+    = Emit (SignedBox (EmitTx s) s) --  proof: owner's  key
+    | Move (SignedBox (MoveTx s) s) --  proof: wallet's key
+    deriving stock (Generic)
+
+instance
+    ( Pretty (AsBase58 (PubKey 'Sign s))
+    , Signatures s
+    , Eq (Signature s)
+    , FromStringMaybe (PubKey 'Sign s)
+    , Serialise (PubKey 'Sign s)
+    , Serialise (Signature s)
+    , Hashable (PubKey 'Sign s)
+    )
+    => Pretty (QBLFDemoToken s)
+    where
+    pretty = \case
+        Emit box -> pretty (WhiteSignedBox @s box)
+        Move box -> pretty (WhiteSignedBox @s box)
+
+newtype WhiteSignedBox s a = WhiteSignedBox (SignedBox a s)
+
+instance
+    ( Pretty (AsBase58 (PubKey 'Sign s))
+    , Pretty a
+    , Serialise a
+    )
+    => Pretty (WhiteSignedBox s a)
+    where
+    pretty (WhiteSignedBox (SignedBox pk bs _sign)) =
+        "SignedBox"
+            <+> "Hash:"
+            <+> pretty ((hashObject @HbSync . serialise) bs)
+            <+> "SignedBy:"
+            <+> pretty (AsBase58 pk)
+            <+> "("
+            <> pretty ((PrettyEither . left show . deserialiseOrFail @a . cs) bs)
+            <> ")"
+
+instance (ForQBLFDemoToken s) => Serialise (Actor s)
+
+instance Serialise DAppState
+
+instance Serialise Amount
+
+instance (ForQBLFDemoToken s) => Serialise (EmitTx s)
+
+instance (ForQBLFDemoToken s) => Serialise (MoveTx s)
+
+instance (ForQBLFDemoToken s) => Serialise (QBLFDemoToken s)
+
+type ForQBLFDemoToken s =
+    ( Eq (PubKey 'Sign s)
+    , Eq (Signature s)
+    , Pretty (AsBase58 (PubKey 'Sign s))
+    , ForSignedBox s
+    , FromStringMaybe (PubKey 'Sign s)
+    , Serialise (PubKey 'Sign s)
+    , Serialise (Signature s)
+    , Hashable (PubKey 'Sign s)
+    )
+
+deriving stock instance (ForQBLFDemoToken s) => Eq (QBLFDemoToken s)
+
+instance (ForQBLFDemoToken s) => Hashable (QBLFDemoToken s) where
+    hashWithSalt salt = \case
+        Emit box -> hashWithSalt salt box
+        Move box -> hashWithSalt salt box
+
+newtype QBLFDemoTran e
+    = QBLFDemoTran (SignedBox (QBLFDemoToken (Encryption e)) (Encryption e))
+    deriving stock (Generic)
+
+instance (ForRefChans e) => Serialise (QBLFDemoTran e)
+
+deriving newtype instance
+    (Eq (PubKey 'Sign (Encryption e)), Eq (Signature (Encryption e)))
+    => Eq (QBLFDemoTran e)
+
+deriving newtype instance
+    (Eq (Signature (Encryption e)), ForRefChans e)
+    => Hashable (QBLFDemoTran e)
+
+instance HasProtocol UNIX (QBLFDemoTran UNIX) where
+    type ProtocolId (QBLFDemoTran UNIX) = 0xFFFF0001
+    type Encoded UNIX = ByteString
+    decode = either (const Nothing) Just . deserialiseOrFail
+    encode = serialise
+
+makeEmitDemoToken
+    :: forall s e m
+     . ( MonadIO m
+       , ForRefChans e
+       , ForQBLFDemoToken s
+       , Signatures (Encryption e)
+       , s ~ Encryption e
+       )
+    => PubKey 'Sign s
+    -> PrivKey 'Sign s
+    -> Account s
+    -> Amount
+    -> m (QBLFDemoToken s)
+makeEmitDemoToken pk sk acc amount = do
+    nonce <- randomIO
+    let box = makeSignedBox @s pk sk (EmitTx acc amount nonce)
+    pure (Emit @s box)
+
+makeMoveDemoToken
+    :: forall s e m
+     . ( MonadIO m
+       , ForQBLFDemoToken s
+       , ForRefChans e
+       , Signatures s
+       , s ~ Encryption e
+       )
+    => PubKey 'Sign s -- from pk
+    -> PrivKey 'Sign s -- from sk
+    -> Account s
+    -> Amount -- amount
+    -> m (QBLFDemoToken s)
+makeMoveDemoToken pk sk acc amount = do
+    nonce <- randomIO
+    let box = makeSignedBox @s pk sk (MoveTx pk acc amount nonce)
+    pure (Move @s box)

examples/refchan-qblf/refchan-qblf.cabal

@@ -19,6 +19,7 @@ common warnings
 common common-deps
     build-depends:
           base, hbs2-core, hbs2-peer, hbs2-storage-simple, hbs2-qblf
+        , hbs2-qblf
         , aeson
         , async
         , bytestring
@@ -57,6 +58,18 @@ common common-deps
         , interpolatedstring-perl6
         , unliftio
 
+        , attoparsec
+        , clock
+        , data-textual
+        , network
+        , network-ip
+        , optparse-applicative
+        , string-conversions
+        , text
+        , time
+
+
+
 common shared-properties
   ghc-options:
         -Wall
@@ -94,68 +107,48 @@ common shared-properties
                      , MultiParamTypeClasses
                      , OverloadedStrings
                      , QuasiQuotes
+                     , RecordWildCards
                      , ScopedTypeVariables
                      , StandaloneDeriving
                      , TupleSections
                      , TypeApplications
+                     , TypeOperators
                      , TypeFamilies
 
+library
+    import:           shared-properties
+    import:           common-deps
+
+    hs-source-dirs:   lib
+
+    exposed-modules:
+      RefChanQBLF.App
+      RefChanQBLF.CLI
+      RefChanQBLF.Common
+      RefChanQBLF.Impl
+      RefChanQBLF.RPCServer
+      RefChanQBLF.Transactions
+
 executable refchan-qblf
     import:           shared-properties
     import:           common-deps
-    default-language: Haskell2010
+
+    build-depends:
+        refchan-qblf
 
     ghc-options:
       -- -prof
       -- -fprof-auto
 
-    other-modules:
-      Demo.QBLF.Transactions
-
     -- other-extensions:
 
     -- type:             exitcode-stdio-1.0
-    hs-source-dirs:   app lib
-    main-is:          RefChanQBLFMain.hs
-
-    build-depends:
-          base, hbs2-core, hbs2-qblf, hbs2-storage-simple
-        , async
-        , attoparsec
-        , bytestring
-        , cache
-        , clock
-        , containers
-        , data-default
-        , data-textual
-        , directory
-        , hashable
-        , microlens-platform
-        , mtl
-        , mwc-random
-        , network
-        , network-ip
-        , optparse-applicative
-        , prettyprinter
-        , QuickCheck
-        , random
-        , safe
-        , serialise
-        , stm
-        , streaming
-        , tasty
-        , tasty-hunit
-        , text
-        , time
-        , transformers
-        , uniplate
-        , vector
-        , unliftio
-
+    hs-source-dirs:   app
+    main-is:          Main.hs
 
 test-suite refchan-qblf-proto-test
     import:           shared-properties
-    default-language: Haskell2010
+    import:           common-deps
 
     other-modules:
 

examples/site/bar.ss

@@ -0,0 +1,35 @@
+; это страница, на которую ссылается foo.ss
+
+(define (bar-page)
+
+[html :html [kw]
+ [html :head [kw]
+   [html :title [kw] Suckless HTML Page]
+   [html :meta [kw :charset UTF-8]]
+   [html :style [kw]
+     [css body [kw font-family sans-serif margin-left 20px max-width 1024px]]
+     [css table [kw border-collapse collapse width auto]]
+
+     [css (list td th) [kw border [sym (unwords 1px solid #ccc)]
+                           padding 8px
+                           text-align left]]
+
+     [css th [kw background-color #f2f2f2 white-space nowrap]]
+     [css .che [kw margin-right 8px]]
+   ]
+ ]
+
+ [html :body [kw]
+   [html :h1 [kw] Some other page]
+   [html :h2 [kw] Built with Suckless Script]
+
+   [html :p [kw] This is an example page generated using hbs2.]
+
+   Just some text
+
+ ]]
+
+)
+
+
+

examples/site/foo.ss

@@ -0,0 +1,96 @@
+; это наш "сайт" -- poo.ss
+
+; просто какой-то левый json
+[define source [json:file miscellaneous/fuzzy-parse/nix/pkgs.json]]
+
+(define (foo-page bar)
+
+[html :html [kw]
+  [html :head [kw]
+    [html :title [kw] Suckless HTML Page]
+    [html :meta [kw :charset UTF-8]]
+    [html :style [kw]
+      [css body [kw font-family sans-serif margin-left 20px max-width 1024px]]
+      [css table [kw border-collapse collapse width auto]]
+
+      [css (list td th) [kw border [sym (unwords 1px solid #ccc)]
+                            padding 8px
+                            text-align left]]
+
+      [css th [kw background-color #f2f2f2 white-space nowrap]]
+      [css .che [kw margin-right 8px]]
+    ]
+  ]
+
+  [html :body [kw]
+    [html :h1 [kw] Super Cool HBS2 Suckless Script Example Page]
+    [html :h2 [kw] Built with Suckless Script]
+
+    [html :p [kw] This is an example page generated using hbs2.]
+
+    [html :p [kw] [html :a [kw href [concat ../../tree/ bar]] Referes to bar ] ]
+
+    [html :form [kw action # method POST]
+      [html :label [kw for cb1]
+        [html :input [kw :type checkbox name checkbox1 :id cb1 :class che]]
+        I agree with the terms
+      ]
+      [html :br]
+      [html :input [kw :type text :name username :placeholder "Enter your name"]]
+      [html :br]
+      [html :input [kw :type submit :value Submit]]
+    ]
+
+    [html :br]
+
+    [html :p [kw]
+      This text contains
+
+      [html :b [kw] bold]
+
+      chr:comma
+
+      [html :i [kw] italic]
+
+      :and
+
+      [html :u [kw] :underlined]
+
+      styles.
+    ]
+
+    [html :br]
+
+    ; Unicode test section
+    [html :p [kw] Russian: Привет, мир!]
+    [html :p [kw] Chinese: 你好，世界！]
+    [html :p [kw] Korean: 안녕하세요, 세계!]
+
+    [html :br]
+
+    [html :table [kw]
+      [html :thead [kw]
+        [html :tr [kw]
+          [html :th [kw] Package]
+          [html :th [kw] Version]
+        ]
+      ]
+
+      [html :tbody [kw]
+        [map [fn 1 [html :tr [kw] [html :th [kw] [car _1]]
+                   [html :td [kw] [nth 1 _1]]  ] ] source]
+      ]
+    ]
+
+    [html :br]
+
+    [html :p [kw]
+      For more information, visit
+      [html :a [kw href http://example.com] our website]
+      "."
+    ]
+  ]
+]
+
+)
+

examples/site/site.ss

@@ -0,0 +1,44 @@
+
+; [eval [cons :begin [top:file bar.ss]]]
+
+(import bar.ss)
+(import foo.ss)
+
+(define site-root-ref :4X65y4YvUjRL2gtA9Ec3YDDP4bnxjTGhfjpoah96t3z1)
+
+(define (as-html n) [kw :file-name n :mime-type "text/html; charset=utf-8"]) ; метаданные что бы hbs2-peer отображал как вебстраницу
+
+(define bar.html (bar-page)) ; генерим страничку
+
+(define bar.hash (hbs2:tree:metadata:string [as-html :bar.html] bar.html)) ; сохраняем как дерево с метаданными
+
+(define foo.html (foo-page bar.hash))
+
+(define foo.hash (hbs2:tree:metadata:string [as-html :foo.html] foo.html)) ; сохраняем как дерево с метаданными
+
+(define grove [hbs2:grove:annotated [kw webroot foo.hash] [list foo.hash bar.hash]])
+
+; println :bar.html space "hash:" space bar.hash
+
+println Grove: space grove ; hello.hash
+
+hbs2:lwwref:update site-root-ref grove
+
+; newline
+
+; print [hbs2:lwwref:get site-root-ref]
+
+(define url [sym [join / http://localhost:5000/ref site-root-ref]]) ; вычисляем url
+
+; newline
+
+; print url
+
+; print bar.html
+
+; print foo.html
+
+; print site-root-ref
+
+(call:proc "firefox" url) ; вызываем фарфокс
+

fixme-new/LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2023, 
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of  nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

fixme-new/README.md

@@ -0,0 +1,22 @@
+
+
+## The new glorious fixme
+
+This is a new fixme implementation! It's a re-implementation
+of fixme aiming for using multiple sources for issues, not
+only git repo, and able to share the state via hbs2
+privimites.
+
+It will replace the old good fixme and will reuse all the
+code from there that could be re-used.
+
+It's indendent to be mostly compatible with the old
+fixme, but we will see.
+
+The binary is called fixme-new in order not to be confused
+with old fixme, but it's only for a while.
+
+It will be replaced as soon, as this fixme will be fully
+operational.
+
+

fixme-new/app/FixmeMain.hs

@@ -0,0 +1,8 @@
+module Main where
+
+import Fixme.Run
+
+main :: IO ()
+main = do
+  runFixmeCLI runCLI
+

fixme-new/examples/config

@@ -0,0 +1,61 @@
+
+; fixme-files **/*.hs docs/devlog.md
+
+; no-debug
+; debug
+
+fixme-prefix     FIXME:
+fixme-prefix     TODO:
+fixme-prefix     PR:
+fixme-prefix     REVIEW:
+
+fixme-git-scan-filter-days 30
+
+fixme-attribs assigned workflow type
+
+fixme-attribs resolution cat scope
+
+fixme-value-set workflow new backlog wip test fixed done
+
+; fixme-value-set cat bug feat refactor
+
+fixme-value-set scope mvp-0 mvp-1 backlog
+
+fixme-files **/*.txt docs/devlog.md
+fixme-files **/*.hs
+
+fixme-file-comments "*.scm" ";"
+
+fixme-comments ";" "--"
+
+(define-template short
+  (quot
+    (simple
+         (trim 10  $fixme-key) " "
+
+         (if (~ FIXME $fixme-tag)
+          (then (fgd red (align 6  $fixme-tag))  )
+          (else (if (~ TODO $fixme-tag)
+                  (then (fgd green (align 6  $fixme-tag)))
+                  (else (align 6  $fixme-tag)) ) )
+          )
+
+
+         (align 10  ("[" $workflow "]"))  " "
+         (align 8  $type)  " "
+         (align 12 $assigned)  " "
+         (align 20 (trim 20 $committer-name)) " "
+         (trim 50  ($fixme-title)) " "
+         (nl))
+    )
+)
+
+(set-template default short)
+
+(define (ls) (report))
+
+(define (ls:wip) (report workflow ~ wip))
+
+(define (stage) (fixme:stage:show))
+
+

fixme-new/examples/config-fixme-new-config

@@ -0,0 +1,6 @@
+
+fixme-pager (quot (bat  "--file-name" $file "-H" $before))
+
+fixme-def-context 2 5
+
+

fixme-new/fixme.cabal

@@ -1,12 +1,11 @@
 cabal-version:      3.0
-name:               hbs2-git
-version:            0.24.1.1
--- synopsis:
+name:               fixme-new
+version:            0.25.0.1
+synopsis: reimplemented fixme
 -- description:
 license:            BSD-3-Clause
 license-file:       LICENSE
 author:             Dmitry Zuikov
-maintainer:         dzuikov@gmail.com
 -- copyright:
 category:           System
 build-type:         Simple
@@ -56,10 +55,15 @@ common shared-properties
         hbs2-core
       , hbs2-peer
       , hbs2-storage-simple
-      , hbs2-keyman
+      , hbs2-keyman-direct-lib
+      , hbs2-git3
+      , hbs2-cli
       , db-pipe
       , suckless-conf
+      , fuzzy-parse
 
+      , aeson
+      , aeson-pretty
       , attoparsec
       , atomic-write
       , bytestring
@@ -69,15 +73,20 @@ common shared-properties
       , exceptions
       , filepath
       , filepattern
+      , generic-lens
+      , generic-deriving
       , interpolatedstring-perl6
       , memory
       , microlens-platform
       , mtl
       , safe
       , serialise
+      , scientific
       , streaming
       , stm
+      , split
       , text
+      , temporary
       , time
       , timeit
       , transformers
@@ -91,80 +100,47 @@ common shared-properties
       , random
       , vector
       , unix
+      , uuid
 
 
 library
     import:           shared-properties
 
+    other-modules:
+      Fixme.Run.Internal
+      Fixme.Run.Internal.RefChan
+
     exposed-modules:
-      HBS2.Git.Local
-      HBS2.Git.Local.CLI
-
-      HBS2.Git.Data.Tx
-      HBS2.Git.Data.GK
-      HBS2.Git.Data.RefLog
-      HBS2.Git.Data.LWWBlock
-
-      HBS2.Git.Client.Prelude
-      HBS2.Git.Client.App.Types
-      HBS2.Git.Client.App.Types.GitEnv
-      HBS2.Git.Client.App
-      HBS2.Git.Client.Config
-      HBS2.Git.Client.State
-      HBS2.Git.Client.RefLog
-      HBS2.Git.Client.Export
-      HBS2.Git.Client.Import
-      HBS2.Git.Client.Progress
+      Fixme
+      Fixme.Config
+      Fixme.Run
+      Fixme.Types
+      Fixme.Prelude
+      Fixme.State
+      Fixme.Scan
+      Fixme.Scan.Git.Local
+      Fixme.GK
 
     build-depends:    base
                     , base16-bytestring
                     , binary
                     , unix
 
-    hs-source-dirs:   hbs2-git-client-lib
+    hs-source-dirs:  lib
 
 
-executable hbs2-git-subscribe
+executable fixme-new
     import:           shared-properties
-    main-is:          Main.hs
+    main-is:          FixmeMain.hs
     -- other-modules:
     -- other-extensions:
     build-depends:
-        base, hbs2-git
+        base, fixme-new, hbs2-core, hbs2-peer
         , binary
         , vector
         , optparse-applicative
 
-    hs-source-dirs:   git-hbs2-subscribe
-    default-language: GHC2021
-
-executable git-hbs2
-    import:           shared-properties
-    main-is:          Main.hs
-    -- other-modules:
-    -- other-extensions:
-    build-depends:
-        base, hbs2-git
-        , binary
-        , vector
-        , optparse-applicative
-
-    hs-source-dirs:   git-hbs2
-    default-language: GHC2021
-
-
-executable git-remote-hbs2
-    import:           shared-properties
-    main-is:          Main.hs
-    -- other-modules:
-    -- other-extensions:
-    build-depends:
-        base, hbs2-git
-        , binary
-        , vector
-        , optparse-applicative
-
-    hs-source-dirs:   git-remote-hbs2
+    hs-source-dirs:   app
     default-language: GHC2021
 
 

fixme-new/lib/Fixme.hs

@@ -0,0 +1,8 @@
+module Fixme
+  ( module Fixme.Types
+  , module Fixme.Prelude
+  ) where
+
+import Fixme.Prelude
+import Fixme.Types
+

fixme-new/lib/Fixme/Config.hs

@@ -0,0 +1,41 @@
+module Fixme.Config where
+
+import Fixme.Prelude
+import Fixme.Types
+
+import HBS2.System.Dir
+import System.Environment
+import System.Directory (getXdgDirectory, XdgDirectory(..))
+
+binName :: FixmePerks m => m FilePath
+binName = pure "fixme-new" -- liftIO getProgName
+
+localConfigDir :: (FixmePerks m, MonadReader FixmeEnv m) =>  m FilePath
+localConfigDir = do
+  p <- asks fixmeEnvWorkDir >>= readTVarIO
+  b <- binName
+  pure (p </> ("." <> b))
+
+fixmeWorkDir :: (FixmePerks m, MonadReader FixmeEnv m) => m FilePath
+fixmeWorkDir = asks fixmeEnvWorkDir >>= readTVarIO
+
+localConfig:: (FixmePerks m, MonadReader FixmeEnv m) => m FilePath
+localConfig = localConfigDir <&> (</> "config")
+
+userConfigs :: FixmePerks m => m [FilePath]
+userConfigs= do
+  bin <- binName
+  h <- home
+  xdg <- liftIO (getXdgDirectory XdgConfig bin)
+
+  let conf1 = h </> ("." <> bin)
+  let conf2 = xdg </> "config"
+
+  pure [conf2, conf1]
+
+localDBName :: FilePath
+localDBName = "state.db"
+
+localDBPath :: (FixmePerks m, MonadReader FixmeEnv m) => m FilePath
+localDBPath = localConfigDir <&> (</> localDBName)
+

fixme-new/lib/Fixme/GK.hs

@@ -0,0 +1,96 @@
+{-# Language MultiWayIf #-}
+module Fixme.GK where
+
+import Fixme.Prelude
+import Fixme.Config
+import Fixme.Types
+
+import HBS2.OrDie
+-- import HBS2.System.Dir
+import HBS2.Storage.Operations.ByteString
+import HBS2.Storage.Operations.Class
+
+import HBS2.Net.Auth.GroupKeySymm
+import HBS2.Peer.Proto.RefChan as RefChan
+import HBS2.System.Dir
+-- import HBS2.Net.Auth.Credentials
+
+import Control.Monad.Trans.Maybe
+import Data.HashSet qualified as HS
+import Data.HashMap.Strict qualified as HM
+import Data.Maybe
+import Lens.Micro.Platform
+
+data GroupKeyOpError =
+    NoRefChanHead
+  | NoReadersSet
+  | GKLoadFailed
+  deriving (Eq,Ord,Show,Typeable)
+
+instance Exception GroupKeyOpError
+
+
+groupKeyFile :: forall m . (FixmePerks m, MonadReader FixmeEnv m) => m FilePath
+groupKeyFile = do
+  dir <- localConfigDir
+  pure $ dir </> "gk0"
+
+-- TODO: rotate-group-key
+
+loadGroupKey :: forall s m . (s ~ 'HBS2Basic, FixmePerks m) => FixmeM m (Maybe (HashRef, GroupKey 'Symm s))
+loadGroupKey = do
+
+  sto <- getStorage
+  gkF <- groupKeyFile
+
+  runMaybeT do
+
+    rchan <- lift (asks fixmeEnvRefChan >>= readTVarIO) >>= toMPlus
+
+    rch <- getRefChanHead @L4Proto sto (RefChanHeadKey rchan)
+             >>= orThrow NoRefChanHead
+
+    guard ( not $ HS.null (view refChanHeadReaders  rch) )
+
+    flip fix 0 $ \next -> \case
+
+      attempt | attempt > 2 -> throwIO GKLoadFailed
+
+      attempt -> do
+
+        let readers = view refChanHeadReaders rch
+
+        gkHash <- liftIO (try @_ @IOError $ readFile gkF)
+                    <&> either (const Nothing) ( (=<<) (fromStringMay @HashRef) . headMay . lines )
+
+        debug $ "GK0" <+> pretty gkHash
+
+        case gkHash of
+          Nothing -> do
+            debug "generate new group key"
+            gknew <- generateGroupKey @'HBS2Basic Nothing (HS.toList readers)
+            ha <- writeAsMerkle sto (serialise gknew)
+            liftIO $ writeFile gkF (show $ pretty ha)
+            next (succ attempt)
+
+          Just h -> do
+            now <- liftIO $ getPOSIXTime <&> round
+            gk' <- loadGroupKeyMaybe @s sto h
+
+            (_,gk) <- maybe1 gk' (rm gkF >> next (succ attempt)) (pure . (h,))
+
+            let ts = getGroupKeyTimestamp gk & fromMaybe 0
+
+            -- FIXME: timeout-hardcode
+            --   $class: hardcode
+            if | now - ts > 2592000 -> do
+                 rm gkF
+                 next (succ attempt)
+
+               | HM.keysSet (recipients gk) /= readers -> do
+                 rm gkF
+                 next (succ attempt)
+
+               | otherwise -> do
+                  pure (h,gk)
+

fixme-new/lib/Fixme/Prelude.hs

@@ -0,0 +1,24 @@
+module Fixme.Prelude
+  ( module All
+  , GitHash(..)
+  , GitRef(..)
+  , Serialise(..)
+  , serialise, deserialiseOrFail, deserialise
+  , module Exported
+  ) where
+
+import HBS2.Prelude.Plated as All
+import HBS2.Hash as All
+import HBS2.Data.Types.Refs as All
+import HBS2.Misc.PrettyStuff as All
+import HBS2.System.Logger.Simple.ANSI as All
+import HBS2.Git.Local (GitHash(..),GitRef(..))
+import Codec.Serialise (Serialise(..),serialise,deserialise,deserialiseOrFail)
+import Data.Functor as All
+import Data.Function as All
+import UnliftIO as All
+import System.FilePattern as All
+import Control.Monad.Reader as All
+
+import Data.Config.Suckless.Script as Exported
+

fixme-new/lib/Fixme/Run.hs

@@ -0,0 +1,592 @@
+module Fixme.Run where
+
+import Prelude hiding (init)
+import Fixme.Prelude hiding (indent)
+import Fixme.Types
+import Fixme.Config
+import Fixme.State
+import Fixme.Run.Internal
+import Fixme.Run.Internal.RefChan
+import Fixme.Scan.Git.Local as Git
+import Fixme.Scan as Scan
+import Fixme.GK as GK
+
+import Data.Config.Suckless.Script.File
+
+import HBS2.KeyMan.Keys.Direct
+
+import HBS2.Git.Local.CLI
+import HBS2.Peer.Proto.RefChan.Types
+
+import HBS2.CLI.Run.KeyMan (keymanNewCredentials)
+
+import HBS2.OrDie
+import HBS2.Peer.CLI.Detect
+import HBS2.Net.Auth.GroupKeySymm
+import HBS2.Data.Types.SignedBox
+import HBS2.Base58
+import HBS2.Storage.Operations.ByteString
+import HBS2.Net.Auth.Credentials
+import HBS2.Merkle
+import HBS2.Data.Types.Refs
+import HBS2.Storage
+import HBS2.Storage.Compact
+import HBS2.System.Dir
+import DBPipe.SQLite hiding (field)
+import Data.Config.Suckless
+
+import Data.Aeson.Encode.Pretty as Aeson
+import Data.ByteString (ByteString)
+import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString.Lazy.Char8 qualified as LBS8
+import Data.Either
+import Data.Maybe
+import Data.HashSet qualified as HS
+import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HM
+import Data.HashSet (HashSet)
+import Data.Set qualified as Set
+import Data.Generics.Product.Fields (field)
+import Data.List qualified as List
+import Data.Text qualified as Text
+import Data.Text.IO qualified as Text
+import Text.InterpolatedString.Perl6 (qc)
+import Data.Coerce
+import Control.Monad.Identity
+import Lens.Micro.Platform
+import System.Environment
+import System.Process.Typed
+import Control.Monad
+import Control.Monad.Trans.Cont
+import Control.Monad.Trans.Maybe
+import System.IO.Temp qualified as Temp
+import System.IO qualified as IO
+
+import Streaming.Prelude qualified as S
+
+{- HLINT ignore "Functor law" -}
+
+
+recover :: (FixmePerks m) => FixmeEnv -> m a -> m a
+recover env m = flip fix 0 $ \next attempt
+    -> do m
+        `catch` (\PeerNotConnected  -> do
+                    if attempt < 1 then do
+                      runWithRPC env $ next (succ attempt)
+                    else do
+                      throwIO PeerNotConnected
+               )
+
+withFixmeCLI :: (FixmePerks m, MonadReader FixmeEnv m) => FixmeEnv -> FixmeM m a -> m a
+withFixmeCLI env m = do
+  recover env do
+    withFixmeEnv env m
+
+runWithRPC :: (FixmePerks m) => FixmeEnv ->  m a -> m a
+runWithRPC FixmeEnv{..} m = do
+
+  soname <- detectRPC
+              `orDie` "can't locate hbs2-peer rpc"
+
+  flip runContT pure do
+
+    client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname)
+                >>= orThrowUser ("can't connect to" <+> pretty soname)
+
+    void $ ContT $ withAsync $ runMessagingUnix client
+
+    peerAPI    <- makeServiceCaller @PeerAPI (fromString soname)
+    refChanAPI <- makeServiceCaller @RefChanAPI (fromString soname)
+    storageAPI <- makeServiceCaller @StorageAPI (fromString soname)
+
+    let endpoints = [ Endpoint @UNIX  peerAPI
+                    , Endpoint @UNIX  refChanAPI
+                    , Endpoint @UNIX  storageAPI
+                    ]
+
+    void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
+
+
+    let newEnv = Just (MyPeerClientEndpoints soname peerAPI refChanAPI storageAPI)
+    liftIO $ atomically $ writeTVar fixmeEnvMyEndpoints newEnv
+    lift m
+
+runFixmeCLI :: forall a m . FixmePerks m => FixmeM m a -> m a
+runFixmeCLI m = do
+  git <- findGitDir
+  env <- FixmeEnv
+            <$>  newMVar ()
+            <*>  newTVarIO mempty
+            <*>  (pwd >>= newTVarIO)
+            <*>  newTVarIO Nothing
+            <*>  newTVarIO git
+            <*>  newTVarIO mempty
+            <*>  newTVarIO mempty
+            <*>  newTVarIO mempty
+            <*>  newTVarIO builtinAttribs
+            <*>  newTVarIO builtinAttribVals
+            <*>  newTVarIO mempty
+            <*>  newTVarIO defCommentMap
+            <*>  newTVarIO Nothing
+            <*>  newTVarIO mzero
+            <*>  newTVarIO mempty
+            <*>  newTVarIO mempty
+            <*>  newTVarIO defaultCatAction
+            <*>  newTVarIO defaultTemplate
+            <*>  newTVarIO mempty
+            <*>  newTVarIO (1,3)
+            <*>  newTVarIO mzero
+            <*>  newTVarIO mzero
+            <*>  newTVarIO mzero
+            <*>  newTVarIO mzero
+            <*>  newTVarIO mempty
+
+  -- FIXME: defer-evolve
+  --   не все действия требуют БД,
+  --   хорошо бы, что бы она не создавалась,
+  --   если не требуется
+  recover env do
+    runReaderT ( setupLogger >> fromFixmeM (handle @_ @SomeException (err . viaShow) evolve >> m) ) env
+                   `finally` flushLoggers
+  where
+    setupLogger = do
+      setLogging @ERROR  $ toStderr . logPrefix "[error] "
+      setLogging @WARN   $ toStderr . logPrefix "[warn] "
+      setLogging @NOTICE $ toStdout . logPrefix ""
+      pure ()
+
+    flushLoggers = do
+      silence
+
+    -- FIXME: tied-fucking-context
+    defaultCatAction = CatAction $ \dict lbs -> do
+      LBS.putStr lbs
+      pure ()
+
+silence :: FixmePerks m => m ()
+silence = do
+  setLoggingOff @DEBUG
+  setLoggingOff @ERROR
+  setLoggingOff @WARN
+  setLoggingOff @NOTICE
+  setLoggingOff @TRACE
+
+
+readConfig :: (FixmePerks m) => FixmeM m [Syntax C]
+readConfig = do
+
+  user <- userConfigs
+  lo   <- localConfig
+
+  w <- for (lo : user) $ \conf -> do
+    try @_ @IOException (liftIO $ readFile conf)
+      <&> fromRight mempty
+      <&> parseTop
+      >>= either (error.show) pure
+
+  updateScanMagic
+
+  pure $ mconcat w
+
+
+runCLI :: FixmePerks m => FixmeM m ()
+runCLI = do
+  argz <- liftIO getArgs
+  forms <- parseTop (unlines $ unwords <$> splitForms argz)
+           & either  (error.show) pure
+
+  runTop forms
+
+
+runTop :: forall m . FixmePerks m => [Syntax C] -> FixmeM m ()
+runTop forms = do
+
+  tvd  <- newTVarIO mempty
+
+  let dict = makeDict @C do
+
+       internalEntries
+
+       entry $ bindMatch "--help" $ nil_ \case
+         HelpEntryBound what -> helpEntry what
+         [StringLike s]      -> helpList False (Just s)
+         _                   -> helpList False Nothing
+
+       entry $ bindMatch "fixme-prefix" $ nil_ \case
+        [StringLike pref] -> do
+
+          t <- lift $ asks fixmeEnvTags
+          atomically (modifyTVar t (HS.insert (FixmeTag $ fromString pref)))
+
+        _ -> throwIO $ BadFormException @C nil
+
+
+       entry $ bindMatch "fixme-attribs" $ nil_ \case
+        StringLikeList xs -> do
+          ta <- lift $ asks fixmeEnvAttribs
+          atomically $ modifyTVar ta (<> HS.fromList (fmap fromString xs))
+
+        _ -> throwIO $ BadFormException @C nil
+
+
+       entry $ bindMatch "fixme-files" $ nil_ \case
+        StringLikeList xs -> do
+          w <- lift fixmeWorkDir
+          t <- lift $ asks fixmeEnvFileMask
+          atomically (modifyTVar t (<> fmap (w </>) xs))
+
+        _ -> throwIO $ BadFormException @C nil
+
+       entry $ bindMatch "fixme-exclude" $ nil_ \case
+        StringLikeList xs -> do
+          w <- lift fixmeWorkDir
+          t <- lift $ asks fixmeEnvFileExclude
+          atomically (modifyTVar t (<> fmap (w </>) xs))
+
+        _ -> throwIO $ BadFormException @C nil
+
+       entry $ bindMatch "fixme-file-comments" $ nil_ $ \case
+         [StringLike ft, StringLike b] -> do
+            let co = Text.pack b & HS.singleton
+            t <- lift $ asks fixmeEnvFileComments
+            atomically (modifyTVar t (HM.insertWith (<>) (commentKey ft) co))
+
+         _ -> throwIO $ BadFormException @C nil
+
+       entry $ bindMatch "fixme-comments" $ nil_  \case
+         (StringLikeList xs) -> do
+            t <- lift $ asks fixmeEnvDefComments
+            let co = fmap Text.pack xs & HS.fromList
+            atomically $ modifyTVar t (<> co)
+
+         _ -> throwIO $ BadFormException @C nil
+
+       entry $ bindMatch  "fixme-value-set" $ nil_ \case
+         (StringLike n : StringLikeList xs)  -> do
+           t <- lift $ asks fixmeEnvAttribValues
+           let name = fromString n
+           let vals = fmap fromString xs & HS.fromList
+           atomically $ modifyTVar t (HM.insertWith (<>) name vals)
+
+         _ -> throwIO $ BadFormException @C nil
+
+       entry $ bindMatch "fixme-pager" $ nil_ \case
+         [ListVal cmd0] -> do
+            t <- lift $ asks fixmeEnvCatAction
+            let action =  CatAction $ \dict lbs -> do
+
+                  let ccmd = case inject dict cmd0 of
+                               (StringLike p : StringLikeList xs) -> Just (p, xs)
+                               _  -> Nothing
+
+
+                  debug $ pretty ccmd
+
+                  maybe1 ccmd none $ \(p, args) -> do
+
+                    let input = byteStringInput lbs
+                    let cmd = setStdin input $ setStderr closed
+                                             $ proc p args
+
+                    void $ runProcess cmd
+
+            atomically $ writeTVar t action
+
+         _ -> throwIO $ BadFormException @C nil
+
+       entry $ bindMatch "fixme-def-context" $ nil_ \case
+        [LitIntVal a, LitIntVal b] -> do
+          t <- lift $ asks fixmeEnvCatContext
+          atomically $ writeTVar t (fromIntegral a, fromIntegral b)
+
+        _ -> throwIO $ BadFormException @C nil
+
+
+       entry $ bindMatch "modify" $ nil_ \case
+        [ FixmeHashLike w, StringLike k, StringLike v ] -> lift do
+          void $ runMaybeT do
+            key <- lift (selectFixmeKey w) >>= toMPlus
+            lift $ modifyFixme key [(fromString k, fromString v)]
+
+        _ -> throwIO $ BadFormException @C nil
+
+
+       entry $ bindMatch "delete" $ nil_ \case
+        [ FixmeHashLike w ] -> lift do
+          void $ runMaybeT do
+            key <- lift (selectFixmeKey w) >>= toMPlus
+            lift $ modifyFixme key [("deleted", "true")]
+
+        _ -> throwIO $ BadFormException @C nil
+
+
+       entry $ bindMatch "cat" $ nil_ $ \case
+        [ FixmeHashLike w ] -> lift do
+          cat_ w
+
+        _ -> throwIO $ BadFormException @C nil
+
+
+       entry $ bindMatch "create" $ nil_ $ \syn -> do
+
+        me' <- lookupValue "me"
+
+        me <- case me' of
+                StringLike who -> pure who
+                _ -> do
+                  user    <- liftIO $ lookupEnv "USER" <&> fromMaybe "stranger"
+                  try @_ @SomeException (readProcess (shell [qc|git config user.name|]))
+                               <&> either (const user) (headDef user . lines . LBS8.unpack . view _2)
+
+        let title = case syn of
+                        StringLikeList xs -> unwords xs
+                        _ -> "new-issue"
+
+        lift $ edit_ (Left (me,title))
+
+       entry $ bindMatch "edit" $ nil_ $ \case
+        [ FixmeHashLike w] -> lift $ void $ runMaybeT do
+          key <- lift (selectFixmeKey w) >>= toMPlus
+          fme <- lift (getFixme key) >>= toMPlus
+          lift $ edit_ (Right fme)
+
+        _ -> throwIO $ BadFormException @C nil
+
+       entry $ bindMatch "dump" $ nil_ $ \case
+        [ FixmeHashLike w ] -> lift $ void $ runMaybeT do
+          key <- lift (selectFixmeKey w) >>= toMPlus
+          fme <- lift $ getFixme key
+          liftIO $ print $ pretty fme
+
+        _ -> throwIO $ BadFormException @C nil
+          -- magic <- lift $ asks fixmeEnvScanMagic >>= readTVarIO
+          -- liftIO $ print $ pretty magic
+
+
+       entry $ bindMatch "report" $ nil_ $ lift . \case
+        ( SymbolVal "template" : StringLike t : p )  -> do
+          report (Just t) p
+
+        ( SymbolVal "--template" : StringLike t : p )  -> do
+          report (Just t) p
+
+        p -> do
+          report Nothing p
+
+       entry $ bindMatch "fixme:key:show" $ nil_ \case
+        [ FixmeHashLike w ] -> lift $ void $ runMaybeT do
+          key <- lift (selectFixmeKey w) >>= toMPlus
+          liftIO $ print $ pretty key
+
+        _ -> throwIO $ BadFormException @C nil
+
+       entry $ bindMatch "fixme:scan-magic" $ nil_ $ const do
+          magic <- lift $ asks fixmeEnvScanMagic >>= readTVarIO
+          liftIO $ print $ pretty magic
+
+       entry $ bindMatch "fixme:gk:show" $ nil_ $ const do
+        w <- lift loadGroupKey
+        case w of
+          Just (h,_) -> do
+            liftIO $ print $ pretty h
+          _ -> do
+            liftIO $ print $ pretty "none"
+
+       entry $ bindMatch "fixme:path" $ nil_ $ const do
+          path <- lift fixmeWorkDir
+          liftIO $ print $ pretty path
+
+       entry $ bindMatch "fixme:files" $ nil_ $ const do
+          w <- lift fixmeWorkDir
+          incl <- lift (asks fixmeEnvFileMask >>= readTVarIO)
+          excl <- lift (asks fixmeEnvFileExclude >>= readTVarIO)
+          glob incl excl w  $ \fn -> do
+            liftIO $ putStrLn (makeRelative w fn)
+            pure True
+
+       entry $ bindMatch "fixme:state:drop" $ nil_ $ const $ lift do
+        cleanupDatabase
+
+       entry $ bindMatch "fixme:state:cleanup" $ nil_ $ const $ lift do
+        cleanupDatabase
+
+
+       entry $ bindMatch "fixme:state:count-by-attribute" $ nil_ $ \case
+        [StringLike s] -> lift do
+            rs <- countByAttribute (fromString s)
+            for_ rs $ \(n,v) -> do
+              liftIO $ print $ pretty n <+> pretty v
+
+        _ -> throwIO $ BadFormException @C nil
+
+       entry $ bindMatch "fixme:git:import" $ nil_ $ const $ lift do
+          import_
+
+       entry $ bindMatch "fixme:git:list" $ nil_ $ const do
+          fxs <- lift scanFiles
+          for_ fxs $ \fme -> do
+            liftIO $ print $ pretty fme
+
+       -- TODO: some-uncommited-shit
+
+       -- TODO: some-shit
+       --  one
+
+       -- TODO: some-shit
+       --  new text
+
+       entry $ bindMatch "env:show" $ nil_ $ const $ do
+        lift printEnv
+
+       entry $ bindMatch "refchan:show" $ nil_ $ const do
+          tref <- lift $ asks fixmeEnvRefChan
+          r <- readTVarIO tref
+          liftIO $ print $ pretty (fmap AsBase58 r)
+
+       entry $ bindMatch "refchan" $ nil_ \case
+        [SignPubKeyLike rchan] -> do
+          tref<- lift $ asks fixmeEnvRefChan
+          atomically  $ writeTVar tref (Just rchan)
+
+        _ -> throwIO $ BadFormException @C nil
+
+       entry $ bindMatch "author" $ nil_ \case
+        [SignPubKeyLike au] -> do
+          t <- lift $ asks fixmeEnvAuthor
+          atomically  $ writeTVar t (Just au)
+
+        _ -> throwIO $ BadFormException @C nil
+
+       entry $ bindMatch "reader" $ nil_ \case
+        [EncryptPubKeyLike reader] -> do
+          t <- lift $ asks fixmeEnvReader
+          atomically  $ writeTVar t (Just reader)
+
+        _ -> throwIO $ BadFormException @C nil
+
+       entry $ bindMatch "git:commits" $ const $ do
+        co <- lift listCommits <&> fmap (mkStr @C . view _1)
+        pure $ mkList co
+
+       entry $ bindMatch "fixme:refchan:export" $ nil_ $ \case
+          [SymbolVal "dry"] -> do
+            notice $ yellow "export is running in dry mode"
+            void $ lift $ refchanExport [RefChanExportDry]
+
+          _ ->  void $ lift $ refchanExport ()
+
+       entry $ bindMatch "fixme:refchan:import" $ nil_ $ \case
+          _ ->  void $ lift $ refchanImport
+
+       entry $ bindMatch "fixme:gk:export" $ nil_ $ \case
+          _ ->  void $ lift $ refchanExportGroupKeys
+
+       entry $ bindMatch "source" $ nil_ $ \case
+        [StringLike path] -> do
+
+          ppath <- if List.isPrefixOf "." path then do
+                      dir <- lift localConfigDir
+                      let rest = tail $ splitDirectories path
+                      pure $ joinPath (dir:rest)
+                   else do
+                      canonicalizePath path
+
+          debug $ red "SOURCE FILE" <+> pretty ppath
+
+          -- FIXME: raise-warning?
+          content <- liftIO $ try @_ @IOException (readFile ppath)
+                        <&> fromRight mempty
+                        <&> parseTop
+                        >>= either (error.show) pure
+
+          lift $ runEval tvd content
+
+        _ -> throwIO $ BadFormException @C nil
+
+       entry $ bindMatch "update" $ nil_ $ const $ lift do
+        refchanUpdate
+
+       entry $ bindMatch "update" $ nil_ $ const $ lift do
+        refchanUpdate
+
+       entry $ bindMatch "fixme:refchan:update" $ nil_ $ const $ lift do
+        refchanUpdate
+
+
+       entry $ bindMatch "cache:ignore" $ nil_ $ const $ lift do
+        tf <- asks fixmeEnvFlags
+        atomically $ modifyTVar tf (HS.insert FixmeIgnoreCached)
+
+       entry $ bindMatch "git:blobs" $  \_ -> do
+        blobs <- lift (listBlobs Nothing)
+
+        elems <- for blobs $ \(f,h) -> do
+                    pure $ mkList @C [ mkStr f, mkSym ".", mkStr h ]
+
+        pure $ mkList @C elems
+
+       entry $ bindMatch "init" $ nil_ $ const $ do
+        lift init
+
+       brief "initializes a new refchan" $
+         desc ( vcat [
+                   "Refchan is an ACL-controlled CRDT channel useful for syncronizing"
+                 , "fixme-new state amongst the different remote setups/peers/directories"
+                 , "use it if you want to use fixme-new in a distributed fashion"
+                 ]
+              ) $
+         args [] $
+         returns "string" "refchan-key" $ do
+         entry $ bindMatch "fixme:refchan:init" $ nil_ $ \case
+          [] -> lift $ fixmeRefChanInit Nothing
+          [SignPubKeyLike rc] -> lift $ fixmeRefChanInit (Just rc)
+          _ -> throwIO $ BadFormException @C nil
+
+       entry $ bindMatch "set-template" $ nil_ \case
+         [SymbolVal who, SymbolVal w] -> do
+           templates <- lift $ asks fixmeEnvTemplates
+           t <- readTVarIO templates
+           for_ (HM.lookup w t) $ \tpl -> do
+             atomically $ modifyTVar templates (HM.insert who tpl)
+
+         _ -> throwIO $ BadFormException @C nil
+
+       entry $ bindMatch "define-template" $ nil_ $ \case
+         [SymbolVal who, IsSimpleTemplate body ] -> do
+          t <- lift $ asks fixmeEnvTemplates
+          atomically $ modifyTVar t (HM.insert who (Simple (SimpleTemplate body)))
+
+         _ -> throwIO $ BadFormException @C nil
+
+       entry $ bindMatch "log:trace:on" $ nil_ $ const do
+          lift $ setLogging @TRACE $ toStderr . logPrefix ""
+
+       entry $ bindMatch "log:trace:off" $ nil_ $ const do
+          lift $ setLoggingOff @TRACE
+
+       entry $ bindMatch "log:debug:on" $ nil_ $ const do
+          lift $ setLogging @DEBUG $ toStderr . logPrefix ""
+
+       entry $ bindMatch "log:debug:off" $ nil_ $ const do
+          lift $ setLoggingOff @DEBUG
+
+       entry $ bindMatch "debug:peer:check" $ nil_ $ const do
+        peer <- lift $ getClientAPI @PeerAPI @UNIX
+        poked <- callRpcWaitMay @RpcPoke (TimeoutSec 1) peer ()
+                   <&> fromMaybe "hbs2-peer not connected"
+        liftIO $ putStrLn poked
+
+
+  argz <- liftIO getArgs
+
+  conf <- readConfig
+
+  let args = zipWith (\i s -> bindValue (mkId ("$_" <> show i)) (mkStr @C s )) [1..] argz
+               & HM.unions
+
+  let finalDict = dict <> args -- :: Dict C (FixmeM m)
+
+  atomically $ writeTVar tvd finalDict
+
+  runEval tvd (conf <> forms) >>= eatNil display
+

fixme-new/lib/Fixme/Run/Internal.hs

@@ -0,0 +1,960 @@
+{-# Language PatternSynonyms #-}
+{-# Language ViewPatterns #-}
+module Fixme.Run.Internal where
+
+import Prelude hiding (init)
+import Fixme.Prelude hiding (indent)
+import Fixme.Types
+import Fixme.Config
+import Fixme.State
+import Fixme.Scan.Git.Local as Git
+import Fixme.Scan as Scan
+import Fixme.GK
+
+import HBS2.Git.Local.CLI
+import HBS2.CLI.Run.MetaData (createTreeWithMetadata,getTreeContents,getGroupKeyHash)
+import HBS2.Merkle.MetaData
+
+import HBS2.OrDie
+import HBS2.Base58
+import HBS2.Net.Auth.GroupKeySymm
+import HBS2.Data.Types.SignedBox
+import HBS2.Peer.Proto.RefChan as RefChan
+import HBS2.Peer.RPC.Client.RefChan
+import HBS2.Storage.Operations.ByteString
+import HBS2.System.Dir
+import HBS2.Net.Auth.Credentials
+import DBPipe.SQLite hiding (field)
+
+import HBS2.CLI.Run.KeyMan (keymanNewCredentials)
+import HBS2.KeyMan.Keys.Direct
+
+import Data.Config.Suckless.Script.File
+
+import Data.List qualified as L
+import Data.List.Split (chunksOf)
+import Data.Aeson.Encode.Pretty as Aeson
+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.Map qualified as Map
+import Data.Set qualified as Set
+import Data.Maybe
+import Data.Generics.Product.Fields (field)
+import Data.HashSet qualified as HS
+import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HM
+import Data.Text qualified as Text
+import Data.Text.Encoding (encodeUtf8)
+import Text.InterpolatedString.Perl6 (qc)
+import Data.Coerce
+import Data.Word
+import Data.UUID.V4 qualified as UUID
+import Lens.Micro.Platform
+import System.Process.Typed
+import Control.Monad.Trans.Cont
+import Control.Monad.Trans.Maybe
+import Control.Monad.Except
+import Control.Concurrent.STM (flushTQueue)
+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
+import System.Directory (getModificationTime)
+
+
+import System.IO as IO
+import System.Environment (lookupEnv)
+import System.IO.Temp qualified as Temp
+
+import Streaming.Prelude qualified as S
+
+pattern IsSimpleTemplate ::  forall {c} . [Syntax c] -> Syntax c
+pattern IsSimpleTemplate xs <- ListVal (SymbolVal "simple" : xs)
+
+{- HLINT ignore "Functor law" -}
+
+
+defaultTemplate :: HashMap Id FixmeTemplate
+defaultTemplate = HM.fromList [ ("default", Simple (SimpleTemplate short)) ]
+  where
+    short = parseTop s & fromRight mempty
+    s = [qc|
+(trim 10  $fixme-key) " "
+(align 6  $fixme-tag) " "
+(trim 50  ($fixme-title))
+(nl)
+    |]
+
+
+templateExample :: String
+templateExample = [qc|
+
+; this is an optional template example
+; for nicer fixme list
+;(define-template short
+;  (quot
+;    (simple
+;         (trim 10  $fixme-key) " "
+;
+;         (if (~ FIXME $fixme-tag)
+;          (then (fgd red (align 6  $fixme-tag))  )
+;          (else (if (~ TODO $fixme-tag)
+;                  (then (fgd green (align 6  $fixme-tag)))
+;                  (else (align 6  $fixme-tag)) ) )
+;          )
+;
+;
+;         (align 10  ("[" $workflow "]"))  " "
+;         (align 8  $class)  " "
+;         (align 12 $assigned)  " "
+;         (align 20 (trim 20 $committer-name)) " "
+;         (trim 50  ($fixme-title)) " "
+;         (nl))
+;    )
+;)
+; (set-template default short)
+
+|]
+
+
+init :: FixmePerks m => FixmeM m ()
+init = do
+
+  lo <- localConfigDir
+
+  let lo0 = takeFileName lo
+
+  mkdir lo
+  touch (lo </> "config")
+
+  let gitignore = lo </> ".gitignore"
+  here <- doesPathExist gitignore
+
+  confPath <- localConfig
+
+  unless here do
+
+    liftIO $ appendFile confPath $ show $ vcat
+      [ mempty
+      , ";; this is a default fixme config"
+      , ";;"
+      , "fixme-prefix"    <+> "FIXME:"
+      , "fixme-prefix"    <+> "TODO:"
+      , "fixme-value-set" <+> hsep [":workflow", ":new",":wip",":backlog",":done"]
+      , "fixme-file-comments" <+> dquotes "*.scm" <+> dquotes ";"
+      , "fixme-comments" <+> dquotes ";"  <+> dquotes "--" <+> dquotes "#"
+      , mempty
+      ]
+
+    exts <- listBlobs Nothing
+              <&> fmap (takeExtension . fst)
+              <&> HS.toList . HS.fromList
+
+    for_ exts $ \e -> do
+      unless (e `elem` [".gitignore",".local"] )  do
+        liftIO $ appendFile confPath $
+          show $ ( "fixme-files" <+> dquotes ("**/*" <> pretty e) <> line )
+
+    liftIO $ appendFile confPath $ show $ vcat
+      [ "fixme-exclude" <+> dquotes "**/.**"
+      ]
+
+    liftIO $ appendFile confPath $ show $ vcat
+      [ mempty
+      , pretty templateExample
+      , ";; uncomment to source any other local settings file"
+      , ";; source ./my.local"
+      , mempty
+      ]
+
+  unless here do
+    liftIO $ writeFile gitignore $ show $
+      vcat [ pretty ("." </> localDBName)
+           ]
+
+  notice $ green "default config created:" <+> ".fixme-new/config" <> line
+             <> "edit it for your project" <> line
+             <> "typically you need to add it to git"
+             <> line
+             <> "use (source ./some.local) form to add your personal settings" <> line
+             <> "which should not be shared amongst the whole project" <> line
+             <> "and add " <> yellow ".fixme-new/some.local" <+> "file to .gitignore"
+             <> line
+
+  notice $ "run" <> line <> vcat [
+      mempty
+    , "git add" <+> pretty (lo0  </> ".gitignore")
+    , "git add" <+> pretty (lo0  </> "config")
+    , mempty
+    ]
+
+
+printEnv :: FixmePerks m => FixmeM m ()
+printEnv = do
+  g <- asks fixmeEnvGitDir >>= readTVarIO
+  masks <- asks fixmeEnvFileMask >>= readTVarIO
+  excl  <- asks fixmeEnvFileExclude >>= readTVarIO
+  tags  <- asks fixmeEnvTags >>= readTVarIO
+  days  <- asks fixmeEnvGitScanDays >>= readTVarIO
+  comments1 <- asks fixmeEnvDefComments >>= readTVarIO <&> HS.toList
+
+  comments2 <- asks fixmeEnvFileComments >>= readTVarIO
+                 <&> HM.toList
+                 <&> fmap  (over _2 HS.toList)
+
+  attr <- asks fixmeEnvAttribs >>= readTVarIO <&> HS.toList
+  vals <- asks fixmeEnvAttribValues >>= readTVarIO <&> HM.toList
+
+  dir <- asks fixmeEnvWorkDir >>= readTVarIO
+
+  liftIO $ print $ "; workdir" <+> pretty dir
+
+  for_ tags $ \m -> do
+    liftIO $ print $ "fixme-prefix" <+> pretty m
+
+  for_ masks $ \m -> do
+    liftIO $ print $ "fixme-files" <+> dquotes (pretty m)
+
+  for_ excl $ \m -> do
+    liftIO $ print $ "fixme-exclude" <+> dquotes (pretty m)
+
+  for_ days $ \d -> do
+    liftIO $ print $ "fixme-git-scan-filter-days" <+> pretty d
+
+  for_ comments1 $ \d -> do
+    liftIO $ print $ "fixme-comments" <+> dquotes (pretty d)
+
+  for_ comments2 $ \(ft, comm') -> do
+    for_ comm' $ \comm -> do
+      liftIO $ print $ "fixme-file-comments"
+                  <+> dquotes (pretty ft) <+> dquotes (pretty  comm)
+
+  for_ attr $ \a -> do
+      liftIO $ print $ "fixme-attribs"
+                  <+> pretty a
+
+  for_ vals$ \(v, vs) -> do
+      liftIO $ print $ "fixme-value-set" <+> pretty v <+> hsep (fmap pretty (HS.toList vs))
+
+  for_ g $ \git -> do
+    liftIO $ print $ "fixme-git-dir" <+> dquotes (pretty git)
+
+  dbPath <- localDBPath
+  liftIO $ print $ "; fixme-state-path" <+> dquotes (pretty dbPath)
+
+  (before,after) <- asks fixmeEnvCatContext >>= readTVarIO
+
+  liftIO $ print $ "fixme-def-context" <+> pretty before <+> pretty after
+
+  ma <- asks fixmeEnvMacro >>= readTVarIO <&> HM.toList
+
+  for_ ma $ \(n, syn) -> do
+    liftIO $ print $ parens ("define-macro" <+> pretty n <+> pretty syn)
+
+  rchan <- asks fixmeEnvRefChan >>= readTVarIO
+
+  liftIO $ print $ ("refchan" <+> pretty (AsBase58 <$> rchan))
+
+  author <- asks fixmeEnvAuthor >>= readTVarIO
+
+  liftIO $ print $ ("author" <+> pretty (AsBase58 <$> author))
+
+  reader <- asks fixmeEnvReader >>= readTVarIO
+
+  liftIO $ print $ ("reader" <+> pretty (AsBase58 <$> reader))
+
+scanOneFile :: FixmePerks m => FilePath -> FixmeM m [Fixme]
+scanOneFile fn = do
+  lbs <- liftIO $ LBS.readFile fn
+  scanBlob (Just fn) lbs
+
+scanFiles :: FixmePerks m => FixmeM m [Fixme]
+scanFiles = do
+  w <- fixmeWorkDir
+  incl <- asks fixmeEnvFileMask >>= readTVarIO
+  excl <- asks fixmeEnvFileExclude >>= readTVarIO
+
+  keys <- newTVarIO (mempty :: HashMap Text Integer)
+
+  S.toList_ do
+
+    glob incl excl w  $ \fn -> do
+
+      ts <- liftIO $ getModificationTime fn <&> round . utcTimeToPOSIXSeconds
+
+      let fnShort = makeRelative w fn
+
+      lbs <- liftIO (try @_ @IOException $ LBS.readFile fn)
+               <&> fromRight mempty
+
+      fxs0 <- lift $ scanBlob (Just fn) lbs
+
+      for_ fxs0 $ \fme -> do
+        let key = fromString (fnShort <> "#") <> coerce (fixmeTitle fme) <> ":" :: Text
+        atomically $ modifyTVar keys (HM.insertWith (+) key 1)
+        no <- readTVarIO keys <&> HM.lookup key <&> fromMaybe 0
+        let keyText = key <> fromString (show no)
+        let keyHash = FixmeKey $ fromString $ show $ pretty $ hashObject @HbSync (serialise keyText)
+        let f2 = mempty { fixmeTs = Just (fromIntegral ts)
+                        , fixmeKey = keyHash
+                        , fixmeAttr = HM.fromList
+                            [   ( "fixme-key-string", FixmeAttrVal keyText)
+                              , ( "file", FixmeAttrVal (fromString fnShort))
+                            ]
+                        , fixmePlain = fixmePlain fme
+                        }
+        let fmeNew = (fme <> f2) & fixmeDerivedFields
+        S.yield fmeNew
+
+      pure True
+
+
+report :: (FixmePerks m, HasPredicate q, HasItemOrder q) => Maybe FilePath -> q -> FixmeM m ()
+report t q = do
+
+  tpl <- asks fixmeEnvTemplates >>= readTVarIO
+            <&> HM.lookup (maybe "default" fromString t)
+
+  fxs <- listFixme (WithLimit Nothing q)
+
+  case tpl of
+    Nothing ->
+      liftIO $ LBS.putStr $ Aeson.encodePretty (fmap fixmeAttr fxs)
+
+    Just (Simple (SimpleTemplate simple)) -> do
+      for_ fxs $ \(Fixme{..}) -> do
+        let subst = [ (mkId k, mkStr @C v) | (k,v) <- HM.toList fixmeAttr ]
+        let what = render (SimpleTemplate (inject  subst simple))
+                      & fromRight "render error"
+
+        liftIO $ hPutDoc stdout what
+
+
+edit_ :: FixmePerks m
+         => Either (String,String) Fixme
+         -> FixmeM m ()
+
+edit_ what = do
+
+  now <- liftIO $ getPOSIXTime <&> round
+
+  editor <- liftIO $ lookupEnv "EDITOR" >>= orThrowUser "EDITOR not set"
+
+  let txt = case what of
+              Right fx0 -> do
+                let fxm = fx0 & set (field @"fixmeAttr") mempty
+                              & set (field @"fixmeStart") mzero
+                              & set (field @"fixmeEnd") mzero
+                show $ pretty fxm
+
+              Left (me,title) -> [qc|TODO: {title}
+$commit-time:    {pretty now}
+$committer-name: {pretty me}
+
+Issue text...
+|]
+
+  let setKey k fx = case what of
+                      Right w -> fx & set (field @"fixmeKey") (fixmeKey w)
+                      Left{}  -> fx & set (field @"fixmeKey") (fromString p)
+        where
+         p = show $ pretty
+                  $ hashObject @HbSync
+                  $ fromString @LBS8.ByteString
+                  $ show k
+
+  flip runContT pure $ callCC \exit -> do
+   fname <- liftIO $ Temp.writeTempFile "." "fixme-issue" txt
+
+   ContT $ bracket none (const $ rm fname)
+
+   h1 <- liftIO (BS.readFile fname)
+            <&> hashObject @HbSync
+
+   debug $ "hash1" <+> pretty  h1
+
+   void $ runProcess $ shell [qc|{editor} {fname}|]
+
+   s <- liftIO $ BS.readFile fname <&> LBS.fromStrict
+
+   let h2 = hashObject @HbSync s
+
+   fxs <- lift $ scanBlobOpts NoIndents Nothing s
+
+   debug $ "hash before/after" <+> pretty  h1 <+> pretty h2
+
+   when (h1 == h2) $ exit ()
+
+   lift $ withState $ transactional do
+     for fxs $ \f -> do
+       key <- liftIO $ UUID.nextRandom <&> show
+       let norm = f & set (field @"fixmeStart") mzero
+                    & set (field @"fixmeEnd") mzero
+                    & setKey key
+                    & set (field @"fixmeTs") (Just $ fromIntegral now)
+                    & fixmeDerivedFields
+
+       notice $ "fixme" <+> pretty (fixmeKey norm)
+       insertFixme norm
+
+
+import_ :: FixmePerks m => FixmeM m ()
+import_ = do
+  fxs0 <- scanFiles
+
+  fxs <- flip filterM fxs0 $ \fme -> do
+           let fn = fixmeGet "file" fme <&> Text.unpack . coerce
+           seen <- maybe1 fn (pure False) selectIsAlreadyScannedFile
+           pure (not seen)
+
+  hashes <- catMaybes <$> flip runContT pure do
+      p <- ContT $ bracket startGitHash stopProcess
+      let files = mapMaybe (fixmeGet "file") fxs
+                      & HS.fromList
+                      & HS.toList
+                      & fmap (Text.unpack . coerce)
+      for files $ \f -> do
+        mbHash <- lift $ gitHashPathStdin p f
+        case mbHash of
+          Just ha ->
+            pure $ Just (f, ha)
+          Nothing ->
+            pure Nothing
+
+  versioned <- listBlobs Nothing <&> HM.fromList
+  let commited = HM.elems versioned & HS.fromList
+
+  let blobs = HM.fromList hashes
+
+  let isVersioned = maybe False (`HM.member` versioned)
+
+  withState $ transactional do
+    for_ fxs $ \fme -> do
+      let fn = fixmeGet "file" fme <&> Text.unpack . coerce
+      fmeRich <- lift $ maybe1 fn (pure mempty) (`getMetaDataFromGitBlame` fme)
+
+      let blob = fn >>= flip HM.lookup blobs
+                    >>= \b -> pure (fixmeSet "blob" (fromString (show $ pretty $ b)) mempty)
+
+      notice $ "fixme" <+> pretty (fixmeKey fme) <+> pretty fn
+      insertFixme (fromMaybe mempty blob <> fmeRich <> fme)
+
+      -- TODO: add-scanned-only-on-commited
+      --   $workflow: test
+      --   поведение: если файл в гите И закоммичен -- то
+      --   добавляем в сканированные.
+      --
+      --   если не в гите -- то добавляем в сканированные
+      --
+      for_ fn $ \f -> do
+        let add = not (isVersioned fn)
+                   || maybe False (`HS.member` commited) (HM.lookup f blobs)
+
+        when add do
+          insertScannedFile f
+
+cat_ :: FixmePerks m => Text -> FixmeM m ()
+cat_ hash = do
+
+  (before,after)  <- asks fixmeEnvCatContext >>= readTVarIO
+  gd  <- fixmeGetGitDirCLIOpt
+
+  CatAction action <- asks fixmeEnvCatAction >>= readTVarIO
+
+  dir  <- fixmeWorkDir
+
+  void $ flip runContT pure do
+    callCC \exit -> do
+
+      mha <- lift $ selectFixmeKey hash
+
+      ha <- ContT $ maybe1 mha (pure ())
+
+      fme' <- lift $ getFixme ha
+
+      fx@Fixme{..} <- ContT $ maybe1 fme' (pure ())
+
+      let dict = [ ("$file", mkStr @C (show $ pretty fixmeKey)) ]
+                 <>
+                 [ (mkId k, mkStr @C   v) | (k,v) <- HM.toList fixmeAttr ]
+                 <>
+                 [ (mkId "$before", mkStr @C (FixmeAttrVal $ Text.pack $ show 1))
+                 ] & HM.fromList
+
+
+      let fallText0 = [qc|{show $ pretty fixmeTag} {show $ pretty fixmeTitle}|]
+                       & encodeUtf8
+                       & LBS8.fromStrict
+
+      let fallback = LBS8.unlines $ fallText0 : fmap (LBS8.fromStrict . encodeUtf8 . coerce) fixmePlain
+
+      let fbAction = action (HM.toList dict)
+
+      let gh' = HM.lookup "blob" fixmeAttr
+
+      -- FIXME: define-fallback-action
+      gh <- ContT $ maybe1 gh' (liftIO (fbAction fallback))
+
+      let cmd = [qc|git {gd} cat-file blob {pretty gh}|] :: String
+
+      w <- gitRunCommand cmd
+              <&> either (const Nothing) Just
+
+      maybe1 w (liftIO $ fbAction fallback) $ \lbs -> do
+
+        let start = fromMaybe 0 fixmeStart & fromIntegral  & (\x -> x - before) & max 0
+
+        -- FIXME: off-by-one-error
+        let bbefore = if start == 0 then 1 else before + 1
+
+        -- warn $ red "before" <+> pretty before <+> pretty bbefore
+
+        let origLen = maybe  0 fromIntegral fixmeEnd - maybe 0 fromIntegral fixmeStart & max 1
+        let lno   =   max 1 $ origLen + after + before
+        let val = mkStr @C (FixmeAttrVal $ Text.pack $ show bbefore)
+        let ddict = HM.toList (HM.insert "$before" val dict)
+        let piece = LBS8.lines lbs & drop start & take lno
+        liftIO $ action ddict (LBS8.unlines piece)
+        exit ()
+
+
+class HasRefChanExportOpts a where
+  refchanExportDry :: a -> Bool
+
+data RefChanExportOpts =
+  RefChanExportDry
+  deriving (Eq,Ord,Show,Enum)
+
+instance HasRefChanExportOpts [RefChanExportOpts] where
+  refchanExportDry what = RefChanExportDry `elem` what
+
+instance HasRefChanExportOpts () where
+  refchanExportDry _ = False
+
+refchanExport :: (FixmePerks m, HasRefChanExportOpts a) => a -> FixmeM m Int
+refchanExport opts = do
+
+  let dry = refchanExportDry opts
+
+  sto <- getStorage
+  rchanAPI <- getClientAPI @RefChanAPI @UNIX
+
+
+  chan <- asks fixmeEnvRefChan
+           >>= readTVarIO
+           >>= orThrowUser "refchan not set"
+
+  au <- asks fixmeEnvAuthor
+           >>= readTVarIO
+           >>= orThrowUser "author's key not set"
+
+  creds <- runKeymanClientRO $ loadCredentials au
+             >>= orThrowUser "can't read credentials"
+
+
+  let (pk,sk) = (view peerSignPk creds, view peerSignSk creds)
+
+  gk0 <- loadGroupKey
+
+  -- TODO: this-may-cause-to-tx-flood
+  --   сделать какой-то период релакса,
+  --   что ли
+  now <- liftIO $ getPOSIXTime <&> round
+
+  withState do
+    what <- select  @FixmeExported [qc|
+      select distinct o,?,k,cast (v as text)
+      from object obj
+      where not exists (select null from scanned where hash = obj.nonce)
+      order by o, k, v, w
+      |] (Only now)
+
+    let chu  = chunksOf 10000 what
+
+    flip runContT pure do
+
+      for_ chu $ \x -> callCC \next -> do
+
+        -- FIXME: encrypt-tree
+
+        --   6. как делать доступ к историческим данным
+        --   6.1 новые ключи в этот же рефчан
+        --   6.2 или новые ключи в какой-то еще рефчан
+
+        let s = maybe "[ ]" (const $ yellow "[@]") gk0
+
+        let gk = snd <$> gk0
+
+        href <- liftIO $ createTreeWithMetadata sto gk mempty (serialise x)
+                  >>= orThrowPassIO
+
+        let tx = AnnotatedHashRef Nothing href
+
+        lift do
+
+          let lbs = serialise tx
+
+          let box = makeSignedBox @'HBS2Basic @BS.ByteString pk sk (LBS.toStrict lbs)
+
+          warn $ "POST" <+> pretty (length x) <+> s <> "tree" <+> pretty href <+> pretty (hashObject @HbSync (serialise box))
+
+          unless dry do
+            r <- callRpcWaitMay @RpcRefChanPropose (TimeoutSec 1) rchanAPI (chan, box)
+
+            when (isNothing r) do
+              err $ red "hbs2-peer rpc calling timeout"
+
+      pure $ length what
+
+
+refchanUpdate :: FixmePerks m => FixmeM m ()
+refchanUpdate = do
+
+  refchanImport
+
+  rchan <- asks fixmeEnvRefChan
+             >>= readTVarIO
+             >>= orThrowUser "refchan not set"
+
+  api   <- getClientAPI @RefChanAPI @UNIX
+
+  sto <- getStorage
+
+  h0 <- callService @RpcRefChanGet api rchan
+         >>= orThrowUser "can't request refchan head"
+
+  rch <-  RefChan.getRefChanHead @L4Proto sto (RefChanHeadKey rchan)
+              >>= orThrowUser "can't request refchan head"
+
+  let w = view refChanHeadWaitAccept rch
+
+  refchanExportGroupKeys
+
+  txn <- refchanExport ()
+
+  unless (txn == 0) do
+
+    notice $ "wait refchan" <+> pretty (AsBase58 rchan) <+> "to update..."
+
+    -- TODO: implement-refchan-update-notifications
+
+    -- FIXME: use-wait-time-from-refchan-head
+
+    -- TODO: fix-this-lame-polling
+    flip fix 0 $ \next -> \case
+      n | n >= w -> pure ()
+      n  -> do
+
+        h <- callService @RpcRefChanGet api rchan
+               >>= orThrowUser "can't request refchan head"
+
+        if h0 /= h then
+          pure ()
+        else do
+          pause @'Seconds 1
+          liftIO $ hPutStr stderr (show $ pretty (w - n) <> "    \r")
+          next (succ n)
+
+    none
+
+  refchanImport
+
+refchanImport :: FixmePerks m => FixmeM m ()
+refchanImport = do
+
+  sto <- getStorage
+
+  chan <- asks fixmeEnvRefChan
+           >>= readTVarIO
+           >>= orThrowUser "refchan not set"
+
+
+  ttsmap  <- newTVarIO HM.empty
+  accepts <- newTVarIO HM.empty
+
+  tq <- newTQueueIO
+
+  ignCached <- asks fixmeEnvFlags >>= readTVarIO <&> HS.member FixmeIgnoreCached
+
+  let goodToGo x | ignCached = pure True
+                 | otherwise  = do
+        here <- selectIsAlreadyScanned x
+        pure $ not here
+
+  fixmeGkSign <- putBlock sto "FIXMEGROUPKEYBLOCKv1" <&> fmap HashRef
+                    >>= orThrowUser "hbs2 storage error. aborted"
+
+  walkRefChanTx @UNIX goodToGo chan $ \txh u -> do
+
+    case  u of
+
+      A (AcceptTran (Just ts) _ what) -> do
+        debug $ red "ACCEPT" <+> pretty ts <+> pretty what
+        atomically $ modifyTVar ttsmap (HM.insertWith max what (coerce @_ @Word64 ts))
+        atomically $ modifyTVar accepts (HM.insertWith (<>) what (HS.singleton txh))
+
+        scanned <- selectIsAlreadyScanned what
+        when scanned do
+           withState $ insertScanned txh
+
+      A _  -> none
+
+      P1 ppk orig (ProposeTran _ box) -> void $ runMaybeT do
+        (_, bs) <- unboxSignedBox0 box & toMPlus
+
+        AnnotatedHashRef sn href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict bs)
+                                    & toMPlus . either (const Nothing) Just
+
+        scanned <- lift $ selectIsAlreadyScanned href
+
+        when (not scanned || ignCached) do
+
+          let isGk = sn == Just fixmeGkSign
+
+          if isGk then do
+
+            atomically $ writeTQueue tq (Left (txh, orig, href, href))
+
+          else do
+            what <- liftIO (runExceptT $ getTreeContents sto href)
+                      <&> either (const Nothing) Just
+                      >>= toMPlus
+
+            let exported = deserialiseOrFail @[FixmeExported] what
+                              & either (const Nothing) Just
+
+            case exported of
+              Just e -> do
+                for_ e $ \x -> do
+                  atomically $ writeTQueue tq (Right (txh, orig, href, x))
+
+              Nothing -> do
+                lift $ withState $ insertScanned txh
+
+  imported <- atomically $ flushTQueue tq
+
+  withState $ transactional do
+    for_ imported $ \case
+      Left (txh, orig, href, gk) -> do
+        -- hx <- writeAsMerkle sto (serialise gk)
+        -- notice $ "import GK" <+> pretty hx <+> "from" <+> pretty href
+        -- let tx = AnnotatedHashRef _ href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict bs)
+        --                             & toMPlus . either (const Nothing) Just
+        insertScanned txh
+        -- TODO: ASAP-notify-hbs2-keyman
+        --   у нас два варианта:
+        --     1. звать runKeymanClient и в нём записывать в БД
+        --        с возможностью блокировок
+        --     2. каким-то образом делать отложенную запись,
+        --        например, писать лог групповых ключей
+        --        куда-то, откуда hbs2-keyman сможет
+        --        обновить их при запуске
+        --
+        --        лог групповых ключей мы можем писать:
+        --          1.  в рефлог, на который подписан и кейман
+        --          2.  в рефчан, на который подписан и кейман
+        --                неожиданные плюсы:
+        --                  + у нас уже есть такой рефчан!
+        --                    всё, что надо сделать  -- это записать ключи туда
+        --                    с одной стороны туповато: перекладывать транзы из
+        --                    рефчана в рефчан. с другой стороны -- не нужны никакие
+        --                    новые механизмы. рефчан, в общем-то, локальный(?),
+        --                    блоки никуда за пределы хоста не поедут (?) и сеть
+        --                    грузить не будут (?)
+        --
+        --          3.  в рефчан, используя notify
+        --          4.  в еще какую переменную, которая будет
+        --              локальна
+        --          5.  в какой-то лог. который кейман будет
+        --              процессировать при hbs2-keyman update
+        --
+        --      поскольку БД кеймана блокируется целиком при апдейтах,
+        --      единственное, куда писать проблематично -- это сама БД.
+        --
+        pure ()
+
+      Right (txh, h, href, i) -> do
+        w <- readTVarIO ttsmap <&> fromMaybe (exportedWeight i) . HM.lookup h
+        let item = i { exportedWeight = w }
+
+        if exportedWeight item /= 0 then do
+          notice $ "import" <+> pretty (exportedKey item) <+> pretty (exportedWeight item)
+          insertFixmeExported (localNonce (href,i)) item
+        else do
+          debug $ "SKIP TX!" <+> pretty txh
+
+        atx <- readTVarIO accepts <&> fromMaybe mempty . HM.lookup h
+        insertScanned txh
+        insertScanned href
+        for_ atx insertScanned
+
+
+
+
+refchanExportGroupKeys :: FixmePerks m => FixmeM m ()
+refchanExportGroupKeys = do
+
+  let gkHash x = hashObject @HbSync ("GKSCAN" <> serialise x) & HashRef
+
+  sto <- getStorage
+
+  chan <- asks fixmeEnvRefChan
+           >>= readTVarIO
+           >>= orThrowUser "refchan not set"
+
+  ignCached <- asks fixmeEnvFlags >>= readTVarIO <&> HS.member FixmeIgnoreCached
+
+  let goodToGo x | ignCached = pure True
+                 | otherwise = do
+        here <- selectIsAlreadyScanned (gkHash x)
+        pure $ not here
+
+  debug "refchanExportGroupKeys"
+
+  skip <- newTVarIO HS.empty
+  gkz <- newTVarIO HS.empty
+
+  fixmeSign <- putBlock sto "FIXMEGROUPKEYBLOCKv1" <&> fmap HashRef
+
+  walkRefChanTx @UNIX goodToGo chan $ \txh u -> do
+
+    case u of
+      P orig (ProposeTran _ box) -> void $ runMaybeT do
+        (_, bs) <- unboxSignedBox0 box & toMPlus
+
+        AnnotatedHashRef _ href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict bs)
+                                    & toMPlus . either (const Nothing) Just
+
+        result <- lift $ try @_ @OperationError  (getGroupKeyHash href)
+
+        case result of
+          Right (Just gk,_) -> do
+            atomically do
+              modifyTVar gkz  (HS.insert gk)
+              modifyTVar skip (HS.insert txh)
+
+          Right (Nothing,_) -> do
+            atomically $ modifyTVar skip (HS.insert txh)
+
+          Left UnsupportedFormat -> do
+            debug $ "unsupported" <+> pretty href
+            atomically $ modifyTVar skip (HS.insert txh)
+
+          Left e -> do
+             debug $ "other error" <+> viaShow e
+
+      _ -> none
+
+  l <- readTVarIO skip <&> HS.toList
+  r <- readTVarIO gkz <&> HS.toList
+
+  withState $ transactional do
+    for_ l (insertScanned . gkHash)
+
+  rchan <- asks fixmeEnvRefChan
+             >>= readTVarIO
+             >>= orThrowUser "refchan not set"
+
+  api   <- getClientAPI @RefChanAPI @UNIX
+
+  rch <-  RefChan.getRefChanHead @L4Proto sto (RefChanHeadKey rchan)
+              >>= orThrowUser "can't request refchan head"
+
+  au <- asks fixmeEnvAuthor
+           >>= readTVarIO
+           >>= orThrowUser "author's key not set"
+
+  creds <- runKeymanClientRO $ loadCredentials au
+             >>= orThrowUser "can't read credentials"
+
+
+  let (pk,sk) = (view peerSignPk creds, view peerSignSk creds)
+
+  keyz <- Set.fromList <$> S.toList_ do
+    for_ r $ \gkh -> void $ runMaybeT do
+
+      debug $ red $ "FOR GK" <+> pretty gkh
+
+      gk <- loadGroupKeyMaybe @'HBS2Basic sto gkh >>= toMPlus
+
+      -- the original groupkey should be indexed as well
+      lift $ S.yield gkh
+
+      gks <- liftIO (runKeymanClientRO $ findMatchedGroupKeySecret sto gk)
+
+      when (isNothing gks) do
+      --   lift $ withState (insertScanned (gkHash txh))
+        warn $ "unaccessible group key" <+> pretty gkh
+        mzero
+
+      gk1 <- generateGroupKey @'HBS2Basic gks (HS.toList $ view refChanHeadReaders rch)
+      let lbs = serialise gk1
+      gkh1 <- writeAsMerkle sto lbs  <&> HashRef
+      debug $  red "prepare new gk0" <+> pretty (LBS.length lbs) <+> pretty gkh <+> pretty (groupKeyId gk)
+      lift $ S.yield gkh1
+
+  notice $ yellow $ "new gk:" <+> pretty (Set.size keyz)
+
+  -- let nitems = 262144 `div` (125 * HS.size (view refChanHeadReaders rch) )
+  -- let chunks = Map.elems keyz & chunksOf nitems
+
+  -- TODO: gk:performance-vs-reliability
+  --   ситуация такова: групповой ключ это меркл-дерево
+  --   для одного и того же блоба могут быть разные меркл-деревья,
+  --   так как могут быть разные настройки.
+  --
+  --   если распространять ключи по-одному, то хотя бы тот же ключ,
+  --   который мы создали изначально -- будет доступен по своему хэшу,
+  --   как отдельный артефакт.
+  --
+  --   Если писать их пачками, где каждый ключ представлен непосредственно,
+  --   то на принимающей стороне нет гарантии, что меркл дерево будет писаться
+  --   с таким же параметрами, хотя и может.
+  --
+  --   Решение:  делать групповой ключ БЛОКОМ. тогда его размер будет ограничен,
+  --   но он хотя бы будет всегда однозначно определён хэшем.
+  --
+  --   Решение: ссылаться не на групповой ключ, а на хэш его секрета
+  --   что ломает текущую схему и обратная совместимость будет морокой.
+  --
+  --   Решение: добавить в hbs2-keyman возможно индексации единичного
+  --   ключа, и индексировать таким образом *исходные* ключи.
+  --
+  --   Тогда можно эти вот ключи писать пачками, их хэши не имеют особого значения,
+  --   если мы проиндексируем оригинальный ключ и будем знать, на какой секрет он
+  --   ссылается.
+  --
+  --   Заметим, что в один блок поместится аж >2000 читателей, что должно быть
+  --   более, чем достаточно => при таких группах вероятность утечки секрета
+  --   стремится к 1.0, так как большинство клало болт на меры безопасности.
+  --
+  --   Кстати говоря, проблема недостаточного количества авторов в ключе легко
+  --   решается полем ORIGIN, т.к мы можем эти самые ключи разделять.
+  --
+  --   Что бы не стоять перед такой проблемой, мы всегда можем распостранять эти ключи
+  --   по-одному, ЛИБО добавить в производный ключ поле
+  --   ORIGIN: где будет хэш изначального ключа.
+  --
+  --   Это нормально, так как мы сможем проверить, что у этих ключей
+  --   (текущий и ORIGIN) одинаковые хэши секретов.
+  --
+  --   Это всё равно оставляет возможность еще одной DoS атаки на сервис,
+  --   с распространением кривых ключей, но это хотя бы выяснимо, ну и атака
+  --   может быть только в рамках рефчана, т.е лечится выкидыванием пиров /
+  --   исключением зловредных авторов.
+
+  for_ (Set.toList keyz) $ \href -> do
+
+      let tx = AnnotatedHashRef fixmeSign href
+
+      let lbs = serialise tx
+
+      let box = makeSignedBox @'HBS2Basic @BS.ByteString pk sk (LBS.toStrict lbs)
+
+      warn $ "post gk tx" <+> "tree" <+> pretty href
+
+      result <- callRpcWaitMay @RpcRefChanPropose (TimeoutSec 1) api (chan, box)
+
+      when (isNothing result) do
+        err $ red "hbs2-peer rpc calling timeout"
+
+

fixme-new/lib/Fixme/Run/Internal/RefChan.hs

@@ -0,0 +1,284 @@
+{-# Language MultiWayIf #-}
+module Fixme.Run.Internal.RefChan (fixmeRefChanInit) where
+
+import Prelude hiding (init)
+import Fixme.Prelude hiding (indent)
+import Fixme.Types
+import Fixme.Config
+
+import HBS2.OrDie
+import HBS2.Base58
+import HBS2.Net.Auth.GroupKeySymm
+import HBS2.Data.Types.SignedBox
+import HBS2.Peer.Proto.RefChan as RefChan
+import HBS2.Storage.Operations.ByteString
+import HBS2.System.Dir
+import HBS2.Net.Auth.Credentials
+
+import HBS2.CLI.Run.KeyMan (keymanNewCredentials)
+import HBS2.KeyMan.Keys.Direct
+
+
+import Data.ByteString.Lazy.Char8 qualified as LBS8
+import Data.Either
+import Data.Maybe
+import Data.List qualified as List
+import Data.HashSet qualified as HS
+import Data.HashMap.Strict qualified as HM
+import Text.InterpolatedString.Perl6 (qc)
+import Lens.Micro.Platform
+import System.Process.Typed
+import Control.Monad.Trans.Cont
+import Control.Monad.Trans.Maybe
+import Data.Word
+import System.IO qualified as IO
+
+{- HLINT ignore "Functor law"-}
+
+notEmpty :: [a] -> Maybe [a]
+notEmpty = \case
+  [] -> Nothing
+  x  -> Just x
+
+
+data RefChanInitFSM =
+    InitInit
+  | SetupNewRefChan
+  | SetupExitFailure
+  | CheckRefChan (PubKey 'Sign 'HBS2Basic)
+  | RefChanHeadFound (PubKey 'Sign 'HBS2Basic) (RefChanHeadBlock L4Proto)
+  | WaitRefChanHeadStart (PubKey 'Sign 'HBS2Basic) Word64
+  | WaitRefChanHead (PubKey 'Sign 'HBS2Basic) Word64
+
+fixmeRefChanInit :: FixmePerks m => Maybe (PubKey 'Sign 'HBS2Basic) -> FixmeM m ()
+fixmeRefChanInit mbRc = do
+   let rch0 = refChanHeadDefault @L4Proto
+   sto <- getStorage
+   peer <- getClientAPI @PeerAPI @UNIX
+   rchanApi <- getClientAPI @RefChanAPI @UNIX
+
+   dir <- localConfigDir
+   confFile <- localConfig
+
+   rchan <- asks fixmeEnvRefChan
+              >>= readTVarIO
+
+   poked <- callRpcWaitMay @RpcPoke (TimeoutSec 1) peer ()
+              >>= orThrowUser "hbs2-peer not connected"
+              <&> parseTop
+              <&> fromRight mempty
+
+   pkey <- [ fromStringMay @(PubKey 'Sign 'HBS2Basic) x
+           | ListVal [SymbolVal "peer-key:", StringLike x ] <- poked
+           ] & headMay . catMaybes & orThrowUser "hbs2-peer key not set"
+
+
+   let refChanClause r = mkList @C [ mkSym "refchan"
+                                   , mkSym (show $ pretty (AsBase58 r))
+                                   ]
+
+   flip runContT pure $ callCC \done -> do
+
+    flip fix InitInit $ \next -> \case
+      InitInit -> do
+
+        case (rchan, mbRc) of
+          (Nothing, Nothing) -> next SetupNewRefChan
+          (_, Just r2)  -> next (CheckRefChan r2)
+          (Just r1, Nothing) -> next (CheckRefChan r1)
+
+      CheckRefChan rc -> do
+        notice $ "check refchan:" <+> pretty (AsBase58 rc)
+
+        notice $ "subscribe to refchan" <+> pretty (AsBase58 rc)
+
+        -- FIXME: poll-time-hardcode
+        --   $class: hardcode
+        void $ callService @RpcPollAdd peer (rc, "refchan", 17)
+
+        notice $ "fetch refchan head" <+> pretty (AsBase58 rc)
+        void $ lift $ callRpcWaitMay  @RpcRefChanHeadFetch (TimeoutSec 1) rchanApi rc
+
+        now <- liftIO $ getPOSIXTime <&> round
+        pause @'Seconds 1
+        next $ WaitRefChanHead rc now
+
+      WaitRefChanHeadStart rc t -> do
+        notice $ "wait for refchan head" <+> pretty (AsBase58 rc)
+        next (WaitRefChanHead rc t)
+
+      WaitRefChanHead rc t -> do
+        now <- liftIO $ getPOSIXTime <&> round
+        let s = 60 - (now -t)
+        hd <- getRefChanHead @L4Proto sto (RefChanHeadKey rc)
+
+        liftIO $ IO.hPutStr stderr $ show $ "waiting" <+> pretty s <+> "      \r"
+
+        if | now - t < 60 && isNothing hd -> do
+             pause @'Seconds 1
+             next $ WaitRefChanHead rc t
+
+           | now - t > 60 && isNothing hd -> do
+             err "refchan wait timeout"
+             next $ SetupExitFailure
+
+           | isJust hd -> do
+              next $ RefChanHeadFound rc (fromJust hd)
+
+           | otherwise -> next $ SetupExitFailure
+
+      RefChanHeadFound rc hd -> do
+        notice $ "found refchan head for" <+> pretty (AsBase58 rc)
+        void $ lift $ callRpcWaitMay  @RpcRefChanFetch (TimeoutSec 1) rchanApi rc
+
+        author <- lift $ asks fixmeEnvAuthor >>= readTVarIO
+
+        let readers = view refChanHeadReaders hd
+        let authors = view refChanHeadAuthors hd
+
+        -- hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs
+        rs <- liftIO (runKeymanClientRO $ loadKeyRingEntries (HS.toList readers))
+
+        let isReader = case rs of
+                           [] -> False
+                           _  -> True
+
+        let canRead = if isReader then
+                        green "yes"
+                      else
+                        red "no"
+
+        notice $ "reader:" <+> canRead
+
+        let isAuthor = maybe1 author False (`HS.member` authors)
+
+        let canWrite = if isAuthor
+                        then green "yes"
+                        else red "no"
+
+        notice $ "author:" <+> canWrite
+
+        unless isReader do
+          warn $ yellow "no reader key found" <> line
+                 <>  "it's may be ok, if this refchan is not encrypted" <> line
+                 <>  "otherwise, make your encryption key a member of this refchan head"
+                 <> line
+
+        unless isAuthor do
+          warn $ red "no author key found" <> line
+                 <>  "it's may be ok if you have only read-only access to this refchan" <> line
+                 <>  "otherwise, use" <+> yellow "author KEY" <+> "settings in the .fixme-new/config" <> line
+                 <>  "and make sure it is added to the refchan head"
+                 <> line
+
+        unless (isJust rchan) do
+          notice $ "adding refchan to" <+> pretty confFile
+          liftIO do
+            appendFile confFile $ show $
+                line
+                <> vcat [ pretty (refChanClause rc) ]
+
+      SetupExitFailure -> do
+        err "refchan init failed"
+
+      SetupNewRefChan -> do
+
+        notice $ green "default peer" <+> pretty (AsBase58 pkey)
+
+        signK' <- lift $ runKeymanClientRO $ listCredentials
+                <&> headMay
+
+        signK <- ContT $ maybe1 signK' (throwIO $ userError "no default author key found in hbs2-keyman")
+
+        notice $ green "default author" <+> pretty (AsBase58 signK)
+
+        -- TODO: use-hbs2-git-api?
+        (_, gkh', _) <- readProcess (shell [qc|git hbs2 key|])
+                         <&> over _2 (  (fromStringMay @HashRef)  <=< (notEmpty . headDef "" . lines . LBS8.unpack) )
+                         <&> \x ->  case view _1 x of
+                               ExitFailure _ -> set _2 Nothing x
+                               ExitSuccess   -> x
+
+        notice $ green "group key" <+> maybe "none" pretty gkh'
+
+        readers <- fromMaybe mempty <$> runMaybeT do
+                     gh <- toMPlus gkh'
+                     gk <- loadGroupKeyMaybe @'HBS2Basic sto gh
+                              >>= toMPlus
+                     pure $ HM.keys (recipients gk)
+
+        notice $ green "readers" <+> pretty (length readers)
+
+        rk <- lift $ runKeymanClientRO $ loadKeyRingEntries readers
+                <&> fmap snd . headMay
+
+
+        let rch1 = rch0 & set refChanHeadReaders (HS.fromList readers)
+                        & set refChanHeadAuthors (HS.singleton signK)
+                        & set refChanHeadPeers   (HM.singleton pkey 1)
+
+
+        let unlucky =    HM.null (view refChanHeadPeers rch1)
+                      || HS.null (view refChanHeadAuthors rch1)
+
+        liftIO $ print $ pretty rch1
+
+        if unlucky then do
+           warn $ red $ "refchan definition is not complete;" <+>
+                        "you may add missed keys, edit the"   <+>
+                        "defition and add if manually or repeat init attempt"
+                        <> line
+        else do
+           notice "refchan definition seems okay, adding new refchan"
+
+           refchan <- lift $ keymanNewCredentials (Just "refchan") 0
+
+           creds <- lift $ runKeymanClientRO $ loadCredentials refchan
+                          >>= orThrowUser "can't load credentials"
+
+           let box = makeSignedBox @'HBS2Basic (view peerSignPk creds) (view peerSignSk creds) rch1
+
+           href <- writeAsMerkle sto  (serialise box)
+
+           callService @RpcPollAdd peer (refchan, "refchan", 17)
+               >>= orThrowUser "can't subscribe to refchan"
+
+           callService @RpcRefChanHeadPost rchanApi (HashRef href)
+               >>= orThrowUser "can't post refchan head"
+
+
+           let nonce = take 6 $ show $ pretty (AsBase58 refchan)
+           let rchanFile = "refchan-" <> nonce <> ".local"
+           let rchanFilePath = dir </> rchanFile
+
+           let note =    ";; author and reader are inferred automatically" <> line
+                      <> ";; from hbs2-keyman data" <> line
+                      <> ";; edit them if needed" <> line
+                      <> ";; reader is *your* reading public key." <> line
+                      <> ";; author is *your* signing public key." <> line
+
+           let theirReaderKeyClause = maybe1 rk ";; reader ..."$ \(KeyringEntry pk _ _) -> do
+                  pretty $ mkList @C [ mkSym "reader", mkSym (show $ pretty (AsBase58 pk) )  ]
+
+           let theirAuthorClause  = mkList @C [ mkSym "author", mkSym (show $ pretty (AsBase58 signK) ) ]
+
+           let content =    line
+                         <> note
+                         <> line
+                         <> vcat [ theirReaderKeyClause
+                                 , pretty theirAuthorClause
+                                 ]
+
+           liftIO do
+             writeFile rchanFilePath $
+               show content
+
+           notice $ "adding refchan to" <+> pretty confFile
+           liftIO do
+             appendFile confFile $ show $
+                 line
+                 <> vcat [ pretty (refChanClause refchan) ]
+
+           next $ CheckRefChan refchan
+
+

fixme-new/lib/Fixme/Scan.hs

@@ -0,0 +1,250 @@
+{-# Language MultiWayIf #-}
+module Fixme.Scan
+  ( scanBlobOpts
+  , scanBlob
+  , scanMagic
+  , updateScanMagic
+  , NoIndents(..)
+  ) where
+
+import Fixme.Prelude hiding (indent)
+import Fixme.Types
+
+import Data.ByteString.Lazy.Char8 (ByteString)
+import Data.ByteString.Lazy.Char8 qualified as LBS8
+import Data.Text qualified as Text
+import Data.Text.Encoding (decodeUtf8With)
+import Data.Text.Encoding.Error (ignore)
+import Data.Char (isSpace)
+
+import Data.Maybe
+import Data.HashSet qualified as HS
+import Data.HashMap.Strict qualified as HM
+import Data.Coerce
+
+import Data.Generics.Product.Fields (field)
+import Lens.Micro.Platform
+import Text.InterpolatedString.Perl6 (qc)
+
+import Streaming.Prelude qualified as S
+
+{- HLINT ignore "Functor law" -}
+
+
+data SfEnv =
+  SfEnv { lno :: Int  -- ^ line number
+        , l0  :: Int  -- ^ fixme indent
+        , eln :: Int  -- ^ empty lines counter
+        }
+        deriving stock Generic
+
+
+succEln :: SfEnv -> ByteString -> SfEnv
+succEln f s | LBS8.null s = over (field @"eln") succ f
+            | otherwise = set (field @"eln") 0 f
+
+data Sx = S0 | Sf SfEnv
+
+data S = S Sx [(Int,ByteString)]
+
+
+data FixmePart = FixmePart Int FixmeWhat
+                 deriving stock (Show,Data,Generic)
+
+data FixmeWhat = FixmeHead Int Int Text Text
+               | FixmeLine Text
+               | FixmeAttr FixmeAttrName FixmeAttrVal
+                 deriving stock (Show,Data,Generic)
+
+data P = P0 [FixmePart] | P1 Int Fixme [FixmePart]
+
+
+scanMagic :: FixmePerks m => FixmeM m HashRef
+scanMagic = do
+  env <- ask
+  w <- atomically do
+         tagz <- fixmeEnvTags env          & readTVar
+         co   <- fixmeEnvDefComments  env  & readTVar
+         fco  <- fixmeEnvFileComments env  & readTVar
+         m    <- fixmeEnvFileMask env      & readTVar
+         e    <- fixmeEnvFileExclude env   & readTVar
+         a    <- fixmeEnvAttribs env       & readTVar
+         v    <- fixmeEnvAttribValues env  & readTVar
+
+         pure $ serialise (tagz, co, fco, m, e, a, v)
+  pure $ HashRef $ hashObject w
+
+updateScanMagic :: (FixmePerks m) => FixmeM m ()
+updateScanMagic = do
+  t <- asks fixmeEnvScanMagic
+  magic <- scanMagic
+  atomically $ writeTVar t (Just magic)
+
+class IsScanBlobOptions a where
+  ignoreIndents :: a -> Bool
+
+data NoIndents = NoIndents
+
+instance IsScanBlobOptions () where
+  ignoreIndents = const False
+
+instance IsScanBlobOptions NoIndents where
+  ignoreIndents = const True
+
+scanBlob ::  forall m . (FixmePerks m)
+         => Maybe FilePath
+         -> ByteString
+         -> FixmeM m [Fixme]
+
+scanBlob = scanBlobOpts ()
+
+
+scanBlobOpts ::  forall o m . (IsScanBlobOptions o, FixmePerks m)
+             => o
+             -> Maybe FilePath
+             -> ByteString
+             -> FixmeM m [Fixme]
+
+scanBlobOpts o fpath lbs = do
+
+  let indents = not (ignoreIndents o)
+
+  tagz <- asks fixmeEnvTags
+              >>= readTVarIO
+              <&> HS.toList
+              <&> fmap (Text.unpack . coerce)
+              <&> filter (not . null)
+              <&> fmap LBS8.pack
+
+  comments <- fixmeGetCommentsFor fpath
+                <&> filter (not . LBS8.null) . fmap (LBS8.pack . Text.unpack)
+
+  anames  <- asks fixmeEnvAttribs >>= readTVarIO <&> HS.toList
+
+  let setters = [ ( LBS8.pack [qc|${show $ pretty n}:|], n ) | n <- anames ]
+
+  let ls = LBS8.lines lbs & zip [0..]
+
+  parts <- S.toList_ do
+
+      flip fix (S S0 ls) $ \next -> \case
+        S S0 ((lno,x):xs) -> do
+
+          (l,bs)  <- eatPrefix0 Nothing comments x
+
+          let mtag = headMay [ t | t <- tagz, LBS8.isPrefixOf t bs ]
+
+          case mtag of
+            Nothing ->
+              next (S S0 xs)
+
+            Just tag -> do
+              emitFixmeStart lno l tag (LBS8.drop (LBS8.length tag) bs)
+              next (S (Sf (SfEnv lno l 0)) xs)
+
+        S sf@(Sf env@(SfEnv{..})) (x : xs) -> do
+
+          (li,bs)  <- eatPrefix0 (Just l0) comments (snd x)
+
+          if | eln > 1 -> next (S S0 (x:xs))
+
+             | indents && li <= l0 && not (LBS8.null bs) -> next (S S0 (x:xs))
+
+             | otherwise -> do
+
+                let stripped = LBS8.dropWhile isSpace bs
+                let attr = headMay [ (s, LBS8.drop (LBS8.length a) stripped)
+                                   | (a,s) <- setters, LBS8.isPrefixOf a stripped
+                                   ]
+
+                case attr of
+                  Just (a,v) -> do
+                    let vv = LBS8.toStrict v & decodeUtf8With ignore & Text.strip
+                    emitFixmeAttr (fst x) l0 a (FixmeAttrVal vv)
+                  Nothing -> do
+                    emitFixmeLine (fst x) l0 bs
+
+                next (S (Sf (succEln env bs)) xs)
+
+        S _ [] -> pure ()
+  -- debug $ vcat (fmap viaShow parts)
+
+  S.toList_ do
+    flip fix (P0 parts) $ \next -> \case
+
+        (P0 (FixmePart l h@FixmeHead{} : rs)) -> do
+          next (P1 l (fromHead h) rs)
+
+        (P1 _ fx (FixmePart l h@FixmeHead{} : rs)) -> do
+          emitFixme fx
+          next (P1 l (fromHead h) rs)
+
+        (P1 _ fx (FixmePart lno (FixmeLine what) : rs)) -> do
+          next (P1 lno (setLno lno $ over (field @"fixmePlain") (<> [FixmePlainLine what]) fx) rs)
+
+        (P1 _ fx (FixmePart lno (FixmeAttr a v) : rs)) -> do
+          next (P1 lno (setLno lno $ over (field @"fixmeAttr") (<> HM.singleton a v) fx) rs)
+
+        (P1 _ fx []) -> emitFixme fx
+        (P0 ( _ : rs ) ) -> next (P0 rs)
+        (P0 []) -> pure ()
+
+  where
+
+    setLno lno fx@Fixme{} = do
+      let lno1 = Just (FixmeOffset (fromIntegral lno))
+      set (field @"fixmeEnd") lno1 fx
+
+    emitFixme e = do
+      S.yield $ over (field @"fixmePlain") dropEmpty e
+      where
+        dropEmpty = dropWhile $ \case
+          FixmePlainLine "" -> True
+          _                 -> False
+
+    -- FIXME: jopakita
+    fromHead = \case
+      FixmeHead lno  _ tag title ->
+          Fixme (FixmeTag tag)
+                (FixmeTitle title)
+                mempty
+                Nothing
+                (Just (FixmeOffset (fromIntegral lno)))
+                Nothing
+                mempty
+                mempty
+
+      _ -> mempty
+
+    emitFixmeStart lno lvl tagbs restbs = do
+      let tag  = decodeUtf8With ignore  (LBS8.toStrict tagbs) & Text.strip
+      let rest = decodeUtf8With ignore  (LBS8.toStrict restbs) & Text.strip
+      S.yield (FixmePart lno (FixmeHead lno lvl tag rest))
+
+    emitFixmeAttr lno _ name val = do
+      S.yield (FixmePart lno (FixmeAttr name val))
+
+    emitFixmeLine lno _ restbs = do
+      let rest = decodeUtf8With ignore  (LBS8.toStrict restbs) & Text.stripEnd
+      S.yield (FixmePart lno (FixmeLine rest))
+
+    eatPrefix0 lim' comments x = do
+      over _2 LBS8.pack <$> do
+
+        flip fix (0, LBS8.unpack x) $ \next w@(k, left) -> do
+
+          let lim = fromMaybe (succ k) lim'
+
+          if k > lim then
+            pure (k, left)
+          else
+            case w of
+              (n, ' '  : rest) -> next (n+1, if k == lim then ' ' : rest else rest)
+              (n, '\t' : rest) -> next (n+8, if k == lim then '\t' : rest else rest)
+
+              (n, rest) -> do
+                let comm = headMay [ co | co <- comments, LBS8.isPrefixOf co (LBS8.pack rest) ]
+                case comm of
+                  Nothing -> pure (n, rest)
+                  Just co -> next (n+1, drop (fromIntegral $ LBS8.length co) rest)
+

fixme-new/lib/Fixme/Scan/Git/Local.hs

@@ -0,0 +1,369 @@
+{-# Language MultiWayIf #-}
+{-# Language PatternSynonyms #-}
+{-# Language ViewPatterns #-}
+module Fixme.Scan.Git.Local where
+
+
+import Prelude hiding (init)
+import Fixme.Prelude hiding (indent)
+import Fixme.Types
+import Fixme.State
+import Fixme.Scan as Scan
+
+import HBS2.Storage
+import HBS2.Storage.Compact
+import HBS2.System.Dir
+import HBS2.Git.Local.CLI
+
+import DBPipe.SQLite hiding (field)
+import Data.Config.Suckless
+import Data.Text.Fuzzy.Tokenize
+
+import Data.ByteString.Char8 qualified as BS
+import Data.ByteString.Lazy.Char8 qualified as LBS8
+import Data.ByteString.Lazy (ByteString)
+import Data.Either
+import Data.Fixed
+import Data.List qualified as List
+import Data.List.Split (chunksOf)
+import Data.Maybe
+import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HM
+import Data.HashSet qualified as HS
+import Data.HashSet (HashSet)
+import Data.Text qualified as Text
+import Data.Text.Encoding (decodeUtf8With)
+import Data.Text.Encoding.Error (ignore)
+import Data.Word
+import Text.InterpolatedString.Perl6 (qc)
+import Data.Coerce
+import Data.Generics.Product.Fields (field)
+import Lens.Micro.Platform
+import System.Process.Typed
+import Control.Monad.Trans.Cont
+import Control.Monad.Trans.Maybe
+import System.IO qualified as IO
+import System.IO.Temp (emptySystemTempFile)
+import System.TimeIt
+
+import Data.Map qualified as Map
+
+import Streaming.Prelude qualified as S
+
+
+{- HLINT ignore "Functor law" -}
+
+
+listCommits :: FixmePerks m => FixmeM m [(GitHash, HashMap FixmeAttrName FixmeAttrVal)]
+listCommits = do
+  gd <- fixmeGetGitDirCLIOpt
+
+  days <- asks fixmeEnvGitScanDays
+            >>= readTVarIO
+            <&> fmap ( \x -> "--since" <+> squotes (pretty x <+> "days ago"))
+            <&> fromMaybe mempty
+            <&> show
+
+  let cmd = [qc|git {gd} log --all --format="%H '%cn' '%ce' %ct" {days}|]
+
+  debug $ yellow "listCommits" <+> pretty cmd
+
+  gitRunCommand cmd
+    <&> fromRight mempty
+    <&> LBS8.lines
+    <&> mapMaybe extract
+
+  where
+    extract :: ByteString -> Maybe (GitHash, HashMap FixmeAttrName FixmeAttrVal)
+    extract lbs = do
+      let txt = decodeUtf8With ignore (LBS8.toStrict lbs)
+      let r = tokenize @Text spec txt
+      case r of
+        [co, n, e, t] -> do
+          let gh = fromStringMay @GitHash (Text.unpack co)
+
+          let bag = [ ("commit", co)
+                    , ("commit-time", t)
+                    , ("committer-name", n)
+                    , ("committer-email", e)
+                    , ("committer", [qc|{n} <{e}>|])
+                    ] & fmap ( over _1 FixmeAttrName . over _2 FixmeAttrVal)
+                      & HM.fromList
+
+          (,) <$> gh <*> pure bag
+
+        _ -> Nothing
+
+    spec = sq <> delims " \t"
+
+listBlobs :: (FixmePerks m, MonadReader FixmeEnv m) => Maybe GitHash -> m [(FilePath,GitHash)]
+listBlobs mco = do
+  gd <- fixmeGetGitDirCLIOpt
+
+  let what = maybe "HEAD" (show . pretty) mco
+
+  gitRunCommand [qc|git {gd} ls-tree -r -l -t {what}|]
+    <&> fromRight mempty
+    <&> fmap LBS8.words . LBS8.lines
+    <&> mapMaybe
+          (\case
+             [a,"blob",h,_,fn] -> (LBS8.unpack fn,) <$> fromStringMay @GitHash (LBS8.unpack h)
+             _                 -> Nothing)
+
+filterBlobs0 :: FixmePerks m
+            => [(Bool,FilePattern)]
+            -> [(FilePath,GitHash)]
+            -> FixmeM m [(FilePath,GitHash)]
+
+filterBlobs0 pat xs = do
+  -- pat <- asks fixmeEnvFileMask >>= readTVarIO <&> fmap (True,)
+  let src = [ ((f,h),f) | (f,h) <- xs ]
+  let r = [(h,f) | (_,(f,h),_) <- matchMany pat src] & HM.fromList & HM.toList
+  pure $ [ (b,a) | (a,b) <- r ]
+
+filterBlobs :: FixmePerks m
+            => [(FilePath,GitHash)]
+            -> FixmeM m [(FilePath,GitHash)]
+
+filterBlobs xs = do
+  pat <- asks fixmeEnvFileMask >>= readTVarIO <&> fmap (True,)
+  filterBlobs0 pat xs
+
+listRelevantBlobs :: FixmePerks m
+                  => FixmeM m [(FilePath, GitHash)]
+listRelevantBlobs =  do
+  commits <- listCommits
+  S.toList_ $ do
+    for_ commits $ \(co, _) -> do
+      found <- lift $ listBlobs (Just co) >>= filterBlobs
+      S.each found
+
+listFixmies :: FixmePerks m
+            => FixmeM m [Fixme]
+listFixmies = do
+
+  flip runContT pure do
+
+      blobs <- lift listRelevantBlobs
+
+      gitCat <- ContT $ bracket startGitCatFile (hClose . getStdin)
+
+      let ssin   = getStdin gitCat
+      let ssout  = getStdout gitCat
+
+      liftIO $ IO.hSetBuffering ssin LineBuffering
+
+      for_ blobs $ \(fp,h) -> do
+        liftIO $ IO.hPrint ssin (pretty h) >> IO.hFlush ssin
+        prefix <- liftIO (BS.hGetLine ssout) <&> BS.words
+
+        case prefix of
+          [bh, "blob", ssize] -> do
+            let mslen = readMay @Int (BS.unpack ssize)
+            len <- ContT $ maybe1 mslen (pure ())
+            blob <- liftIO $ LBS8.hGet ssout len
+            void $ liftIO $ BS.hGetLine ssout
+
+            poor <- lift (Scan.scanBlob (Just fp) blob)
+
+            liftIO $ mapM_ (print . pretty) poor
+
+          _ -> pure ()
+
+
+
+  pure mempty
+
+
+gitListStage :: (FixmePerks m)
+             => FixmeM m [Either (FilePath, GitHash) (FilePath, GitHash)]
+gitListStage = do
+  gd <- fixmeGetGitDirCLIOpt
+  modified <- gitRunCommand [qc|git {gd} status --porcelain|]
+                <&> fromRight mempty
+                <&> fmap LBS8.words . LBS8.lines
+                <&> mapMaybe ( \case
+                       ["M", fn] -> Just (LBS8.unpack fn)
+                       _         -> Nothing
+                    )
+
+  new <- S.toList_ $ do
+            for_ modified $ \fn -> void $ runMaybeT do
+
+              e <- gitRunCommand [qc|git {gd} hash-object {fn}|]
+                     >>= toMPlus
+                     <&> maybe mempty LBS8.unpack . headMay . LBS8.words
+                     <&> fromStringMay @GitHash
+                     >>= toMPlus
+
+              lift (S.yield $ (fn,e))
+
+  old <- gitRunCommand [qc|git {gd} ls-files -s|]
+          <&> fromRight mempty
+          <&> fmap LBS8.words . LBS8.lines
+          <&> mapMaybe ( \case
+                [_, h, _, fn] -> (LBS8.unpack fn,) <$> fromStringMay @GitHash (LBS8.unpack h)
+                _             -> Nothing
+                )
+
+  new1 <- filterBlobs new <&> fmap Left
+  old1 <- filterBlobs old <&> fmap Right
+
+  pure (old1 <> new1)
+
+
+getMetaDataFromGitBlame :: FixmePerks m => FilePath -> Fixme -> FixmeM m Fixme
+getMetaDataFromGitBlame f fx0 = do
+  gd <- fixmeGetGitDirCLIOpt
+  fromMaybe mempty <$> runMaybeT do
+    l0 <- fixmeStart fx0 & toMPlus <&> fromIntegral <&> succ
+    let cmd = [qc|git {gd} blame {f} -L{l0},{l0} -t -l -p|]
+
+    s0 <- gitRunCommand cmd
+             <&> LBS8.unpack . fromRight mempty
+
+    s <- parseTop s0 & toMPlus
+
+    let ko = headMay (words <$> lines s0)
+                   >>= headMay
+                   >>= (\z -> do
+                         if z == "0000000000000000000000000000000000000000"
+                           then Nothing
+                           else Just z )
+                   >>= fromStringMay @GitHash
+
+    pieces <- for s $ \case
+      ListVal (SymbolVal "committer" : StringLikeList  w) | isJust ko -> do
+        let co = FixmeAttrVal $ fromString $ unwords w
+        pure $ mempty { fixmeAttr = HM.singleton "committer-name" co }
+
+      ListVal (SymbolVal "committer-mail" : StringLikeList  w) | isJust ko -> do
+        let co = FixmeAttrVal $ fromString $ unwords w
+        pure $ mempty { fixmeAttr = HM.singleton "committer-email" co }
+
+      ListVal [SymbolVal "committer-time", TimeStampLike t] | isJust ko  -> do
+        let ct = FixmeAttrVal $ fromString $ show t
+        pure $ mempty { fixmeAttr = HM.singleton "commit-time" ct, fixmeTs = Just t }
+
+      _ -> pure mempty
+
+    let coco = mempty { fixmeAttr = maybe mempty (HM.singleton "commit" . fromString . show . pretty) ko }
+
+    pure $ mconcat pieces <> coco
+
+gitExtractFileMetaData :: FixmePerks m => [FilePath] -> FixmeM m (HashMap FilePath Fixme)
+gitExtractFileMetaData fns = do
+  -- FIXME: magic-number
+  let chunks = chunksOf 64 fns
+
+  gd <- fixmeGetGitDirCLIOpt
+
+  commitz <- S.toList_ $ for_ chunks $ \chu -> do
+      let filez = unwords chu
+      let cmd = [qc|git {gd} log --diff-filter=AMR --pretty=format:'entry %H %at "%an" "%ae"' -- {filez}|]
+      ss <- gitRunCommand cmd
+             <&> fromRight mempty
+             <&> fmap LBS8.unpack . LBS8.lines
+
+      for_ ss $ \s -> do
+        let syn = parseTop s & fromRight mempty
+        case syn of
+          [ListVal [SymbolVal "entry", SymbolVal (Id e), LitIntVal t, StringLike n, StringLike m]] -> do
+            -- liftIO $ print $ pretty e <+> pretty syn
+            S.yield (fromString @GitHash (Text.unpack e), (t,n,m) )
+
+          _ -> pure ()
+
+  let co = HM.fromList commitz
+             & HM.toList
+
+  rich0 <- S.toList_ $ do
+    for_ co $ \(c, (t,n,m)) -> do
+      let pat = [ (True, f) | f <- fns ]
+      blobz <- lift $ listBlobs (Just c) >>= filterBlobs0 pat
+
+      for_ blobz $ \(f,h) -> do
+        let attr = HM.fromList [ ("commit",          FixmeAttrVal (fromString $ show $ pretty c))
+                               , ("commit-time",     FixmeAttrVal (fromString $ show $ pretty t))
+                               , ("committer-name",  FixmeAttrVal (fromString n))
+                               , ("committer-email", FixmeAttrVal (fromString m))
+                               , ("committer",       FixmeAttrVal (fromString $ [qc|{n} <{m}>|]))
+                               , ("file",            FixmeAttrVal (fromString f))
+                               , ("blob",            FixmeAttrVal (fromString $ show $ pretty $ h))
+                               ]
+        let what = mempty { fixmeAttr = attr }
+        S.yield (f,t,what)
+
+  let rich = List.sortBy (\a b -> compare (view _2 a) (view _2 b)) rich0
+
+  pure $ HM.fromList [ (view _1 w, view _3 w) | w <- rich ]
+
+
+data GitBlobInfo = GitBlobInfo FilePath GitHash
+                   deriving stock (Eq,Ord,Data,Generic,Show)
+
+instance Hashable GitBlobInfo
+
+data GitIndexEntry =
+       GitCommit Word64 (HashSet GitBlobInfo)
+       deriving stock (Eq,Ord,Data,Generic,Show)
+
+instance Serialise GitBlobInfo
+instance Serialise GitIndexEntry
+
+listCommitForIndex :: forall m . (FixmePerks m, MonadReader FixmeEnv m) => ( (GitHash, GitIndexEntry) -> m ()) -> m ()
+listCommitForIndex fn = do
+
+  gd <- fixmeGetGitDirCLIOpt
+  let cmd = [qc|git {gd} log --all --format="%H %ct"|]
+
+  debug $ yellow "listCommits" <+> pretty cmd
+
+  s0 <- gitRunCommand cmd
+    <&> fromRight mempty
+    <&> fmap (words . LBS8.unpack) . LBS8.lines
+    <&> mapMaybe ( \case
+         [a,b] -> (,) <$> fromStringMay @GitHash a <*> makeIndexEntry0 a b
+         _     -> Nothing
+         )
+
+  for_ s0 $ \(h, GitCommit w _) -> do
+    blobz <- listBlobs (Just h) <&> HS.fromList . fmap ( uncurry GitBlobInfo  )
+    fn (h, GitCommit w blobz)
+
+  where
+    makeIndexEntry0 _ t = GitCommit <$> readMay t <*> pure mempty
+
+gitCatBlob :: (FixmePerks m, MonadReader FixmeEnv m) => GitHash -> m ByteString
+gitCatBlob h = do
+  gd <- fixmeGetGitDirCLIOpt
+  (_,s,_)  <- readProcess $ shell [qc|git {gd} cat-file blob {pretty h}|]
+  pure s
+
+
+startGitHash ::  (FixmePerks m, MonadReader FixmeEnv m) => m (Process Handle Handle ())
+startGitHash = do
+  gd <- fixmeGetGitDirCLIOpt
+  let cmd = [qc|git {gd} hash-object --stdin-paths|]
+  debug $ pretty cmd
+  let config = setStdin createPipe $ setStdout createPipe $ setStderr closed $ shell cmd
+  startProcess config
+
+gitHashPathStdin :: FixmePerks m => (Process Handle Handle e) -> FilePath -> FixmeM m (Maybe GitHash)
+gitHashPathStdin prc file  = do
+  let ssin = getStdin prc
+  let sout = getStdout prc
+  liftIO $ IO.hPutStrLn ssin file >> IO.hFlush ssin
+  liftIO (IO.hGetLine sout) <&> fromStringMay @GitHash
+
+startGitCatFile ::  (FixmePerks m, MonadReader FixmeEnv m) => m (Process Handle Handle ())
+startGitCatFile = do
+  gd <- fixmeGetGitDirCLIOpt
+  let cmd = [qc|git {gd} cat-file --batch|]
+  debug $ pretty cmd
+  let config = setStdin createPipe $ setStdout createPipe $ setStderr closed $ shell cmd
+  -- ssin <- getStdin config
+  startProcess config
+
+
+

fixme-new/lib/Fixme/State.hs

@@ -0,0 +1,599 @@
+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Fixme.State
+  ( evolve
+  , withState
+  , cleanupDatabase
+  , listFixme
+  , countFixme
+  , countByAttribute
+  , insertFixme
+  , insertFixmeExported
+  , modifyFixme
+  , insertScannedFile
+  , insertScanned
+  , selectIsAlreadyScannedFile
+  , selectIsAlreadyScanned
+  , listAllScanned
+  , selectFixmeKey
+  , getFixme
+  , insertTree
+  , FixmeExported(..)
+  , HasPredicate(..)
+  , SelectPredicate(..)
+  , HasLimit(..)
+  , HasItemOrder(..)
+  , ItemOrder(..)
+  , Reversed(..)
+  , LocalNonce(..)
+  , WithLimit(..)
+  , QueryOffset(..)
+  , QueryLimit(..)
+  , QueryLimitClause(..)
+  ) where
+
+import Fixme.Prelude hiding (key)
+import Fixme.Types
+import Fixme.Config
+
+import HBS2.Base58
+import HBS2.System.Dir
+import DBPipe.SQLite hiding (field)
+
+import Data.HashSet (HashSet)
+import Data.HashSet qualified as HS
+import Data.Aeson as Aeson
+import Data.ByteString.Lazy qualified as LBS
+import Data.HashMap.Strict qualified as HM
+import Text.InterpolatedString.Perl6 (qc)
+import Data.Text qualified as Text
+import Data.Text.Encoding qualified as Text
+import Data.Maybe
+import Data.List qualified as List
+import Control.Monad.Trans.Maybe
+import Data.Coerce
+import Data.Word (Word64)
+import System.Directory (getModificationTime)
+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
+
+-- TODO: runPipe-omitted
+--   runPipe нигде не запускается, значит, все изменения
+--   будут закоммичены в БД только по явному вызову
+--   commitAll или transactional
+--   это может объясняеть некоторые артефакты.
+--   Но это и удобно: кажется, что можно менять БД
+--   на лету бесплатно
+
+
+newtype SomeHash h = SomeHash { fromSomeHash :: h }
+                     deriving newtype (IsString)
+
+instance Pretty (AsBase58 h) => ToField (SomeHash h) where
+  toField (SomeHash h) = toField ( show $ pretty (AsBase58 h))
+
+instance IsString (SomeHash h) => FromField (SomeHash h) where
+  fromField = fmap fromString . fromField @String
+
+pattern Operand :: forall {c} . Text -> Syntax c
+pattern Operand what <- (operand -> Just what)
+
+pattern BinOp :: forall {c} . Id -> Syntax c
+pattern BinOp what <- (binOp -> Just what)
+
+binOp :: Syntax c -> Maybe Id
+binOp = \case
+  SymbolVal "~"  -> Just "like"
+  SymbolVal "&&" -> Just "and"
+  SymbolVal "||" -> Just "or"
+  _              -> Nothing
+
+operand :: Syntax c -> Maybe Text
+operand = \case
+  SymbolVal c -> Just (coerce c)
+  LitStrVal s -> Just s
+  LitIntVal i -> Just (Text.pack (show i))
+  LitScientificVal v -> Just (Text.pack (show v))
+  _ -> Nothing
+
+
+instance ToField HashRef where
+  toField x = toField $ show $ pretty x
+
+instance FromField HashRef where
+  fromField = fmap (fromString @HashRef) . fromField @String
+
+evolve :: FixmePerks m => FixmeM  m ()
+evolve = do
+  dbPath <- localDBPath
+  debug $ "evolve" <+> pretty dbPath
+  mkdir (takeDirectory dbPath)
+  withState do
+    createTables
+
+withState :: forall m a . (FixmePerks m, MonadReader FixmeEnv m) => DBPipeM m a ->  m a
+withState what = do
+  lock <- asks fixmeLock
+
+  db <- withMVar lock $ \_ -> do
+          t <- asks fixmeEnvDb
+          mdb <- readTVarIO t
+          case mdb of
+            Just d  -> pure (Right d)
+            Nothing -> do
+              path <- localDBPath
+              newDb <- try @_ @IOException (newDBPipeEnv dbPipeOptsDef path)
+              case newDb of
+                Left e   -> pure (Left e)
+                Right db -> do
+                  debug "set-new-db"
+                  atomically $ writeTVar t (Just db)
+                  pure $ Right db
+
+  either throwIO (`withDB` what) db
+
+createTables :: FixmePerks m => DBPipeM m ()
+createTables = do
+
+  -- ddl [qc| create table if not exists tree
+  --          ( hash   text not null
+  --          , nonce  text not null
+  --          , primary key (hash,nonce)
+  --          )
+  --        |]
+
+  ddl [qc| create table if not exists scanned
+           ( hash text not null primary key )
+         |]
+
+  ddl [qc| create table if not exists object
+           ( o   text    not null
+           , w   integer not null
+           , k   text    not null
+           , v   blob    not null
+           , nonce text  null
+           , primary key (o,k)
+           )
+         |]
+
+
+class HasPredicate a where
+  predicate :: a -> SelectPredicate
+
+class HasLimit a where
+  limit :: a -> Maybe QueryLimitClause
+
+data ItemOrder = Direct | Reverse
+
+class HasItemOrder a where
+  itemOrder :: a -> ItemOrder
+  itemOrder = const Direct
+
+newtype Reversed a = Reversed a
+
+instance HasItemOrder (Reversed a) where
+  itemOrder = const Reverse
+
+-- TODO: move-to-db-pipe?
+newtype QueryOffset = QueryOffset Word64
+                      deriving newtype (Show,Eq,Ord,Num,Enum,Integral,Real,ToField,FromField,Pretty)
+
+-- TODO: move-to-db-pipe?
+newtype QueryLimit = QueryLimit Word64
+                      deriving newtype (Show,Eq,Ord,Num,Enum,Integral,Real,ToField,FromField,Pretty)
+
+type QueryLimitClause = (QueryOffset, QueryLimit)
+
+instance HasLimit () where
+  limit _ = Nothing
+
+data WithLimit q = WithLimit (Maybe QueryLimitClause) q
+
+instance HasItemOrder q => HasItemOrder (WithLimit q) where
+  itemOrder (WithLimit _ q) = itemOrder q
+
+instance HasItemOrder [Syntax c] where
+  itemOrder = const Direct
+
+instance HasItemOrder () where
+  itemOrder = const Direct
+
+instance HasPredicate q => HasPredicate (WithLimit q) where
+  predicate (WithLimit _ query) = predicate query
+
+instance HasLimit (WithLimit a) where
+  limit (WithLimit l _) = l
+
+instance HasPredicate q => HasPredicate (Reversed q) where
+  predicate (Reversed q) = predicate q
+
+instance HasLimit q => HasLimit (Reversed q) where
+  limit (Reversed q) = limit q
+
+data SelectPredicate =
+    All
+  | FixmeHashExactly Text
+  | AttrLike Text Text
+  | And SelectPredicate SelectPredicate
+  | Or SelectPredicate SelectPredicate
+  | Not SelectPredicate
+  | Ignored
+  deriving stock (Data,Generic,Show)
+
+
+instance HasPredicate () where
+  predicate = const All
+
+instance HasPredicate SelectPredicate where
+  predicate = id
+
+instance IsContext c => HasPredicate [Syntax c] where
+  predicate s = goPred $ unlist $ go s
+    where
+
+      goPred :: Syntax c -> SelectPredicate
+      goPred = \case
+        ListVal [SymbolVal "not", a]     ->  Not (goPred a)
+        ListVal [SymbolVal "or", a, b]   ->  Or (goPred a) (goPred b)
+        ListVal [SymbolVal "and", a, b]  ->  And (goPred a) (goPred b)
+        ListVal [SymbolVal "like", StringLike a, StringLike b] ->  AttrLike (Text.pack a) (Text.pack b)
+        _ -> Ignored
+
+      go :: [Syntax c] -> Syntax c
+      go = \case
+
+        ( SymbolVal "!" : rest ) -> do
+            mkList [mkSym "not", unlist (go rest)]
+
+        ( Operand a : SymbolVal "~" : Operand b  : rest ) -> do
+          go (mkList [mkSym "like", mkStr a, mkStr b] : rest)
+
+        ( w : SymbolVal "&&" : rest ) -> do
+          mkList [mkSym "and", unlist w, unlist (go rest)]
+
+        ( w : SymbolVal "||" : rest ) -> do
+          mkList [mkSym "or", unlist w, unlist (go rest)]
+
+        w -> mkList w
+
+      unlist = \case
+        ListVal [x] -> x
+        x -> x
+
+
+{- HLINT ignore "Functor law" -}
+{- HLINT ignore "Eta reduce" -}
+
+data Bound = forall a . (ToField a, Show a) => Bound a
+
+instance ToField Bound where
+  toField (Bound x) = toField x
+
+instance Show Bound where
+  show (Bound x) = show x
+
+genPredQ  :: Text -> SelectPredicate -> (Text, [Bound])
+genPredQ tbl what = go what
+  where
+    go = \case
+      All -> ("true", mempty)
+
+      FixmeHashExactly x ->
+        ([qc|(o.o = ?)|], [Bound x])
+
+      AttrLike name val -> do
+        let x = val <> "%"
+        let binds = [Bound x]
+        ([qc|(json_extract({tbl}.blob, '$."{name}"') like ?)|], binds)
+
+      Not a -> do
+        let (sql, bound) = go a
+        ([qc|(coalesce(not {sql},true))|], bound)
+
+      And a b -> do
+        let (asql, abound) = go a
+        let (bsql, bbound) = go b
+        ([qc|{asql} and {bsql}|], abound <> bbound)
+
+      Or a b -> do
+        let asql = go a
+        let bsql = go b
+        ([qc|{fst asql} or {fst bsql}|], snd asql <> snd bsql)
+
+      Ignored -> ("true", mempty)
+
+
+cleanupDatabase :: (FixmePerks m, MonadReader FixmeEnv m) => m ()
+cleanupDatabase = do
+  warn $ red "cleanupDatabase"
+  withState $ transactional do
+    update_ [qc|delete from object|]
+    update_ [qc|delete from scanned|]
+
+scannedKey :: (FixmePerks m, MonadReader FixmeEnv m) => Fixme -> m HashRef
+scannedKey fme = do
+  magic <- asks fixmeEnvScanMagic >>= readTVarIO
+  let file = fixmeAttr fme & HM.lookup "file"
+  let w  = fixmeTs fme
+  pure $ hashObject @HbSync ( serialise (magic,w,file) ) & HashRef
+
+scannedKeyForFile :: (FixmePerks m, MonadReader FixmeEnv m) => FilePath-> m HashRef
+scannedKeyForFile  file = do
+  dir <- fixmeWorkDir
+  magic <- asks fixmeEnvScanMagic >>= readTVarIO
+  let fn = dir </> file
+  w <- liftIO $ getModificationTime fn <&> round . utcTimeToPOSIXSeconds
+  pure $ hashObject @HbSync ( serialise (magic,w,file) ) & HashRef
+
+selectIsAlreadyScannedFile :: (FixmePerks m, MonadReader FixmeEnv m) => FilePath -> m Bool
+selectIsAlreadyScannedFile file = do
+  k <- scannedKeyForFile file
+  selectIsAlreadyScanned k
+
+selectIsAlreadyScanned :: (FixmePerks m, MonadReader FixmeEnv m) => HashRef -> m Bool
+selectIsAlreadyScanned k = withState do
+  what <- select @(Only Int) [qc|select 1 from scanned where hash = ? limit 1|] (Only k)
+  pure $ not $ List.null what
+
+
+insertTree :: FixmePerks m => HashRef -> FixmeKey -> FixmeAttrName -> DBPipeM m ()
+insertTree h o k = do
+  insert [qc|  insert into tree (hash,o,k)
+               values (?,?,?)
+               on conflict (hash,o,k) do nothing
+         |] (h,o,k)
+
+listAllScanned :: (FixmePerks m, MonadReader FixmeEnv m) => m (HashSet HashRef)
+listAllScanned = withState do
+  select_ [qc|select hash from scanned|] <&> HS.fromList . fmap ( fromSomeHash . fromOnly )
+
+insertScannedFile :: (FixmePerks m, MonadReader FixmeEnv m) => FilePath -> DBPipeM m ()
+insertScannedFile file = do
+  k <- lift $ scannedKeyForFile file
+  insertScanned k
+
+insertScanned:: (FixmePerks m) => HashRef -> DBPipeM m ()
+insertScanned k = do
+  insert [qc| insert into scanned (hash)
+              values(?)
+              on conflict (hash) do nothing|]
+         (Only k)
+
+selectFixmeKey :: (FixmePerks m, MonadReader FixmeEnv m) => Text -> m (Maybe FixmeKey)
+selectFixmeKey s = do
+  withState do
+    select @(Only FixmeKey) [qc|select distinct(o) from object where o like ? order by w desc|] (Only (s<>"%"))
+       <&> fmap fromOnly
+       <&> headMay
+
+
+sqliteToAeson :: FromJSON a => Text -> Maybe a
+sqliteToAeson = Aeson.decode . LBS.fromStrict . Text.encodeUtf8
+
+
+countFixme :: (FixmePerks m, MonadReader FixmeEnv m) => m Int
+countFixme = do
+
+  let present = [qc|coalesce(json_extract(s1.blob, '$.deleted'),'false') <> 'true' |] :: String
+
+  let sql = [qc|
+    with s1 as (
+      select cast (json_insert(json_group_object(o.k, o.v), '$.w', max(o.w)) as text) as blob
+      from object o
+      group by o.o
+    )
+    select count(s1.blob) from s1
+    where
+      {present}
+    |]
+
+  debug $ pretty sql
+
+  withState $ select_ @_ @(Only Int) sql
+    <&> maybe 0 fromOnly . headMay
+
+
+countByAttribute :: ( FixmePerks m
+                    , MonadReader FixmeEnv m
+                    )
+                 => FixmeAttrName
+                 -> m [(FixmeAttrVal, Int)]
+countByAttribute name = do
+  let sql = [qc|
+
+
+    select v, count(1) from object o
+    where not exists
+      ( select null from object o1
+        where o1.o = o.o
+          and o1.k = 'deleted' and o1.v == 'true'
+      )
+    and o.k = ?
+    group by v
+
+    |]
+
+  withState $ select sql (Only name)
+
+listFixme :: ( FixmePerks m
+             , MonadReader FixmeEnv m
+             , HasPredicate q
+             , HasLimit q
+             , HasItemOrder q
+             )
+          => q
+          -> m [Fixme]
+listFixme expr = do
+
+  let (w,bound) = genPredQ "s1" (predicate expr)
+
+  let present = [qc|and coalesce(json_extract(s1.blob, '$.deleted'),'false') <> 'true' |] :: String
+
+  let (limitClause, lbound) = case limit expr of
+                                 Just (o,l) -> ([qc|limit ? offset ?|] :: String, [Bound l, Bound o])
+                                 Nothing -> (mempty, [])
+
+  let o = case itemOrder expr of
+            Direct  -> "asc" :: String
+            Reverse -> "desc"
+
+  let sql = [qc|
+    with s1 as (
+      select cast (json_insert(json_group_object(o.k, o.v), '$.fixme-timestamp', cast(max(o.w) as text)) as text) as blob
+      from object o
+      group by o.o
+    )
+    select s1.blob from s1
+    where
+      {w}
+      {present}
+    order by
+        json_extract(s1.blob, '$.commit-time') {o} nulls last,
+        json_extract(s1.blob, '$.w') {o} nulls last
+    {limitClause}
+    |]
+
+  debug $ pretty sql
+
+  withState $ select @(Only Text) sql (bound <> lbound)
+        <&> fmap (sqliteToAeson . fromOnly)
+        <&> catMaybes
+
+getFixme :: (FixmePerks m, MonadReader FixmeEnv m) => FixmeKey -> m (Maybe Fixme)
+getFixme key = do
+
+  let sql = [qc|
+    select cast (json_insert(json_group_object(o.k, o.v), '$.fixme-timestamp', cast(max(o.w) as text)) as text) as blob
+    from object o
+    where o.o = ?
+    group by o.o
+    limit 1
+    |]
+
+  runMaybeT do
+
+    lift (withState $ select @(Only Text) sql (Only key))
+      <&> fmap (sqliteToAeson . fromOnly)
+      <&> catMaybes
+      <&> headMay
+      >>= toMPlus
+
+
+modifyFixme :: (FixmePerks m)
+            => FixmeKey
+            -> [(FixmeAttrName, FixmeAttrVal)]
+            -> FixmeM m ()
+modifyFixme o a' = do
+  FixmeEnv{..} <- ask
+
+  attrNames <- readTVarIO fixmeEnvAttribs
+  values    <- readTVarIO fixmeEnvAttribValues
+
+  now <- liftIO getPOSIXTime <&> fromIntegral . round
+
+  let a = [ (k,v) | (k,v) <- a'
+          , k `HS.member` attrNames
+          , not (HM.member k values) || v `HS.member` fromMaybe mempty (HM.lookup k values)
+          ]
+
+  let w = mempty { fixmeAttr = HM.fromList a, fixmeKey = o, fixmeTs = Just now }
+
+  withState $ insertFixme w
+
+insertFixme :: (FixmePerks m, MonadReader FixmeEnv m) => Fixme -> DBPipeM m ()
+insertFixme fme = do
+
+  void $ runMaybeT do
+
+    let o = fixmeKey fme
+    w   <-  fixmeTs fme & toMPlus
+    let attrs   = fixmeAttr fme
+    let txt = fixmePlain fme & Text.unlines . fmap coerce
+
+    let sql = [qc|
+      insert into object (o, w, k, v)
+      values (?, ?, ?, ?)
+      on conflict (o, k)
+      do update set
+        v = case
+              when excluded.w > object.w and (excluded.v <> object.v) then excluded.v
+              else object.v
+            end,
+        w = case
+              when excluded.w > object.w and (excluded.v <> object.v) then excluded.w
+              else object.w
+            end,
+        nonce = case when excluded.w > object.w and (excluded.v <> object.v) then excluded.nonce
+                     else object.nonce
+                end
+      |]
+
+    for_ (fixmeStart fme) $ \s -> do
+      lift $ insert sql (o,w,"fixme-start",s)
+
+    for_ (fixmeEnd fme) $ \s -> do
+      lift $ insert sql (o,w,"fixme-end",s)
+
+    for_ (HM.toList attrs) $ \(k,v) -> do
+      lift $ insert sql (o,w,k,v)
+
+    lift $ insert sql (o,w,"fixme-text",txt)
+
+
+data FixmeExported =
+  FixmeExported
+  { exportedKey    :: FixmeKey
+  , exportedWeight :: Word64
+  , exportedName   :: FixmeAttrName
+  , exportedValue  :: FixmeAttrVal
+  }
+  deriving stock Generic
+
+instance FromRow FixmeExported
+instance ToRow  FixmeExported
+instance Serialise FixmeExported
+
+class LocalNonce a where
+  localNonce :: a -> HashRef
+
+instance LocalNonce FixmeExported where
+  localNonce FixmeExported{..} =
+    HashRef $ hashObject @HbSync
+            $ serialise (exportedKey,exportedName,exportedValue,exportedWeight)
+
+instance LocalNonce (HashRef, FixmeExported) where
+  localNonce (h, e) =  HashRef $ hashObject @HbSync
+                               $ serialise (h, localNonce e)
+
+data WithNonce a = WithNonce HashRef a
+
+instance ToRow (WithNonce FixmeExported) where
+  toRow (WithNonce nonce f@FixmeExported{..}) = toRow (exportedKey, exportedWeight, exportedName, exportedValue, nonce)
+
+insertFixmeExported :: FixmePerks m => HashRef -> FixmeExported -> DBPipeM m ()
+insertFixmeExported h item = do
+
+  let sql = [qc|
+
+      insert into object (o, w, k, v, nonce)
+      values (?, ?, ?, ?, ?)
+      on conflict (o, k)
+      do update set
+        v = case
+              when excluded.w > object.w  then excluded.v
+              else object.v
+            end,
+        w = case
+              when excluded.w > object.w  then excluded.w
+              else object.w
+            end,
+        nonce = case
+                  when excluded.w > object.w then excluded.nonce
+                  else object.nonce
+                end
+  |]
+
+  insert sql (WithNonce h item)
+  insertScanned h
+
+

fixme-new/lib/Fixme/Types.hs

@@ -0,0 +1,759 @@
+{-# LANGUAGE PatternSynonyms, ViewPatterns, TemplateHaskell #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Fixme.Types
+  ( module Fixme.Types
+  , module Exported
+  ) where
+
+import Fixme.Prelude hiding (align)
+import HBS2.Base58
+
+import DBPipe.SQLite hiding (field)
+import HBS2.Git.Local
+
+import HBS2.OrDie
+import HBS2.System.Dir
+import HBS2.Storage as Exported
+import HBS2.Peer.CLI.Detect
+import HBS2.Peer.RPC.Client as Exported hiding (encode,decode)
+import HBS2.Peer.RPC.Client.Unix as Exported  hiding (encode,decode)
+import HBS2.Peer.RPC.API.Peer as Exported
+import HBS2.Peer.RPC.API.RefChan as Exported
+import HBS2.Peer.RPC.API.Storage as Exported
+import HBS2.Peer.RPC.Client.StorageClient as Exported
+
+
+import Data.Config.Suckless
+
+import Prettyprinter.Render.Terminal
+import Control.Applicative
+import Data.Aeson as Aeson
+import Data.Aeson.KeyMap as Aeson hiding (null)
+import Data.Aeson.Key qualified as Aeson
+import Data.Aeson.Types as Aeson
+import Data.ByteString (ByteString)
+import Data.ByteString.Char8 qualified as BS8
+import Data.ByteString.Lazy qualified as LBS
+import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HM
+import Data.HashSet (HashSet)
+import Data.HashSet qualified as HS
+import Data.Word (Word64,Word32)
+import Data.Maybe
+import Data.Coerce
+import Data.Text qualified as Text
+import Data.List qualified as List
+import Data.Map qualified as Map
+import System.FilePath
+import Text.InterpolatedString.Perl6 (qc)
+import Data.Generics.Product.Fields (field)
+import Lens.Micro.Platform
+
+
+data MyPeerClientEndpoints =
+  MyPeerClientEndpoints
+  { _peerSocket      :: FilePath
+  , _peerPeerAPI     :: ServiceCaller PeerAPI UNIX
+  , _peerRefChanAPI  :: ServiceCaller RefChanAPI UNIX
+  , _peerStorageAPI  :: ServiceCaller StorageAPI UNIX
+  }
+
+makeLenses 'MyPeerClientEndpoints
+
+-- FIXME: move-to-suckless-conf
+
+pattern FixmeHashLike :: forall {c} . Text -> Syntax c
+pattern FixmeHashLike  e <- (fixmeHashFromSyn -> Just e)
+
+
+pattern TimeStampLike :: forall {c} . FixmeTimestamp -> Syntax c
+pattern TimeStampLike  e <- (tsFromFromSyn -> Just e)
+
+instance MkId FixmeAttrName where
+  mkId (k :: FixmeAttrName) = Id ("$" <> coerce k)
+
+
+
+fixmeHashFromSyn :: Syntax c -> Maybe Text
+fixmeHashFromSyn = \case
+  StringLike s -> do
+    let (_,value) = span (`elem` "#%~:") s
+    Just $ Text.pack value
+
+  _            -> Nothing
+
+tsFromFromSyn :: Syntax c -> Maybe FixmeTimestamp
+tsFromFromSyn = \case
+  LitIntVal n -> Just (fromIntegral n)
+  _ -> Nothing
+
+newtype FixmeTag = FixmeTag { fromFixmeTag :: Text }
+                   deriving newtype (Eq,Ord,Show,IsString,Hashable,Semigroup,Monoid,ToField,FromField,FromJSON,ToJSON)
+                   deriving stock (Data,Generic)
+
+newtype FixmeTitle = FixmeTitle { fromFixmeTitle :: Text }
+                     deriving newtype (Eq,Ord,Show,IsString,Semigroup,Monoid,ToField,FromField,Hashable,FromJSON,ToJSON)
+                     deriving stock (Data,Generic)
+
+newtype FixmePlainLine = FixmePlainLine { fromFixmeText :: Text }
+                         deriving newtype (Eq,Ord,Show,IsString,Semigroup,Monoid,ToField,FromField,FromJSON,ToJSON)
+                         deriving stock (Data,Generic)
+
+
+newtype FixmeAttrName = FixmeAttrName { fromFixmeAttrName :: Text }
+                        deriving newtype (Eq,Ord,Show,IsString,Hashable)
+                        deriving newtype (ToField,FromField)
+                        deriving newtype (ToJSON,FromJSON,ToJSONKey,FromJSONKey)
+                        deriving stock (Data,Generic)
+
+
+newtype FixmeAttrVal = FixmeAttrVal { fromFixmeAttrVal :: Text }
+                        deriving newtype (Eq,Ord,Show,IsString,Hashable,ToField,FromField,ToJSON,FromJSON,Semigroup,Monoid)
+                        deriving stock (Data,Generic)
+
+newtype FixmeTimestamp = FixmeTimestamp Word64
+                        deriving newtype (Eq,Ord,Show,Enum,Num,Integral,Real,ToField,FromField,ToJSON)
+                        deriving stock (Data,Generic)
+
+
+newtype FixmeKey  = FixmeKey Text
+                    deriving newtype (Eq,Ord,Show,ToField,FromField,Pretty,FromJSON,ToJSON,Semigroup,Monoid,IsString)
+                    deriving stock (Data,Generic)
+
+newtype FixmeOffset = FixmeOffset Word32
+                     deriving newtype (Eq,Ord,Show,Num,ToField,FromField,ToJSON)
+                     deriving newtype (Integral,Real,Enum)
+                     deriving stock (Data,Generic)
+
+instance FromStringMaybe FixmeKey where
+  fromStringMay s = pure (fromString s)
+
+
+data Fixme =
+  Fixme
+  { fixmeTag       :: FixmeTag
+  , fixmeTitle     :: FixmeTitle
+  , fixmeKey       :: FixmeKey
+  , fixmeTs        :: Maybe FixmeTimestamp
+  , fixmeStart     :: Maybe FixmeOffset
+  , fixmeEnd       :: Maybe FixmeOffset
+  , fixmePlain     :: [FixmePlainLine]
+  , fixmeAttr      :: HashMap FixmeAttrName FixmeAttrVal
+  }
+  deriving stock (Ord,Eq,Show,Data,Generic)
+
+instance Monoid Fixme where
+  mempty = Fixme mempty mempty mempty Nothing Nothing Nothing mempty mempty
+
+instance Semigroup Fixme where
+  (<>) a b = b { fixmeTs  = fixmeTs b <|> fixmeTs a
+               , fixmeTitle = fixmeAttrNonEmpty (fixmeTitle a) (fixmeTitle b)
+               , fixmeTag   = fixmeAttrNonEmpty (fixmeTag a) (fixmeTag b)
+               , fixmeStart = fixmeStart b <|> fixmeStart a
+               , fixmeEnd = fixmeEnd b <|> fixmeEnd a
+               , fixmePlain = fixmePlain b
+               , fixmeAttr = fixmeAttr a <> fixmeAttr b
+               }
+
+fixmeGet :: FixmeAttrName -> Fixme -> Maybe FixmeAttrVal
+fixmeGet name Fixme{..} = HM.lookup name fixmeAttr
+
+fixmeSet :: FixmeAttrName -> FixmeAttrVal -> Fixme -> Fixme
+fixmeSet name val fx = fx { fixmeAttr = HM.insert name val (fixmeAttr fx) }
+
+instance FromJSON FixmeOffset where
+  parseJSON = \case
+    Number x -> pure (FixmeOffset  (ceiling x))
+
+    String s  -> do
+      n <- maybe (fail "invalid FixmeOffset value") pure (readMay (Text.unpack s))
+      pure $ FixmeOffset n
+
+    _ -> fail "invalid FixmeOffset value"
+
+
+instance FromJSON FixmeTimestamp where
+  parseJSON = \case
+    Number x -> pure (FixmeTimestamp (ceiling x))
+
+    String s  -> do
+      n <- maybe (fail "invalid FixmeOffset value") pure (readMay (Text.unpack s))
+      pure $ FixmeTimestamp n
+
+    _ -> fail "invalid FixmeTimestamp value"
+
+
+instance FromJSON Fixme where
+  parseJSON = withObject "Fixme" $ \o -> do
+    fixmeKey   <- o .:  "fixme-key"
+    fixmeTag   <- o .:  "fixme-tag"
+    fixmeTitle <- o .:  "fixme-title"
+    fixmeStart <- o .:? "fixme-start"
+    fixmeEnd   <- o .:? "fixme-end"
+    fixmeTs    <- o .:? "fixme-timestamp"
+
+    fixmePlainTxt <- o .:? "fixme-text" <&> fromMaybe mempty
+    let fixmePlain = fmap FixmePlainLine (Text.lines fixmePlainTxt)
+
+    let wtf = [ unpackItem k v
+              | (k,v) <- Aeson.toList o
+              , k /= "fixme-text"
+              ] & catMaybes
+
+    let fixmeAttr = HM.fromList wtf
+
+    return Fixme{..}
+
+    where
+      unpackItem k v = do
+        (FixmeAttrName (Aeson.toText k),) <$>
+          case v of
+           String x -> pure (FixmeAttrVal x)
+           Number x -> pure (FixmeAttrVal (Text.pack $ show x))
+           _        -> Nothing
+
+newtype FixmeThin = FixmeThin (HashMap FixmeAttrName FixmeAttrVal)
+                    deriving newtype (Semigroup,Monoid,Eq,Ord,Show,ToJSON,FromJSON)
+                    deriving stock (Data,Generic)
+
+
+
+type FixmePerks m = ( MonadUnliftIO m
+                    , MonadIO m
+                    )
+
+
+data UpdateAction = forall c . IsContext c => UpdateAction { runUpdateAction :: Syntax c -> IO () }
+
+data ReadLogAction = forall c . IsContext c => ReadLogAction { runReadLog :: Syntax c -> IO () }
+
+-- FIXME: fucking-context-hardcode-wtf-1
+data CatAction = CatAction { catAction :: [(Id, Syntax C)] -> LBS.ByteString -> IO () }
+
+data SimpleTemplate = forall c . (IsContext c, Data (Context c), Data c) => SimpleTemplate [Syntax c]
+
+class HasSequence w where
+  getSequence :: w -> Word64
+
+newtype FromFixmeKey a = FromFixmeKey a
+
+data CompactAction =
+    Deleted  Word64 HashRef
+  | Modified Word64 HashRef FixmeAttrName FixmeAttrVal
+  | Added    Word64 Fixme
+  deriving stock (Eq,Ord,Show,Generic)
+
+class MkKey a where
+  mkKey :: a -> ByteString
+
+instance MkKey CompactAction where
+  mkKey (Deleted _ h) = "D" <> LBS.toStrict (serialise h)
+  mkKey (Modified _ h _ _) = "M" <> LBS.toStrict (serialise h)
+  mkKey (Added _ fixme) = "A" <> coerce (hashObject @HbSync $ serialise fixme)
+
+instance MkKey (FromFixmeKey Fixme) where
+  mkKey (FromFixmeKey fx@Fixme{..}) =
+    maybe k2  (mappend "A" . LBS.toStrict . serialise) (HM.lookup "fixme-key" fixmeAttr)
+    where k2 = mappend "A" $ serialise fx & LBS.toStrict
+
+instance IsContext c => MkStr c GitHash  where
+  mkStr ha = mkStr (show $ pretty ha)
+
+instance IsContext c => MkStr c GitRef  where
+  mkStr ha = mkStr (show $ pretty ha)
+
+instance IsContext c => MkStr c HashRef  where
+  mkStr ha = mkStr (show $ pretty ha)
+
+instance IsContext c => MkStr c FixmeAttrVal  where
+  mkStr v = mkStr (coerce @_ @Text v)
+
+instance IsContext c => MkStr c (AsBase58 ByteString) where
+  mkStr v = mkStr (show $ pretty v)
+
+instance IsContext c => MkStr c FixmeAttrName  where
+  mkStr v = mkStr (coerce @_ @Text v)
+
+instance Pretty CompactAction where
+  pretty = \case
+    Deleted s r      -> pretty $ mkList @C [ mkSym "deleted", mkInt s, mkStr r  ]
+    Modified s r k v -> pretty $ mkList @C [ mkSym "modified", mkInt s, mkStr r, mkStr k, mkStr v ]
+    -- FIXME: normal-pretty-instance
+    e@(Added  w fx) -> do
+      pretty $ mkList @C [ mkSym "added", mkStr (AsBase58 $ mkKey e) ]
+
+instance Serialise CompactAction
+
+pattern CompactActionSeq :: Word64 -> CompactAction
+pattern CompactActionSeq s <- (seqOf -> Just s)
+
+{-# COMPLETE CompactActionSeq #-}
+
+seqOf :: CompactAction -> Maybe Word64
+seqOf = \case
+  Deleted   w  _ -> Just w
+  Modified  w _ _ _ -> Just w
+  Added w _ -> Just w
+
+instance HasSequence CompactAction where
+  getSequence x = fromMaybe 0 (seqOf x)
+
+data FixmeTemplate =
+  Simple SimpleTemplate
+
+data RenderError = RenderError String
+                   deriving stock (Eq,Show,Typeable)
+
+class FixmeRenderTemplate a b where
+  render :: a -> Either RenderError b
+
+data FixmeOpts =
+  FixmeOpts
+  { fixmeOptNoEvolve :: Bool
+  }
+  deriving stock (Eq,Ord,Show,Data,Generic)
+
+instance Monoid FixmeOpts where
+  mempty = FixmeOpts False
+
+instance Semigroup FixmeOpts where
+  (<>) _ b = FixmeOpts (fixmeOptNoEvolve b)
+
+data PeerNotConnected = PeerNotConnected
+     deriving (Show,Typeable)
+
+instance Exception PeerNotConnected
+
+data FixmeFlags =
+  FixmeIgnoreCached
+  deriving stock (Eq,Ord,Enum,Show,Generic)
+
+instance Hashable FixmeFlags
+  -- hashWithSalt s e = undefined
+
+
+data FixmeEnv =
+  FixmeEnv
+  { fixmeLock              :: MVar ()
+  , fixmeEnvOpts           :: TVar FixmeOpts
+  , fixmeEnvWorkDir        :: TVar FilePath
+  , fixmeEnvDb             :: TVar (Maybe DBPipeEnv)
+  , fixmeEnvGitDir         :: TVar (Maybe FilePath)
+  , fixmeEnvFileMask       :: TVar [FilePattern]
+  , fixmeEnvFileExclude    :: TVar [FilePattern]
+  , fixmeEnvTags           :: TVar (HashSet FixmeTag)
+  , fixmeEnvAttribs        :: TVar (HashSet FixmeAttrName)
+  , fixmeEnvAttribValues   :: TVar (HashMap FixmeAttrName (HashSet FixmeAttrVal))
+  , fixmeEnvDefComments    :: TVar (HashSet Text)
+  , fixmeEnvFileComments   :: TVar (HashMap FilePath (HashSet Text))
+  , fixmeEnvGitScanDays    :: TVar (Maybe Integer)
+  , fixmeEnvScanMagic      :: TVar (Maybe HashRef)
+  , fixmeEnvUpdateActions  :: TVar [UpdateAction]
+  , fixmeEnvReadLogActions :: TVar [ReadLogAction]
+  , fixmeEnvCatAction      :: TVar CatAction
+  , fixmeEnvTemplates      :: TVar (HashMap Id FixmeTemplate)
+  , fixmeEnvMacro          :: TVar (HashMap Id (Syntax C))
+  , fixmeEnvCatContext     :: TVar (Int,Int)
+  , fixmeEnvMyEndpoints    :: TVar (Maybe MyPeerClientEndpoints)
+  , fixmeEnvRefChan        :: TVar (Maybe (PubKey 'Sign 'HBS2Basic))
+  , fixmeEnvAuthor         :: TVar (Maybe (PubKey 'Sign 'HBS2Basic))
+  , fixmeEnvReader         :: TVar (Maybe (PubKey 'Encrypt 'HBS2Basic))
+  , fixmeEnvFlags          :: TVar (HashSet FixmeFlags)
+  }
+  deriving stock (Generic)
+
+fixmeGetCommentsFor :: FixmePerks m => Maybe FilePath -> FixmeM m [Text]
+
+fixmeGetCommentsFor Nothing = do
+  asks fixmeEnvDefComments >>= readTVarIO
+    <&> HS.toList
+
+fixmeGetCommentsFor (Just fp) = do
+  cof <- asks fixmeEnvFileComments >>= readTVarIO
+  def <- asks fixmeEnvDefComments >>= readTVarIO
+
+  let r = maybe mempty HS.toList (HM.lookup (commentKey fp) cof)
+           <> HS.toList def
+
+  pure r
+
+{- HLINT ignore "Functor law" -}
+
+fixmeGetGitDirCLIOpt :: (FixmePerks m, MonadReader FixmeEnv m) => m String
+fixmeGetGitDirCLIOpt = do
+  asks fixmeEnvGitDir
+          >>= readTVarIO
+          <&> fmap (\d -> [qc|--git-dir {d}|])
+          <&> fromMaybe ""
+
+builtinAttribs :: HashSet FixmeAttrName
+builtinAttribs = HS.singleton "deleted"
+
+builtinAttribVals :: HashMap FixmeAttrName (HashSet FixmeAttrVal)
+builtinAttribVals = HM.fromList [("deleted", HS.fromList ["true","false"])]
+
+newtype FixmeM m a = FixmeM { fromFixmeM :: ReaderT FixmeEnv m a }
+                     deriving newtype ( Applicative
+                                      , Functor
+                                      , Monad
+                                      , MonadIO
+                                      , MonadUnliftIO
+                                      , MonadReader FixmeEnv
+                                      )
+
+
+fixmeEnvBare :: forall m .  FixmePerks m => m FixmeEnv
+fixmeEnvBare = do
+  FixmeEnv
+    <$>  newMVar ()
+    <*>  newTVarIO mempty
+    <*>  (pwd >>= newTVarIO)
+    <*>  newTVarIO Nothing
+    <*>  newTVarIO Nothing
+    <*>  newTVarIO mempty
+    <*>  newTVarIO mempty
+    <*>  newTVarIO mempty
+    <*>  newTVarIO builtinAttribs
+    <*>  newTVarIO builtinAttribVals
+    <*>  newTVarIO mempty
+    <*>  newTVarIO defCommentMap
+    <*>  newTVarIO Nothing
+    <*>  newTVarIO mzero
+    <*>  newTVarIO mempty
+    <*>  newTVarIO mempty
+    <*>  newTVarIO (CatAction $ \_ _ -> pure ())
+    <*>  newTVarIO mempty
+    <*>  newTVarIO mempty
+    <*>  newTVarIO (1,3)
+    <*>  newTVarIO mzero
+    <*>  newTVarIO mzero
+    <*>  newTVarIO mzero
+    <*>  newTVarIO mzero
+    <*>  newTVarIO mempty
+
+withFixmeEnv :: FixmePerks m => FixmeEnv -> FixmeM m a -> m a
+withFixmeEnv env what = runReaderT ( fromFixmeM what) env
+
+instance Serialise FixmeTag
+instance Serialise FixmeTitle
+instance Serialise FixmePlainLine
+instance Serialise FixmeAttrName
+instance Serialise FixmeAttrVal
+instance Serialise FixmeTimestamp
+instance Serialise FixmeOffset
+instance Serialise FixmeKey
+instance Serialise Fixme
+
+
+instance (FixmePerks m, MonadReader FixmeEnv m) => HasClientAPI PeerAPI UNIX m where
+  getClientAPI = getApiOrThrow peerPeerAPI
+
+instance (FixmePerks m, MonadReader FixmeEnv m) => HasClientAPI RefChanAPI UNIX m where
+  getClientAPI = getApiOrThrow peerRefChanAPI
+
+instance (FixmePerks m, MonadReader FixmeEnv m) => HasClientAPI StorageAPI UNIX m where
+  getClientAPI = getApiOrThrow peerStorageAPI
+
+
+instance (FixmePerks m) => HasStorage (FixmeM m) where
+  getStorage = do
+    api <- getClientAPI @StorageAPI @UNIX
+    pure $ AnyStorage (StorageClient api)
+
+getApiOrThrow :: (MonadReader FixmeEnv m, MonadIO m)
+              => Getting b MyPeerClientEndpoints b -> m b
+getApiOrThrow getter =
+    asks fixmeEnvMyEndpoints
+      >>= readTVarIO
+      >>= orThrow PeerNotConnected
+      <&> view getter
+
+instance ToField GitHash where
+  toField h = toField (show $ pretty h)
+
+instance ToField GitRef where
+  toField h = toField (show $ pretty h)
+
+instance FromField GitRef where
+  fromField = fmap fromString . fromField @String
+
+instance FromField GitHash where
+  fromField = fmap fromString . fromField @String
+
+instance Pretty FixmeTimestamp where
+  pretty = pretty . coerce @_ @Word64
+
+instance Pretty FixmeOffset where
+  pretty = pretty . coerce @_ @Word32
+
+instance Pretty FixmeAttrName where
+  pretty = pretty . coerce @_ @Text
+
+instance Pretty FixmeAttrVal where
+  pretty = pretty . coerce @_ @Text
+
+instance Pretty FixmeTitle where
+  pretty = pretty . coerce @_ @Text
+
+instance Pretty FixmeTag where
+  pretty = pretty . coerce @_ @Text
+
+instance Pretty FixmePlainLine where
+  pretty = pretty . coerce @_ @Text
+
+instance Pretty Fixme where
+  pretty Fixme{..} =
+    pretty fixmeTag <+> pretty fixmeTitle
+    <> fstart
+    <> fend
+    <> la
+    <> lls
+    <> line
+    where
+
+      fstart = case fixmeStart of
+        Just s  -> line <> pretty ([qc| $fixme-start: {show $ pretty s}|] :: String)
+        Nothing -> mempty
+
+      fend = case fixmeEnd of
+        Just s  -> line <> pretty ([qc| $fixme-end: {show $ pretty s}|] :: String)
+        Nothing -> mempty
+
+      la | not (HM.null fixmeAttr) = do
+            let a = HM.toList fixmeAttr
+            let ss = [ [qc| ${show $ pretty n}: {show $ pretty v}|]  | (n,v) <- a ]  :: [String]
+            line <> vcat ( fmap pretty ss ) <> line
+
+         | otherwise = mempty
+
+      lls | not (null fixmePlain) =  line <> vcat (fmap pretty fixmePlain)
+          | otherwise = mempty
+
+
+defCommentMap :: HashMap FilePath (HashSet Text)
+defCommentMap = HM.fromList
+  [ comment ".cabal"   ["--"]
+  , comment ".hs"      ["--"]
+  , comment ".c"       ["//"]
+  , comment ".h"       ["//"]
+  , comment ".cc"      ["//"]
+  , comment ".cpp"     ["//"]
+  , comment ".cxx"     ["//"]
+  , comment "Makefile" ["#"]
+  ]
+  where
+    comment a b = (a, HS.fromList b)
+
+commentKey :: FilePath -> FilePath
+commentKey fp =
+  case takeExtension fp of
+    "" -> takeFileName fp
+    xs -> xs
+
+type ContextShit c = (Data c, Data (Context c), IsContext c, Data (Syntax c))
+
+
+cc0 :: forall c . ContextShit c => Context c
+cc0 = noContext :: Context c
+
+inject :: forall c  a . (ContextShit c, Data a) => [(Id,Syntax c)] -> a -> a
+inject repl target =
+  flip transformBi target $ \case
+   (SymbolVal x) | issubst x -> fromMaybe mt (Map.lookup x rmap)
+   other -> other
+   where
+    mt = Literal (noContext @c) (LitStr "")
+    rmap = Map.fromList repl
+    issubst (Id x) = Text.isPrefixOf "$" x
+
+pattern NL :: forall {c}. Syntax c
+pattern NL <- ListVal [SymbolVal "nl"]
+
+
+instance FixmeRenderTemplate SimpleTemplate (Doc AnsiStyle) where
+
+  render (SimpleTemplate syn) = Right $ mconcat $
+      flip fix (mempty,syn) $ \next -> \case
+        (acc, NL : rest)    -> next (acc <> nl, rest)
+        (acc, ListVal [StringLike w] : rest) -> next (acc <> txt w, rest)
+        (acc, StringLike w : rest) -> next (acc <> txt w, rest)
+        (acc, ListVal [SymbolVal "trim", LitIntVal n, e] : rest) -> next (acc <> trim n (deep' [e]), rest)
+        (acc, ListVal [SymbolVal "align", LitIntVal n, e] : rest) -> next (acc <> align n (deep' [e]), rest)
+        (acc, ListVal [SymbolVal "fg", SymbolVal co, e] : rest) -> next (acc <> fmap (fg_ (color_ co)) (deep [e]), rest)
+        (acc, ListVal [SymbolVal "bg", SymbolVal co, e] : rest) -> next (acc <> fmap (bg_ (color_ co)) (deep [e]), rest)
+        (acc, ListVal [SymbolVal "fgd", SymbolVal co, e] : rest) -> next (acc <> fmap (fgd_ (color_ co)) (deep [e]), rest)
+        (acc, ListVal [SymbolVal "bgd", SymbolVal co, e] : rest) -> next (acc <> fmap (bgd_ (color_ co)) (deep [e]), rest)
+
+        (acc, ListVal [ SymbolVal "if", cond
+                      , ListVal (SymbolVal "then" : then_)
+                      , ListVal (SymbolVal "else" : else_)
+                      ] : rest) -> do
+
+          let r = case cond of
+                    ListVal [SymbolVal "~", StringLike p, evaluated -> Just x] ->
+                      Text.isPrefixOf (Text.pack p) x
+                    _ -> False
+
+          next (acc <> if r then deep then_ else deep else_, rest)
+
+
+        (acc, ListVal es : rest) ->  next (acc <> deep es, rest)
+        (acc, e : rest) -> next (acc <> p e, rest)
+        (acc, []) -> acc
+
+    where
+
+      evaluated :: (ContextShit c) => Syntax c -> Maybe  Text
+      evaluated what = Just (deep' [what] & Text.concat)
+
+      color_ = \case
+        "black"   -> Just Black
+        "red"     -> Just Red
+        "green"   -> Just Green
+        "yellow"  -> Just Yellow
+        "blue"    -> Just Blue
+        "magenta" -> Just Magenta
+        "cyan"    -> Just Cyan
+        "white"   -> Just White
+        _         -> Nothing
+
+
+      fg_ = maybe id (annotate . color)
+      bg_ = maybe id (annotate . bgColor)
+
+      fgd_ = maybe id (annotate . colorDull)
+      bgd_ = maybe id (annotate . bgColorDull)
+
+      untxt = fmap pretty
+
+      align n0 s0 | n > 0     = untxt [Text.justifyLeft n ' ' s]
+                  | otherwise = untxt [Text.justifyRight (abs n) ' ' s]
+
+        where
+          n = fromIntegral n0
+          s = mconcat s0
+
+      trim n0 s0 | n >= 0     = untxt [ Text.take n s ]
+                 | otherwise  = untxt [ Text.takeEnd (abs n) s ]
+        where
+          n = fromIntegral n0
+          s = mconcat s0
+
+      deep :: forall c . (ContextShit c) => [Syntax c] -> [Doc AnsiStyle]
+      deep sy = either mempty List.singleton (render (SimpleTemplate sy))
+
+      deep' :: forall c . (ContextShit c) => [Syntax c] -> [Text]
+      deep' sy = do
+        let what = deep sy
+        [ Text.pack (show x) | x <- what]
+
+      nl = [ line ]
+      txt s = [fromString s]
+      p e = untxt [Text.pack (show $ pretty e)]
+
+
+instance FixmeRenderTemplate SimpleTemplate Text where
+  render (SimpleTemplate syn) = Right $ Text.concat $
+      flip fix (mempty,syn) $ \next -> \case
+        (acc, NL : rest)    -> next (acc <> nl, rest)
+        (acc, ListVal [StringLike w] : rest) -> next (acc <> txt w, rest)
+        (acc, StringLike w : rest) -> next (acc <> txt w, rest)
+        (acc, ListVal [SymbolVal "trim", LitIntVal n, e] : rest) -> next (acc <> trim n (deep [e]), rest)
+        (acc, ListVal [SymbolVal "align", LitIntVal n, e] : rest) -> next (acc <> align n (deep [e]), rest)
+        (acc, ListVal es : rest) ->  next (acc <> deep es, rest)
+        (acc, e : rest) -> next (acc <> p e, rest)
+        (acc, []) -> acc
+
+    where
+
+      align n0 s0 | n > 0     = [Text.justifyLeft n ' ' s]
+                  | otherwise = [Text.justifyRight (abs n) ' ' s]
+
+        where
+          n = fromIntegral n0
+          s = mconcat s0
+
+      trim n0 s0 | n >= 0     = [ Text.take n s ]
+                 | otherwise  = [ Text.takeEnd (abs n) s ]
+        where
+          n = fromIntegral n0
+          s = mconcat s0
+
+      deep :: forall c . (ContextShit c) => [Syntax c] -> [Text]
+      deep sy = either mempty List.singleton (render (SimpleTemplate sy))
+
+      nl = [ "\n" ]
+      txt s = [fromString s]
+      p e = [Text.pack (show $ pretty e)]
+
+
+newtype ViaSerialise a = ViaSerialise a
+
+instance Serialise a => Hashed HbSync (ViaSerialise a) where
+  hashObject (ViaSerialise x) = hashObject (serialise x)
+
+
+fixmeTitleNonEmpty :: FixmeTitle -> FixmeTitle -> FixmeTitle
+fixmeTitleNonEmpty a b = case (coerce a :: Text, coerce b :: Text) of
+  (x,y) | Text.null x && not (Text.null y) -> FixmeTitle y
+  (x,y) | not (Text.null x) &&  Text.null y -> FixmeTitle x
+  (_,y) -> FixmeTitle y
+
+fixmeAttrNonEmpty :: Coercible a Text => a -> a -> a
+fixmeAttrNonEmpty a b = case (coerce a :: Text, coerce b :: Text) of
+  (x,y) | Text.null x && not (Text.null y) -> b
+  (x,y) | not (Text.null x) &&  Text.null y -> a
+  (_,_) -> b
+
+fixmeDerivedFields :: Fixme -> Fixme
+fixmeDerivedFields fx = do
+  -- TODO: refactor-this-out
+  --   чревато ошибками, надо как-то переписать
+  --   по-человечески.
+  fxEnd
+  <> fx
+  <> fxKey
+  <> fxCo
+  <> tag
+  <> fxLno
+  <> fxTs
+  -- always last
+  <> fxMisc
+  where
+    email = HM.lookup "commiter-email" (fixmeAttr fx)
+              & maybe mempty (\x -> " <" <> x <> ">")
+
+    comitter = HM.lookup "commiter-name" (fixmeAttr fx)
+                 <&> (<> email)
+
+    tag = mempty { fixmeAttr = HM.singleton "fixme-tag" (FixmeAttrVal (coerce $ fixmeTag fx))  }
+
+    key = HM.singleton "fixme-key" (FixmeAttrVal $ coerce $ (fixmeKey fx))
+
+    fxKey = mempty { fixmeAttr = key }
+
+    lno = succ <$> fixmeStart fx <&> FixmeAttrVal . fromString . show
+
+    fxLno = mempty { fixmeAttr = maybe mempty (HM.singleton "line") lno }
+
+    fxE = join $ for (fixmeStart fx) $ \n -> do
+            Just $ FixmeOffset $ fromIntegral $ fromIntegral n + length (fixmePlain fx)
+
+    fxEnd = mempty { fixmeEnd = fxE }
+
+    fxCo =
+      maybe mempty (\c -> mempty { fixmeAttr = HM.singleton "committer" c }) comitter
+
+    fxTs  =
+      maybe mempty (\c -> mempty { fixmeAttr = HM.singleton "fixme-timestamp" (fromString (show c)) }) (fixmeTs fx)
+
+    fxMisc =
+      fx & over (field @"fixmeAttr")
+                (HM.insert "fixme-title" (FixmeAttrVal (coerce (fixmeTitle fx))))
+
+mkFixmeFileName :: FilePath -> Fixme
+mkFixmeFileName fp =
+  mempty { fixmeAttr = HM.singleton "file" (FixmeAttrVal (fromString fp)) }
+
+

fixme-new/man/man1/fixme-new.1

@@ -0,0 +1 @@
+fixme-new manual

flake.lock

@@ -1,130 +1,15 @@
 {
   "nodes": {
-    "db-pipe": {
-      "inputs": {
-        "haskell-flake-utils": "haskell-flake-utils",
-        "nixpkgs": [
-          "nixpkgs"
-        ]
-      },
-      "locked": {
-        "lastModified": 1708680396,
-        "narHash": "sha256-ZPwDreNdnyCS/hNdaE0OqVhytm+SzZGRfGRTRvBuSzE=",
-        "ref": "refs/heads/master",
-        "rev": "221fde04a00a9c38d2f6c0d05b1e1c3457d5a827",
-        "revCount": 7,
-        "type": "git",
-        "url": "https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft"
-      },
-      "original": {
-        "type": "git",
-        "url": "https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft"
-      }
-    },
-    "fixme": {
-      "inputs": {
-        "haskell-flake-utils": "haskell-flake-utils_2",
-        "nixpkgs": [
-          "nixpkgs"
-        ],
-        "suckless-conf": "suckless-conf"
-      },
-      "locked": {
-        "lastModified": 1697356303,
-        "narHash": "sha256-hJbJZtx7gdcXaKL8n5J8b/eVyoYe9VxM+037ZK7q8Gw=",
-        "ref": "refs/heads/master",
-        "rev": "e9b1dcfd78dc766a2255a8125c14b24f0d728c0e",
-        "revCount": 139,
-        "type": "git",
-        "url": "https://git.hbs2.net/Fujv1Uy4W5d9Z7REEArMxbXSJ8nLLn4dYuvaAs8b86hr"
-      },
-      "original": {
-        "type": "git",
-        "url": "https://git.hbs2.net/Fujv1Uy4W5d9Z7REEArMxbXSJ8nLLn4dYuvaAs8b86hr"
-      }
-    },
     "flake-utils": {
+      "inputs": {
+        "systems": "systems"
+      },
       "locked": {
-        "lastModified": 1644229661,
-        "narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=",
+        "lastModified": 1726560853,
+        "narHash": "sha256-X6rJYSESBVr3hBoH0WbKE5KvhPU5bloyZ2L4K60/fPQ=",
         "owner": "numtide",
         "repo": "flake-utils",
-        "rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797",
-        "type": "github"
-      },
-      "original": {
-        "owner": "numtide",
-        "repo": "flake-utils",
-        "type": "github"
-      }
-    },
-    "flake-utils_2": {
-      "locked": {
-        "lastModified": 1644229661,
-        "narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=",
-        "owner": "numtide",
-        "repo": "flake-utils",
-        "rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797",
-        "type": "github"
-      },
-      "original": {
-        "owner": "numtide",
-        "repo": "flake-utils",
-        "type": "github"
-      }
-    },
-    "flake-utils_3": {
-      "locked": {
-        "lastModified": 1644229661,
-        "narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=",
-        "owner": "numtide",
-        "repo": "flake-utils",
-        "rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797",
-        "type": "github"
-      },
-      "original": {
-        "owner": "numtide",
-        "repo": "flake-utils",
-        "type": "github"
-      }
-    },
-    "flake-utils_4": {
-      "locked": {
-        "lastModified": 1644229661,
-        "narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=",
-        "owner": "numtide",
-        "repo": "flake-utils",
-        "rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797",
-        "type": "github"
-      },
-      "original": {
-        "owner": "numtide",
-        "repo": "flake-utils",
-        "type": "github"
-      }
-    },
-    "flake-utils_5": {
-      "locked": {
-        "lastModified": 1644229661,
-        "narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=",
-        "owner": "numtide",
-        "repo": "flake-utils",
-        "rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797",
-        "type": "github"
-      },
-      "original": {
-        "owner": "numtide",
-        "repo": "flake-utils",
-        "type": "github"
-      }
-    },
-    "flake-utils_6": {
-      "locked": {
-        "lastModified": 1644229661,
-        "narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=",
-        "owner": "numtide",
-        "repo": "flake-utils",
-        "rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797",
+        "rev": "c1dfcf08411b08f6b8615f7d8971a2bfa81d5e8a",
         "type": "github"
       },
       "original": {
@@ -135,68 +20,16 @@
     },
     "haskell-flake-utils": {
       "inputs": {
-        "flake-utils": "flake-utils"
+        "flake-utils": [
+          "flake-utils"
+        ]
       },
       "locked": {
-        "lastModified": 1698938553,
-        "narHash": "sha256-oXpTKXioqFbl2mhhvpJIAvgNd+wYyv4ekI+YnJHEJ6s=",
+        "lastModified": 1707809372,
+        "narHash": "sha256-wfTL9PlCSOqSSyU4eenFFI7pHrV21gba4GEILnI4nAU=",
         "owner": "ivanovs-4",
         "repo": "haskell-flake-utils",
-        "rev": "19b273b5dc401a0a565e7f75cf50a593871b80c9",
-        "type": "github"
-      },
-      "original": {
-        "owner": "ivanovs-4",
-        "repo": "haskell-flake-utils",
-        "type": "github"
-      }
-    },
-    "haskell-flake-utils_2": {
-      "inputs": {
-        "flake-utils": "flake-utils_2"
-      },
-      "locked": {
-        "lastModified": 1672412555,
-        "narHash": "sha256-Kaa8F7nQFR3KuS6Y9WRUxeJeZlp6CCubyrRfmiEsW4k=",
-        "owner": "ivanovs-4",
-        "repo": "haskell-flake-utils",
-        "rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9",
-        "type": "github"
-      },
-      "original": {
-        "owner": "ivanovs-4",
-        "repo": "haskell-flake-utils",
-        "type": "github"
-      }
-    },
-    "haskell-flake-utils_3": {
-      "inputs": {
-        "flake-utils": "flake-utils_3"
-      },
-      "locked": {
-        "lastModified": 1672412555,
-        "narHash": "sha256-Kaa8F7nQFR3KuS6Y9WRUxeJeZlp6CCubyrRfmiEsW4k=",
-        "owner": "ivanovs-4",
-        "repo": "haskell-flake-utils",
-        "rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9",
-        "type": "github"
-      },
-      "original": {
-        "owner": "ivanovs-4",
-        "repo": "haskell-flake-utils",
-        "type": "github"
-      }
-    },
-    "haskell-flake-utils_4": {
-      "inputs": {
-        "flake-utils": "flake-utils_4"
-      },
-      "locked": {
-        "lastModified": 1698938553,
-        "narHash": "sha256-oXpTKXioqFbl2mhhvpJIAvgNd+wYyv4ekI+YnJHEJ6s=",
-        "owner": "ivanovs-4",
-        "repo": "haskell-flake-utils",
-        "rev": "19b273b5dc401a0a565e7f75cf50a593871b80c9",
+        "rev": "3cbdc5d6093e8b4464ae64097e0c8c61e4414ff2",
         "type": "github"
       },
       "original": {
@@ -206,46 +39,11 @@
         "type": "github"
       }
     },
-    "haskell-flake-utils_5": {
-      "inputs": {
-        "flake-utils": "flake-utils_5"
-      },
-      "locked": {
-        "lastModified": 1672412555,
-        "narHash": "sha256-Kaa8F7nQFR3KuS6Y9WRUxeJeZlp6CCubyrRfmiEsW4k=",
-        "owner": "ivanovs-4",
-        "repo": "haskell-flake-utils",
-        "rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9",
-        "type": "github"
-      },
-      "original": {
-        "owner": "ivanovs-4",
-        "repo": "haskell-flake-utils",
-        "rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9",
-        "type": "github"
-      }
-    },
-    "haskell-flake-utils_6": {
-      "inputs": {
-        "flake-utils": "flake-utils_6"
-      },
-      "locked": {
-        "lastModified": 1672412555,
-        "narHash": "sha256-Kaa8F7nQFR3KuS6Y9WRUxeJeZlp6CCubyrRfmiEsW4k=",
-        "owner": "ivanovs-4",
-        "repo": "haskell-flake-utils",
-        "rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9",
-        "type": "github"
-      },
-      "original": {
-        "owner": "ivanovs-4",
-        "repo": "haskell-flake-utils",
-        "type": "github"
-      }
-    },
     "hspup": {
       "inputs": {
-        "haskell-flake-utils": "haskell-flake-utils_5",
+        "haskell-flake-utils": [
+          "haskell-flake-utils"
+        ],
         "nixpkgs": [
           "nixpkgs"
         ]
@@ -266,11 +64,11 @@
     },
     "nixpkgs": {
       "locked": {
-        "lastModified": 1707451808,
-        "narHash": "sha256-UwDBUNHNRsYKFJzyTMVMTF5qS4xeJlWoeyJf+6vvamU=",
+        "lastModified": 1727089097,
+        "narHash": "sha256-ZMHMThPsthhUREwDebXw7GX45bJnBCVbfnH1g5iuSPc=",
         "owner": "nixos",
         "repo": "nixpkgs",
-        "rev": "442d407992384ed9c0e6d352de75b69079904e4e",
+        "rev": "568bfef547c14ca438c56a0bece08b8bb2b71a9c",
         "type": "github"
       },
       "original": {
@@ -282,74 +80,26 @@
     },
     "root": {
       "inputs": {
-        "db-pipe": "db-pipe",
-        "fixme": "fixme",
-        "haskell-flake-utils": "haskell-flake-utils_4",
+        "flake-utils": "flake-utils",
+        "haskell-flake-utils": "haskell-flake-utils",
         "hspup": "hspup",
-        "nixpkgs": "nixpkgs",
-        "saltine": "saltine",
-        "suckless-conf": "suckless-conf_2"
+        "nixpkgs": "nixpkgs"
       }
     },
-    "saltine": {
-      "flake": false,
+    "systems": {
       "locked": {
-        "lastModified": 1651348885,
-        "narHash": "sha256-0guvfkdOrofElDildQWE8QDwh+T/u2WY3HVYmOu4g3w=",
-        "owner": "tel",
-        "repo": "saltine",
-        "rev": "3d3a54cf46f78b71b4b55653482fb6f4cee6b77d",
+        "lastModified": 1681028828,
+        "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
+        "owner": "nix-systems",
+        "repo": "default",
+        "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
         "type": "github"
       },
       "original": {
-        "owner": "tel",
-        "repo": "saltine",
-        "rev": "3d3a54cf46f78b71b4b55653482fb6f4cee6b77d",
+        "owner": "nix-systems",
+        "repo": "default",
         "type": "github"
       }
-    },
-    "suckless-conf": {
-      "inputs": {
-        "haskell-flake-utils": "haskell-flake-utils_3",
-        "nixpkgs": [
-          "fixme",
-          "nixpkgs"
-        ]
-      },
-      "locked": {
-        "lastModified": 1697354514,
-        "narHash": "sha256-5doedGj2QU4vPuw1VZor1GGEJTxu0zFeO/PsybFIcn8=",
-        "owner": "voidlizard",
-        "repo": "suckless-conf",
-        "rev": "3f87278bc10ac4f14a6d9d2c75cbbed228509129",
-        "type": "github"
-      },
-      "original": {
-        "owner": "voidlizard",
-        "repo": "suckless-conf",
-        "type": "github"
-      }
-    },
-    "suckless-conf_2": {
-      "inputs": {
-        "haskell-flake-utils": "haskell-flake-utils_6",
-        "nixpkgs": [
-          "nixpkgs"
-        ]
-      },
-      "locked": {
-        "lastModified": 1704001322,
-        "narHash": "sha256-D7T/8wAg5J4KkRw0uB90w3+adY11aQaX7rjmQPXkkQc=",
-        "ref": "refs/heads/master",
-        "rev": "8cfc1272bb79ef6ad62ae6a625f21e239916d196",
-        "revCount": 28,
-        "type": "git",
-        "url": "https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ"
-      },
-      "original": {
-        "type": "git",
-        "url": "https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ"
-      }
     }
   },
   "root": "root",

flake.nix

@@ -5,69 +5,127 @@ inputs = {
 
     nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable";
     # haskell-flake-utils.url = "github:ivanovs-4/haskell-flake-utils";
-    haskell-flake-utils.url = "github:ivanovs-4/haskell-flake-utils/master";
+    flake-utils.url = "github:numtide/flake-utils";
+    haskell-flake-utils = { # we don't use haskell-flake-utils directly, but we override input evrywhere
+        url = "github:ivanovs-4/haskell-flake-utils/master";
+        inputs.flake-utils.follows = "flake-utils";
+    };
     hspup.url = "github:voidlizard/hspup";
     hspup.inputs.nixpkgs.follows = "nixpkgs";
-
-    fixme.url = "git+https://git.hbs2.net/Fujv1Uy4W5d9Z7REEArMxbXSJ8nLLn4dYuvaAs8b86hr";
-    fixme.inputs.nixpkgs.follows = "nixpkgs";
-
-    suckless-conf.url = "git+https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ";
-    suckless-conf.inputs.nixpkgs.follows = "nixpkgs";
-
-    db-pipe.url = "git+https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft";
-    db-pipe.inputs.nixpkgs.follows = "nixpkgs";
-
-    saltine = {
-      url = "github:tel/saltine/3d3a54cf46f78b71b4b55653482fb6f4cee6b77d";
-      flake = false;
-    };
+    hspup.inputs.haskell-flake-utils.follows = "haskell-flake-utils";
 
 };
 
-outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
+outputs = { self, nixpkgs, flake-utils, ... }@inputs:
   let
-    packageNames = [
+    packageNames =
+      topLevelPackages ++ keymanPackages;
+
+    keymanPackages =
+      [
+      "hbs2-keyman"
+      "hbs2-keyman-direct-lib"
+      ];
+
+    topLevelPackages =
+      [
       "hbs2"
       "hbs2-peer"
       "hbs2-core"
       "hbs2-storage-simple"
-     "hbs2-git"
-     "hbs2-qblf"
-     "hbs2-keyman"
-     "hbs2-share"
-     "hbs2-fixer"
+      "hbs2-storage-ncq"
+      "hbs2-git3"
+      "hbs2-cli"
+      "hbs2-sync"
+      "hbs2-log-structured"
+      "fixme-new"
+      "suckless-conf"
       ];
+
+    miscellaneous =
+      [
+      "bytestring-mmap"
+      "db-pipe"
+      "fuzzy-parse"
+      "suckless-conf"
+      ];
+
+    jailbreakUnbreak = pkgs: pkg:
+        pkgs.haskell.lib.doJailbreak (pkg.overrideAttrs (_: { meta = { }; }));
+
+    # gitHbs2Script = pkgs.stdenv.mkDerivation {
+    #   pname = "git-hbs2";
+    #   version = "1.0";
+    #   src = ./hbs2-git3/bf6;
+    #   installPhase = ''
+    #     mkdir -p $out/bin
+    #     install -m755 git-hbs2 $out/bin/git-hbs2
+    #   '';
+    # };
+
+    hpOverridesPre = pkgs: new: old: with pkgs.haskell.lib; {
+      scotty = new.callHackage "scotty" "0.21" {};
+      skylighting-lucid = new.callHackage "skylighting-lucid" "1.0.4" { };
+      wai-app-file-cgi = dontCoverage (dontCheck (jailbreakUnbreak pkgs old.wai-app-file-cgi));
+      libyaml =
+        if pkgs.hostPlatform.isStatic
+          then old.libyaml.overrideDerivation (drv: {
+            postPatch = let sed = "${pkgs.gnused}/bin/sed"; in ''
+              ${sed} -i -e 's/buffer_init/snoyberg_buffer_init/' c/helper.c include/helper.h
+              ${sed} -i -e 's/"buffer_init"/"snoyberg_buffer_init"/' src/Text/Libyaml.hs
+            '';
+          })
+          else old.libyaml;
+    };
+
+    overrideComposable = pkgs: hpkgs: overrides:
+      hpkgs.override (oldAttrs: {
+        overrides = pkgs.lib.composeExtensions (oldAttrs.overrides or (_: _: { })) overrides;
+      });
+
+    makePkgsFromDirOverride = pkgs: ov: pkgNames: mkPath:
+      pkgs.lib.genAttrs pkgNames (name:
+        ov (pkgs.haskellPackages.callCabal2nix name "${self}/${mkPath name}" {})
+      );
+
+    makePkgsFromDir = pkgs: makePkgsFromDirOverride pkgs (q: q);
+    makePkgsFromDirWithMan = pkgs: makePkgsFromDirOverride pkgs (q:
+      q.overrideDerivation (drv: {
+          postInstall = ''
+            if [ -d man ]; then
+              mkdir -p $out
+              cp -r man $out/
+            fi
+          '';
+        })
+    );
+
+    ourHaskellPackages = pkgs: ({}
+      // makePkgsFromDirWithMan pkgs topLevelPackages (n: n)
+      // makePkgsFromDirWithMan pkgs keymanPackages (name: "hbs2-keyman/${name}")
+      // makePkgsFromDir pkgs miscellaneous (name: "miscellaneous/${name}")
+    );
+
+    overlay = final: prev: {
+      haskellPackages = overrideComposable prev prev.haskellPackages
+        (new: old:
+          hpOverridesPre prev new old
+            // ourHaskellPackages final
+        );
+      };
+
   in
- haskell-flake-utils.lib.simpleCabalProject2flake {
-   inherit self nixpkgs;
-   systems = [ "x86_64-linux" "aarch64-linux" "x86_64-darwin" "aarch64-darwin" ];
-   name = "hbs2";
-
-   haskellFlakes = with inputs; [
-     suckless-conf
-     db-pipe
-   ];
-
-   inherit packageNames;
-
-   packageDirs = {
-     "hbs2"        = "./hbs2";
-     "hbs2-tests"  = "./hbs2-tests";
-     "hbs2-core"   = "./hbs2-core";
-     "hbs2-storage-simple" = "./hbs2-storage-simple";
-     "hbs2-peer"   = "./hbs2-peer";
-     "hbs2-keyman" = "./hbs2-keyman";
-     "hbs2-share"  = "./hbs2-share";
-     "hbs2-git"    = "./hbs2-git";
-     "hbs2-fixer"  = "./hbs2-fixer";
+  { overlays.default = overlay; }
+  //
+  (flake-utils.lib.eachSystem ["x86_64-linux" "aarch64-linux" "x86_64-darwin" "aarch64-darwin"]
+  (system:
+    let
+      pkgs = import nixpkgs {
+        inherit system;
+        overlays = [overlay];
       };
 
-   hpPreOverrides = {pkgs, ...}: final: prev: with pkgs; {
-     saltine = prev.callCabal2nix "saltine" inputs.saltine { inherit (pkgs) libsodium; };
-   };
-
-   packagePostOverrides = { pkgs }: with pkgs; with haskell.lib; [
+      packagePostOverrides = pkg: with pkgs.haskell.lib.compose; pkgs.lib.pipe pkg [
         disableExecutableProfiling
         disableLibraryProfiling
         dontBenchmark
@@ -81,35 +139,71 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
 
         dontCheck
 
-    (compose.overrideCabal (drv: {
+        (overrideCabal (drv: {
             preBuild = ''
               export GIT_HASH="${self.rev or self.dirtyRev or "dirty"}"
               '';
+             disallowGhcReference = false;
           }))
-
       ];
 
-   shell = {pkgs, ...}:
-      pkgs.haskellPackages.shellFor {
-        packages = _: pkgs.lib.attrsets.attrVals packageNames pkgs.haskellPackages;
+    makePackages = pkgs:
+      let ps = pkgs.lib.mapAttrs
+        (_name: packagePostOverrides) # we can't apply overrides inside our overlay because it will remove linking info
+        (pkgs.lib.getAttrs packageNames (ourHaskellPackages pkgs))
+        ;
+      in ps // {
+        bf6-git-hbs2 = pkgs.callPackage ./nix/bf6-hbs2-git.nix { inherit (ps) suckless-conf; };
+      };
+
+    packagesDynamic = makePackages pkgs;
+    packagesStatic = makePackages pkgs.pkgsStatic;
+    in  {
+    legacyPackages = pkgs;
+    homeManagerModules.default = import ./nix/hm-module.nix self;
+
+    packages =
+      packagesDynamic //
+      {
+        default =
+        pkgs.symlinkJoin {
+          name = "hbs2-all";
+          paths = builtins.attrValues packagesDynamic;
+        };
+        static =
+        pkgs.symlinkJoin {
+          name = "hbs2-static";
+          paths = builtins.attrValues packagesStatic;
+        };
+      };
+
+
+    devShells.default = pkgs.haskellPackages.shellFor {
+      packages = p: builtins.attrValues (ourHaskellPackages pkgs) ++ [
+        p.skylighting-core  # needed for hbs2-tests which we did not expose
+      ];
       # withHoogle = true;
       buildInputs = (
-          with pkgs.haskellPackages; ([
+        with pkgs.haskellPackages; [
+          ghc
           ghcid
           cabal-install
           haskell-language-server
           hoogle
-            htags
+          # htags
           text-icu
           magic
           pkgs.icu72
           pkgs.openssl
           weeder
-          ])
+        ]
         ++
         [ pkgs.pkg-config
+          pkgs.libsodium
+          pkgs.file
+          pkgs.zlib
+          pkgs.fuse
           inputs.hspup.packages.${pkgs.system}.default
-            inputs.fixme.packages.${pkgs.system}.default
         ]
       );
 
@@ -118,6 +212,8 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
       '';
 
     };
- };
+  }
+ ));
 
 }
+

hbs2-cli/LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2024, Dmitry Zuikov
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Dmitry Zuikov nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

hbs2-cli/app/Main.hs

@@ -0,0 +1,136 @@
+{-# Language AllowAmbiguousTypes #-}
+{-# Language UndecidableInstances #-}
+module Main where
+
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run
+import HBS2.CLI.Run.Help
+import HBS2.CLI.Run.KeyMan
+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 HBS2.CLI.NCQ3.Migrate
+
+import Data.Config.Suckless.Script.File as SF
+
+import HBS2.Peer.RPC.Client.Unix
+
+import HBS2.Net.Auth.Schema()
+
+import System.Environment
+import System.IO qualified as IO
+
+type RefLogId = PubKey 'Sign 'HBS2Basic
+
+{- HLINT ignore "Functor law" -}
+
+
+setupLogger :: MonadIO m => m ()
+setupLogger = do
+  -- setLogging @DEBUG  $ toStderr . logPrefix "[debug] "
+  setLogging @ERROR  $ toStderr . logPrefix "[error] "
+  setLogging @WARN   $ toStderr . logPrefix "[warn] "
+  setLogging @NOTICE $ toStderr . logPrefix ""
+  setLogging @INFO   $ toStderr . logPrefix ""
+  pure ()
+
+flushLoggers :: MonadIO m => m ()
+flushLoggers = do
+  silence
+
+silence :: MonadIO m => m ()
+silence = do
+  setLoggingOff @DEBUG
+  setLoggingOff @ERROR
+  setLoggingOff @WARN
+  setLoggingOff @NOTICE
+
+
+main :: IO ()
+main = do
+
+  setupLogger
+
+  cli <- getArgs <&> unlines . fmap unwords . splitForms
+           >>= either (error.show) pure . parseTop
+
+  let runScript dict argz what = liftIO do
+        script <- either (error.show) pure $ parseTop what
+        runHBS2Cli $ recover $ runM dict do
+          bindCliArgs argz
+          void $ evalTop script
+
+  let dict = makeDict do
+
+        internalEntries
+        keymanEntries
+        keyringEntries
+        groupKeyEntries
+        sigilEntries
+        treeEntries
+        metaDataEntries
+        peerEntries
+        reflogEntries
+        refchanEntries
+        lwwRefEntries
+        mailboxEntries
+        migrateEntries
+        helpEntries
+
+        SF.entries
+
+        entry $ bindMatch "--help" $ nil_ \case
+          HelpEntryBound what -> helpEntry what
+          [StringLike s]      -> helpList False (Just s)
+          _                   -> helpList False Nothing
+
+        entry $ bindMatch "debug:cli:show" $ nil_ \case
+          _ -> display cli
+
+        entry $ bindMatch "#!" $ nil_ $ const none
+
+        entry $ bindMatch "stdin" $ nil_ $ \case
+          argz  -> do
+            liftIO getContents >>= runScript dict argz
+
+        entry $ bindMatch "file" $ nil_ $ \case
+          ( StringLike fn : argz ) -> do
+            liftIO (readFile fn) >>= runScript dict argz
+
+          e -> error (show $ pretty $ mkList e)
+
+  runHBS2Cli do
+
+    -- error (show $ pretty cli)
+
+    case cli of
+
+      ( cmd@(ListVal [StringLike "file", StringLike fn]) : _ ) -> do
+        void $ run dict [cmd]
+
+      ( cmd@(ListVal [StringLike "stdin"]) : _ ) -> do
+        void $ run dict [cmd]
+
+      ( cmd@(ListVal [StringLike "--help"]) : _ ) -> do
+        void $ run dict [cmd]
+
+      [] -> do
+        eof <- liftIO IO.isEOF
+        if eof then
+          void $ run dict [mkForm  "help" []]
+        else do
+          what <- liftIO getContents
+                    >>= either (error.show) pure . parseTop
+
+          recover $ run dict what >>= eatNil display
+
+      _ -> do
+        recover $ run dict cli >>= eatNil display
+

hbs2-cli/hbs2-cli.cabal

@@ -0,0 +1,146 @@
+cabal-version:      3.0
+name:               hbs2-cli
+version:            0.25.3.0
+-- synopsis:
+-- description:
+license:            BSD-3-Clause
+license-file:       LICENSE
+author:             Dmitry Zuikov
+-- copyright:
+category:           System
+build-type:         Simple
+-- extra-doc-files:    CHANGELOG.md
+-- extra-source-files:
+
+common shared-properties
+  ghc-options:
+        -Wall
+        -fno-warn-type-defaults
+        -threaded
+        -rtsopts
+        -O2
+        "-with-rtsopts=-N4 -A64m -AL256m -I0"
+
+  default-language: GHC2021
+
+  default-extensions:
+                       ApplicativeDo
+                     , BangPatterns
+                     , BlockArguments
+                     , ConstraintKinds
+                     , DataKinds
+                     , DeriveDataTypeable
+                     , DeriveGeneric
+                     , DerivingStrategies
+                     , DerivingVia
+                     , ExtendedDefaultRules
+                     , FlexibleContexts
+                     , FlexibleInstances
+                     , GADTs
+                     , GeneralizedNewtypeDeriving
+                     , ImportQualifiedPost
+                     , LambdaCase
+                     , MultiParamTypeClasses
+                     , OverloadedStrings
+                     , QuasiQuotes
+                     , RecordWildCards
+                     , ScopedTypeVariables
+                     , StandaloneDeriving
+                     , TupleSections
+                     , TypeApplications
+                     , TypeFamilies
+                     , PatternSynonyms
+                     , ViewPatterns
+
+
+  build-depends:
+        hbs2-core
+      , hbs2-peer
+      , hbs2-storage-simple
+      , hbs2-storage-ncq
+      , hbs2-keyman-direct-lib
+      , db-pipe
+      , suckless-conf
+
+      , attoparsec
+      , atomic-write
+      , bytestring
+      , binary
+      , containers
+      , directory
+      , exceptions
+      , filepath
+      , filepattern
+      , generic-lens
+      , hashable
+      , interpolatedstring-perl6
+      , memory
+      , microlens-platform
+      , mtl
+      , safe
+      , serialise
+      , streaming
+      , stm
+      , text
+      , time
+      , timeit
+      , transformers
+      , typed-process
+      , unordered-containers
+      , unliftio
+      , unliftio-core
+      , zlib
+      , prettyprinter
+      , prettyprinter-ansi-terminal
+      , random
+      , vector
+      , unix
+      , split
+
+
+library
+    import:           shared-properties
+
+    exposed-modules:
+      HBS2.CLI
+      HBS2.CLI.Prelude
+      HBS2.CLI.Bind
+      HBS2.CLI.Run
+      HBS2.CLI.Run.Internal
+      HBS2.CLI.Run.Internal.GroupKey
+      HBS2.CLI.Run.Internal.Merkle
+      HBS2.CLI.Run.Internal.KeyMan
+      HBS2.CLI.Run.Internal.RefChan
+      HBS2.CLI.Run.Internal.RefLog
+      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.NCQ3.Migrate
+
+    build-depends:    base
+                    , magic
+
+    hs-source-dirs:   lib
+
+
+executable hbs2-cli
+    import:           shared-properties
+    main-is:          Main.hs
+    -- other-modules:
+    -- other-extensions:
+    build-depends:
+          base, hbs2-cli
+
+    hs-source-dirs:   app
+    default-language: GHC2021
+

hbs2-cli/lib/HBS2/CLI.hs

@@ -0,0 +1 @@
+module HBS2.CLI where

hbs2-cli/lib/HBS2/CLI/Bind.hs

@@ -0,0 +1,4 @@
+module HBS2.CLI.Bind where
+
+import HBS2.CLI.Prelude
+

hbs2-cli/lib/HBS2/CLI/NCQ3/Migrate.hs

@@ -0,0 +1,57 @@
+{-# Language AllowAmbiguousTypes #-}
+module HBS2.CLI.NCQ3.Migrate where
+
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run.Internal
+
+import HBS2.Peer.NCQ3.Migrate.NCQ
+
+import HBS2.Net.Auth.Schema()
+import HBS2.Peer.RPC.API.Peer
+import HBS2.Peer.RPC.Client
+import HBS2.Peer.RPC.Client.Unix
+import HBS2.Storage
+import HBS2.Storage.NCQ3.Internal.Prelude
+import HBS2.Peer.Proto.RefLog
+import HBS2.Peer.Proto.RefChan
+import HBS2.Peer.Proto.LWWRef
+
+import Streaming.Prelude qualified as S
+
+migrateEntries :: forall c m . ( MonadUnliftIO m
+                               , IsContext c
+                               , Exception (BadFormException c)
+                               , HasClientAPI PeerAPI UNIX m
+                               , HasStorage m
+                               ) => MakeDictM c m ()
+migrateEntries = do
+  brief "migrate NCQv1 => NCQ3"
+   $ args [ arg "path" "src"
+          , arg "path" "dst"
+          ]
+
+   $ entry $ bindMatch "ncq3:migrate:ncq" $ nil_ $ \case
+       [ StringLike src, StringLike dst] -> do
+
+        api <- getClientAPI @PeerAPI  @UNIX
+
+        refs <- callRpcWaitMay @RpcPollList2 (1.0 :: Timeout 'Seconds) api (Nothing, Nothing)
+                  <&> fromMaybe mempty
+
+        rrefs <- S.toList_ <$> for refs $ \(pk, s, _) -> case s of
+                   "reflog"  -> S.yield (WrapRef $ RefLogKey @'HBS2Basic pk)
+
+                   "refchan" -> do
+                      S.yield (WrapRef $ RefChanLogKey @'HBS2Basic pk)
+                      S.yield (WrapRef $ RefChanHeadKey @'HBS2Basic pk)
+
+                   "lwwref"  -> S.yield (WrapRef $ LWWRefKey @'HBS2Basic pk)
+                   _         -> none
+
+        lift $ migrateNCQ1 nicelog rrefs src dst
+
+       e -> throwIO $ BadFormException (mkList e)
+
+nicelog :: forall m . MonadIO  m => Doc AnsiStyle -> m ()
+nicelog doc = liftIO $ hPutDoc stdout (doc <> line)
+

hbs2-cli/lib/HBS2/CLI/Prelude.hs

@@ -0,0 +1,28 @@
+module HBS2.CLI.Prelude
+  ( module HBS2.Prelude.Plated
+  , module HBS2.OrDie
+  , module UnliftIO
+  , module Data.Config.Suckless
+  , module Data.HashMap.Strict
+  , module Control.Monad.Reader
+  , module HBS2.System.Logger.Simple.ANSI
+  , module HBS2.Misc.PrettyStuff
+  , qc,qq,q
+  , Generic
+  , pattern SignPubKeyLike
+  ) where
+
+import HBS2.Prelude.Plated
+import HBS2.OrDie
+import HBS2.System.Logger.Simple.ANSI
+import HBS2.Misc.PrettyStuff
+import HBS2.Net.Auth.Credentials
+
+import Data.HashMap.Strict
+import Data.Config.Suckless
+
+import Control.Monad.Reader
+import UnliftIO
+
+import Text.InterpolatedString.Perl6 (qc,q,qq)
+

hbs2-cli/lib/HBS2/CLI/Run.hs

@@ -0,0 +1,9 @@
+{-# Language UndecidableInstances #-}
+module HBS2.CLI.Run
+  ( module HBS2.CLI.Run.Internal
+  ) where
+
+import HBS2.CLI.Run.Internal
+
+
+

hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs

@@ -0,0 +1,200 @@
+module HBS2.CLI.Run.GroupKey
+  ( module HBS2.CLI.Run.GroupKey
+  , loadGroupKey
+  ) where
+
+import HBS2.CLI.Prelude hiding (mapMaybe)
+
+import HBS2.Data.Types.Refs
+import HBS2.Storage.Operations.Class
+import HBS2.Storage.Operations.ByteString
+import HBS2.Base58
+import HBS2.CLI.Run.Internal
+import HBS2.CLI.Run.Internal.GroupKey as G
+import HBS2.Net.Auth.GroupKeySymm as Symm
+import HBS2.Storage
+
+import HBS2.KeyMan.Keys.Direct
+
+import HBS2.Peer.RPC.API.Storage
+import HBS2.Peer.RPC.Client
+import HBS2.Peer.RPC.Client.Unix
+
+import Data.Text qualified as Text
+import Data.ByteString.Lazy.Char8 as LBS8
+import Data.ByteString.Lazy as LBS
+import Data.ByteString.Char8 as BS8
+import Data.HashMap.Strict qualified as HM
+import Control.Monad.Except
+import Codec.Serialise
+
+{- HLINT ignore "Functor law" -}
+
+
+groupKeyEntries :: forall c m . ( MonadUnliftIO m
+                                , IsContext c
+                                , Exception (BadFormException c)
+                                , HasClientAPI StorageAPI UNIX m
+                                , HasStorage m
+                                ) => MakeDictM c m ()
+groupKeyEntries = do
+
+  entry $ bindMatch "hbs2:groupkey:load" $ \case
+      [HashLike h] -> do
+        sto <- getStorage
+
+        gk <- loadGroupKey h
+                >>= orThrowUser "can not load groupkey"
+
+        pure $ mkStr (show $ pretty $ AsGroupKeyFile gk)
+
+      _ -> throwIO $ BadFormException @C nil
+
+
+  brief "stores groupkey to the peer's storage" $
+   args [arg "string" "groupkey"] $
+   returns "string" "hash" $
+    entry $ bindMatch "hbs2:groupkey:store" $ \case
+        [LitStrVal s] -> do
+          let lbs = LBS8.pack (Text.unpack s)
+          gk <- pure (Symm.parseGroupKey @'HBS2Basic $ AsGroupKeyFile lbs)
+                  `orDie` "invalid group key"
+
+          sto <- getStorage
+          ha <- writeAsMerkle sto (serialise gk)
+          pure $ mkStr (show $ pretty ha)
+
+        _ -> throwIO $ BadFormException @c nil
+
+
+  brief "publish groupkey to the given refchan" $
+    args [arg "string" "refchan", arg "string" "groupkey-blob|groupkey-hash"] $
+    desc "groupkey may be also hash of te stored groupkey" $
+      entry $ bindMatch "hbs2:groupkey:publish" $ nil_ $ \case
+
+      [SignPubKeyLike rchan, LitStrVal gk] -> do
+        -- get
+        -- check
+        -- store
+        -- find refchan
+        -- post tx as metadata
+        notice $ red "not implemented yet"
+
+      [SignPubKeyLike rchan, HashLike gkh] -> do
+        notice $ red "not implemented yet"
+
+      _ -> throwIO $ BadFormException @c nil
+
+
+-- $ hbs2-cli print [hbs2:groupkey:update [hbs2:groupkey:load 6XJGpJszP6f68fmhF17AtJ9PTgE7BKk8RMBHWQ2rXu6N] \
+--             [list [remove . CcRDzezX1XQdPxRMuMKzJkfHFB4yG7vGJeTYvScKkbP8] \
+--                   [add . 5sJXsw7qhmq521hwhE67jYvrD6ZNVazc89rFwfWaQPyY]] ]
+--
+  entry $ bindMatch "hbs2:groupkey:update" $ \case
+    [LitStrVal s, ListVal ins] -> do
+
+      sto <- getStorage
+
+      let lbs = LBS8.pack (Text.unpack s)
+      gk <- pure (Symm.parseGroupKey @'HBS2Basic $ AsGroupKeyFile lbs)
+              `orDie` "invalid group key"
+
+      gk1 <- modifyGroupKey gk ins
+
+      pure $ mkStr (show $ pretty $ AsGroupKeyFile gk1)
+
+    _ -> throwIO $ BadFormException @C nil
+
+  brief "create group key" $
+    args [ arg "keys" "list" ] $
+    desc "list of encryption public keys of members" $
+    entry $ bindMatch "hbs2:groupkey:create" $ \syn -> do
+      case syn of
+        [ListVal (StringLikeList keys)] -> do
+          s <- groupKeyFromKeyList  keys
+                  <&> AsGroupKeyFile
+                  <&> show . pretty
+
+          pure $ mkStr s
+
+        StringLikeList keys -> do
+          s <- groupKeyFromKeyList  keys
+                  <&> AsGroupKeyFile
+                  <&> show . pretty
+
+          pure $ mkStr s
+
+        _ -> throwIO $ BadFormException @C nil
+
+
+  entry $ bindMatch "hbs2:groupkey:dump" $ nil_ $ \syn -> do
+    case syn of
+      -- TODO: from-file
+      -- TODO: from-stdin
+      -- TODO: base58 file
+      [HashLike gkh] -> do
+        gk <- loadGroupKey gkh
+        liftIO $ print $ pretty gk
+
+      _ -> throwIO $ BadFormException @C nil
+
+  entry $ bindMatch "hbs2:groupkey:list-public-keys" $ \syn -> do
+    case syn of
+      [LitStrVal s] -> do
+
+        let lbs = LBS8.pack (Text.unpack s)
+        gk <- pure (Symm.parseGroupKey @'HBS2Basic $ AsGroupKeyFile lbs)
+                `orDie` "invalid group key"
+
+        let rcpt = recipients gk & HM.keys & fmap (mkStr . show . pretty . AsBase58)
+
+        pure $ mkList @c rcpt
+
+      _ -> throwIO $ BadFormException @C nil
+
+  brief "find groupkey secret in hbs2-keyman" $
+    args [arg "string" "group-key-hash"] $
+    returns "secret-key-id" "string" $
+    entry $ bindMatch "hbs2:groupkey:find-secret" $ \case
+      [HashLike gkh] -> do
+
+        sto <- getStorage
+
+        gk <- loadGroupKey gkh >>= orThrowUser "can't load groupkey"
+
+        what <- runKeymanClientRO $ findMatchedGroupKeySecret sto gk
+                   >>= orThrowUser "groupkey secret not found"
+
+        let gid = generateGroupKeyId GroupKeyIdBasic1 what
+
+        pure $ mkStr (show $ pretty gid)
+
+      _ -> throwIO $ BadFormException @c nil
+
+
+  entry $ bindMatch "hbs2:groupkey:decrypt-block" $ \case
+    [BlobLike bs] -> do
+
+      sto <- getStorage
+
+      let lbs = LBS.fromStrict bs
+
+      seb <- pure (deserialiseOrFail lbs)
+               `orDie` "invalid SmallEncryptedBlock"
+
+      decrypted <- G.decryptBlock sto seb
+
+      pure $ mkForm @c "blob" [mkStr (BS8.unpack decrypted)]
+
+    _ -> throwIO $ BadFormException @C nil
+
+  entry $ bindMatch "hbs2:groupkey:encrypt-block" $ \case
+    [StringLike gkh, BlobLike what] -> do
+        sto <- getStorage
+        gk <- loadGroupKey (fromString gkh)
+                `orDie` "can't load group key"
+        seb <- G.encryptBlock sto gk what
+        pure $ mkForm "blob" [mkStr (LBS8.unpack (serialise seb))]
+
+    _ -> throwIO $ BadFormException @C nil
+

hbs2-cli/lib/HBS2/CLI/Run/Help.hs

@@ -0,0 +1,28 @@
+module HBS2.CLI.Run.Help where
+
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run.Internal
+
+import Data.HashMap.Strict qualified as HM
+import Data.List qualified as List
+import Data.Text qualified as Text
+
+helpEntries :: (MonadUnliftIO m, IsContext c) => MakeDictM c m ()
+helpEntries = do
+
+  entry $ bindMatch "help" $ nil_ $ \syn -> do
+
+      display_ $ "hbs2-cli tool" <> line
+
+      case syn of
+
+        [StringLike "--documented"] -> do
+          helpList True Nothing
+
+        (StringLike p : _) -> do
+          helpList False (Just p)
+
+        HelpEntryBound what -> helpEntry what
+
+        _ -> helpList False Nothing
+

hbs2-cli/lib/HBS2/CLI/Run/Internal.hs

@@ -0,0 +1,242 @@
+{-# Language TemplateHaskell #-}
+{-# Language UndecidableInstances #-}
+{-# Language AllowAmbiguousTypes #-}
+module HBS2.CLI.Run.Internal
+  ( module HBS2.CLI.Run.Internal
+  , module SC
+  ) where
+
+import HBS2.CLI.Prelude
+
+import HBS2.System.Dir
+
+import HBS2.OrDie
+import HBS2.Base58
+import HBS2.Data.Types.Refs
+import HBS2.Storage
+import HBS2.Peer.CLI.Detect
+import HBS2.Peer.RPC.Client
+import HBS2.Peer.RPC.Client.Unix
+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.Storage
+import HBS2.Peer.RPC.API.RefChan
+import HBS2.Peer.RPC.Client.StorageClient
+
+import Data.Config.Suckless.Script qualified as SC
+import Data.Config.Suckless.Script hiding (internalEntries)
+
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Cont
+import Data.ByteString.Char8 qualified as BS8
+import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString qualified as BS
+import Data.Text qualified as Text
+import Lens.Micro.Platform
+
+
+data HBS2CliEnv =
+  HBS2CliEnv
+  { _peerSocket      :: FilePath
+  , _peerRefChanAPI  :: ServiceCaller RefChanAPI UNIX
+  , _peerRefLogAPI   :: ServiceCaller RefLogAPI UNIX
+  , _peerLwwRefAPI   :: ServiceCaller LWWRefAPI UNIX
+  , _peerPeerAPI     :: ServiceCaller PeerAPI UNIX
+  , _peerStorageAPI  :: ServiceCaller StorageAPI UNIX
+  }
+
+makeLenses 'HBS2CliEnv
+
+newtype HBS2Cli m a = HBS2Cli { fromHBS2Cli :: ReaderT (TVar (Maybe HBS2CliEnv)) m a }
+                      deriving newtype ( Applicative
+                                       , Functor
+                                       , Monad
+                                       , MonadIO
+                                       , MonadUnliftIO
+                                       , MonadReader (TVar (Maybe HBS2CliEnv))
+                                       )
+
+withHBS2Cli :: TVar (Maybe HBS2CliEnv) -> HBS2Cli m a -> m a
+withHBS2Cli env action = runReaderT (fromHBS2Cli action) env
+
+recover :: HBS2Cli IO a -> HBS2Cli IO a
+recover what = do
+  catch what $ \case
+    PeerNotConnectedException -> do
+
+      soname <- detectRPC
+                  `orDie` "can't locate hbs2-peer rpc"
+
+      flip runContT pure do
+
+        client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname)
+                    >>= orThrowUser ("can't connect to" <+> pretty soname)
+
+        void $ ContT $ withAsync $ runMessagingUnix client
+
+        peerAPI    <- makeServiceCaller @PeerAPI (fromString soname)
+        refLogAPI  <- makeServiceCaller @RefLogAPI (fromString soname)
+        refChanAPI <- makeServiceCaller @RefChanAPI (fromString soname)
+        storageAPI <- makeServiceCaller @StorageAPI (fromString soname)
+        lwwAPI     <- makeServiceCaller @LWWRefAPI (fromString soname)
+
+        -- let sto = AnyStorage (StorageClient storageAPI)
+
+        let endpoints = [ Endpoint @UNIX  peerAPI
+                        , Endpoint @UNIX  refLogAPI
+                        , Endpoint @UNIX  refChanAPI
+                        , Endpoint @UNIX  lwwAPI
+                        , Endpoint @UNIX  storageAPI
+                        ]
+
+        void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
+
+        let env = Just (HBS2CliEnv soname refChanAPI refLogAPI lwwAPI peerAPI storageAPI)
+        tv <- newTVarIO env
+
+        liftIO $ withHBS2Cli tv what
+
+
+runHBS2Cli :: MonadUnliftIO m => HBS2Cli m a -> m a
+runHBS2Cli action = do
+   noenv <- newTVarIO Nothing
+   withHBS2Cli  noenv action
+
+data PeerException =
+  PeerNotConnectedException
+  deriving stock (Show, Typeable)
+
+instance Exception PeerException
+
+
+instance (MonadUnliftIO m, HasClientAPI api proto m) => HasClientAPI api proto (RunM c m) where
+  getClientAPI = lift (getClientAPI @api @proto)
+
+instance (MonadUnliftIO m, HasStorage m) => HasStorage  (RunM c m) where
+  getStorage = lift getStorage
+
+instance (MonadUnliftIO m, HasClientAPI StorageAPI UNIX m, HasStorage m) => HasStorage (ContT a (RunM c m)) where
+  getStorage = lift getStorage
+
+instance (MonadUnliftIO m, HasClientAPI api proto m) => HasClientAPI api proto (ContT a (RunM c m)) where
+  getClientAPI = lift $ getClientAPI @api @proto
+
+instance MonadUnliftIO m => HasClientAPI RefChanAPI UNIX (HBS2Cli m) where
+  getClientAPI = do
+    what <- ask >>= readTVarIO >>= orThrow PeerNotConnectedException
+    pure $ view peerRefChanAPI what
+
+instance MonadUnliftIO m => HasClientAPI RefLogAPI UNIX (HBS2Cli m) where
+  getClientAPI = do
+    what <- ask >>= readTVarIO >>= orThrow PeerNotConnectedException
+    pure $ view peerRefLogAPI what
+
+instance MonadUnliftIO m => HasClientAPI PeerAPI UNIX (HBS2Cli m) where
+  getClientAPI = do
+    what <- ask >>= readTVarIO >>= orThrow PeerNotConnectedException
+    pure $ view peerPeerAPI what
+
+instance MonadUnliftIO m => HasClientAPI StorageAPI UNIX (HBS2Cli m) where
+  getClientAPI = do
+    what <- ask >>= readTVarIO >>= orThrow PeerNotConnectedException
+    pure $ view peerStorageAPI what
+
+instance MonadUnliftIO m => HasClientAPI LWWRefAPI UNIX (HBS2Cli m) where
+  getClientAPI = do
+    what <- ask >>= readTVarIO >>= orThrow PeerNotConnectedException
+    pure $ view peerLwwRefAPI what
+
+instance MonadUnliftIO m => HasStorage (HBS2Cli m) where
+  getStorage = getClientAPI @StorageAPI @UNIX  <&> AnyStorage . StorageClient
+
+internalEntries :: forall c m . (IsContext c, Exception (BadFormException c), MonadUnliftIO m) => MakeDictM c m ()
+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 "hbs2:hash" $ \case
+      [] -> liftIO do
+        LBS.getContents
+          <&> mkSym . HashRef . hashObject @HbSync
+
+      [ StringLike fn ] -> liftIO do
+        LBS.readFile fn
+          <&> mkSym . HashRef . hashObject @HbSync
+
+      [isOpaqueOf @LBS.ByteString -> Just s ] -> do
+          pure $ mkSym $ HashRef $ hashObject @HbSync s
+
+      [isOpaqueOf @BS.ByteString -> Just s ] -> do
+          pure $ mkSym $ HashRef $ hashObject @HbSync s
+
+      e -> throwIO (BadFormException @c (mkList e))
+
+    entry $ bindMatch "blob:base58" $ \case
+      [LitStrVal t] -> do
+        bs <- pure (Text.unpack t & BS8.pack & fromBase58)
+               `orDie` "invalid base58"
+              <&> BS8.unpack
+
+        pure (mkForm "blob" [mkStr @c bs])
+
+      _ -> throwIO (BadFormException @c nil)
+
+
+    let decodeB58 t = do
+          pure (Text.unpack t & BS8.pack & fromBase58)
+            `orDie` "invalid base58"
+
+    let decodeAndOut t = do
+          liftIO $ BS8.putStr =<< decodeB58 t
+
+    entry $ bindMatch "base58:encode" $ \case
+      [LitStrVal t] -> do
+        let s = Text.unpack t & BS8.pack & toBase58 & BS8.unpack
+        pure (mkForm "blob:base58" [mkStr @c s])
+
+      [ListVal [SymbolVal "blob", LitStrVal t]] -> do
+        let s = Text.unpack t & BS8.pack & toBase58 & BS8.unpack
+        pure (mkForm "blob:base58" [mkStr @c s])
+
+      e -> throwIO (BadFormException @c nil)
+
+    entry $ bindMatch "base58:decode" $ \case
+
+      [ListVal [SymbolVal "blob:base58", LitStrVal t]] -> do
+        s <- decodeB58 t <&> BS8.unpack
+        pure $ mkForm "blob" [mkStr @c s]
+
+      e -> throwIO (BadFormException @c nil)
+
+    entry $ bindMatch "base58:put" $ nil_ $ \case
+      [ListVal [SymbolVal "blob:base58", LitStrVal t]] ->
+        decodeAndOut t
+
+      [LitStrVal t] -> decodeAndOut t
+
+      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/Internal/GroupKey.hs

@@ -0,0 +1,107 @@
+module HBS2.CLI.Run.Internal.GroupKey
+  ( module HBS2.CLI.Run.Internal.GroupKey
+  , SmallEncryptedBlock(..)
+  ) where
+
+import HBS2.CLI.Prelude hiding (mapMaybe)
+import HBS2.CLI.Run.Internal
+
+import HBS2.Base58
+import HBS2.Hash
+import HBS2.Storage
+import HBS2.Data.Types.Refs
+import HBS2.Data.Types.SmallEncryptedBlock
+import HBS2.Storage.Operations.Class
+import HBS2.Storage.Operations.ByteString
+import HBS2.KeyMan.Keys.Direct
+import HBS2.Net.Auth.GroupKeySymm as Symm
+
+import HBS2.Peer.RPC.Client.Unix
+import HBS2.Peer.RPC.Client
+import HBS2.Peer.RPC.API.Storage
+
+import Data.HashMap.Strict qualified as HM
+import Data.HashSet qualified as HS
+import Data.Maybe
+import Control.Monad.Trans.Cont
+import Control.Monad.Except
+import Codec.Serialise
+import Data.ByteString (ByteString)
+
+groupKeyFromKeyList :: MonadUnliftIO m => [String] -> m (GroupKey 'Symm HBS2Basic)
+groupKeyFromKeyList ks = do
+  let members = mapMaybe (fromStringMay @(PubKey 'Encrypt 'HBS2Basic)) ks
+  Symm.generateGroupKey @'HBS2Basic Nothing members
+
+
+encryptBlock :: (MonadUnliftIO m, Serialise t)
+             => AnyStorage
+             -> GroupKey 'Symm 'HBS2Basic
+             -> t
+             -> m (SmallEncryptedBlock t)
+
+encryptBlock sto gk x = do
+
+  let HbSyncHash non = hashObject (serialise x)
+
+  gks <- runKeymanClientRO (extractGroupKeySecret gk)
+           >>= orThrowUser "can't extract group key secret"
+
+  Symm.encryptBlock sto gks (Right gk) (Just non) x
+
+decryptBlock :: (MonadUnliftIO m, Serialise t)
+             => AnyStorage
+             -> SmallEncryptedBlock t
+             -> m t
+decryptBlock sto seb = do
+  let find gk = runKeymanClientRO (findMatchedGroupKeySecret sto gk)
+
+  -- FIXME: improve-error-diagnostics
+  runExceptT (Symm.decryptBlock sto find seb)
+     >>= orThrowUser "can't decrypt block"
+
+loadGroupKey :: ( IsContext c
+                , MonadUnliftIO m
+                , HasStorage m
+                , HasClientAPI StorageAPI UNIX m
+                ) => HashRef -> RunM c m (Maybe (GroupKey 'Symm HBS2Basic))
+loadGroupKey h = do
+
+  flip runContT pure do
+    sto <- getStorage
+
+    raw <- runExceptT (readFromMerkle sto (SimpleKey (fromHashRef h)))
+            <&> either (const Nothing) Just
+
+    bs <- ContT (maybe1 raw (pure Nothing))
+
+    let gk = deserialiseOrFail bs
+              & either (const Nothing) Just
+
+    pure gk
+
+modifyGroupKey :: (IsContext c, MonadUnliftIO m)
+               => GroupKey 'Symm 'HBS2Basic
+               -> [Syntax c]
+               -> m (GroupKey 'Symm HBS2Basic)
+modifyGroupKey gk ins = do
+
+  gks <- runKeymanClient do
+          extractGroupKeySecret gk
+         `orDie` "can't extract group key secret"
+
+  let r = catMaybes [ fromStringMay @(PubKey 'Encrypt HBS2Basic) k
+                    | ListVal [SymbolVal "remove", StringLike k] <- ins
+                    ] & HS.fromList
+
+  let a = catMaybes [ fromStringMay @(PubKey 'Encrypt HBS2Basic) k
+                    | ListVal [SymbolVal "add", StringLike k] <- ins
+                    ] & HS.fromList
+
+  let x = recipients gk & HM.keysSet
+
+  let new = x `HS.difference` r `mappend` a & HS.toList
+
+  generateGroupKey @'HBS2Basic (Just gks) new
+
+

hbs2-cli/lib/HBS2/CLI/Run/Internal/KeyMan.hs

@@ -0,0 +1,55 @@
+module HBS2.CLI.Run.Internal.KeyMan where
+
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run.Internal
+
+import HBS2.Hash
+import HBS2.System.Dir
+import HBS2.Net.Auth.Credentials
+
+import HBS2.KeyMan.Config (getDefaultKeyPath)
+import HBS2.KeyMan.Keys.Direct
+import HBS2.KeyMan.State
+import HBS2.KeyMan.App.Types
+
+import Codec.Serialise
+import Data.Either
+import Data.ByteString.Lazy qualified as LBS
+import Data.Text.Encoding qualified as TE
+import Data.Text.IO qualified as TIO
+import System.Process.Typed
+import Text.InterpolatedString.Perl6 (qc)
+
+
+keymanGetConfig :: (IsContext c, MonadUnliftIO m) => m [Syntax c]
+keymanGetConfig = do
+    (_,lbs,_) <- readProcess (shell [qc|hbs2-keyman config|] & setStderr closed)
+
+    let conf = TE.decodeUtf8 (LBS.toStrict lbs)
+                 & parseTop
+                 & fromRight mempty
+
+    pure $ fmap fixContext conf
+
+keymanUpdate :: MonadUnliftIO m => m ()
+keymanUpdate = do
+  void $ runProcess (shell [qc|hbs2-keyman update|] & setStderr closed & setStdout closed)
+
+keymanNewCredentials :: MonadUnliftIO m => Maybe String -> Int -> m (PubKey 'Sign 'HBS2Basic)
+keymanNewCredentials suff n = do
+  conf <- keymanGetConfig @C
+  path <- getDefaultKeyPath conf
+  creds <- newCredentialsEnc @'HBS2Basic n
+
+  let s = show $ pretty $ AsCredFile (AsBase58 creds)
+
+  let psk = view peerSignPk creds
+
+  let fpath = path </> show (pretty (AsBase58 psk) <> "-" <> pretty suff <> ".key")
+
+  liftIO $ writeFile fpath s
+
+  keymanUpdate
+
+  pure psk
+

hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs

@@ -0,0 +1,156 @@
+module HBS2.CLI.Run.Internal.Merkle where
+
+import HBS2.CLI.Prelude
+import HBS2.Defaults
+import HBS2.CLI.Run.Internal
+import HBS2.CLI.Run.Internal.GroupKey as G
+
+import HBS2.Hash
+import HBS2.Net.Auth.GroupKeySymm as Symm
+import HBS2.Data.Types.Refs
+import HBS2.Data.Detect
+import HBS2.Merkle
+import HBS2.Storage
+import HBS2.Storage.Operations.ByteString
+import HBS2.Peer.RPC.Client.Unix
+import HBS2.Peer.RPC.Client
+import HBS2.Peer.RPC.API.Storage
+import HBS2.KeyMan.Keys.Direct
+
+import HBS2.Net.Auth.Schema()
+
+import Codec.Serialise
+import Data.Coerce
+import Data.ByteString.Lazy qualified as LBS
+import Data.HashMap.Strict qualified as HM
+import Data.Text qualified as Text
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Cont
+import Control.Monad.Except
+import Data.Maybe
+
+
+--FIXME: move-somewhere-else
+getGroupKeyHash :: ( MonadUnliftIO m
+                   , HasStorage m
+                   , HasClientAPI StorageAPI UNIX m
+                   )
+                => HashRef
+                -> m (Maybe HashRef, MTreeAnn [HashRef])
+getGroupKeyHash h = do
+  flip runContT pure do
+    sto <- lift getStorage
+
+    headBlock <- getBlock sto (fromHashRef h)
+                   >>= orThrow MissedBlockError
+                   <&> deserialiseOrFail @(MTreeAnn [HashRef])
+                   >>= orThrow UnsupportedFormat
+
+    case _mtaCrypt headBlock of
+      (EncryptGroupNaClSymm hash _) ->
+        pure $ (Just $ HashRef hash, headBlock)
+      _ -> pure (Nothing, headBlock)
+
+-- TODO: client-api-candidate
+createTreeWithMetadata :: (MonadUnliftIO m)
+                       => AnyStorage
+                       -> Maybe (GroupKey 'Symm 'HBS2Basic)
+                       -> HashMap Text Text
+                       -> LBS.ByteString
+                       -> m (Either OperationError HashRef)
+createTreeWithMetadata sto mgk meta lbs = do -- flip runContT pure do
+
+    let mt = vcat [ pretty k <> ":" <+> dquotes (pretty v) | (k,v) <- HM.toList meta ]
+               & show & Text.pack
+
+    case mgk of
+      Nothing -> Right <$> createSimpleTree mt
+      Just gk -> createEncryptedTree gk mt
+
+  where
+    createSimpleTree mt = do
+        t0 <- writeAsMerkle sto lbs
+                >>= getBlock sto
+                >>= orThrowUser "can't read merkle tree just written"
+                <&> deserialiseOrFail @(MTree [HashRef])
+                >>= orThrowUser "merkle tree corrupted/invalid"
+
+        let mann = MTreeAnn (ShortMetadata mt) NullEncryption t0
+
+        putBlock sto (serialise mann)
+          >>= orThrowUser "can't write tree"
+          <&> HashRef
+
+    -- FIXME: support-encryption
+    createEncryptedTree gk mt = do
+      -- 1. find key
+      mgks <- runKeymanClientRO do
+                extractGroupKeySecret gk
+
+      gks <- orThrowUser "can't get groupkey's secret" mgks
+
+      -- FIXME: consider-other-nonce-calculation
+      --   надо считать начальный нонс (от чего / как?)
+      --   нонс: да так-то пофиг от чего, но:
+      --     если брать рандомные места в байтстроке --
+      --     она зафорсится
+      --     что вообще зависит от начального нонса:
+      --       если в файл будет допись в конец, то
+      --       "старые" блоки останутся такими же, как были
+      --       что хорошо для дедуплицирования, но
+      --       потенциально это менее безопасно.
+      --   можно еще с метаданными похэшировать, тогда
+      --   нонс будет более уникальный; но поменялись метаданные -- поменялось всё
+      let s0 = LBS.take ( 1024 * 1024 ) lbs
+
+      let (HbSyncHash nonce) = hashObject @HbSync s0
+      -- куда-то девать зашифрованные метаданные
+      --
+      let segments = readChunkedBS lbs defBlockSize
+
+      seb <- G.encryptBlock sto gk (ShortMetadata mt)
+
+      hmeta <- putBlock sto (serialise seb)
+                 >>= orThrowUser "can't put block"
+
+      let source = ToEncryptSymmBS gks (Right gk) nonce segments  (AnnHashRef hmeta) Nothing
+
+      runExceptT $ writeAsMerkle sto source <&> HashRef
+
+
+getTreeContents :: forall m . ( MonadUnliftIO m
+                              , MonadIO m
+                              , MonadError OperationError m
+                   )
+                => AnyStorage
+                -> HashRef
+                -> m LBS.ByteString
+
+getTreeContents sto href = do
+
+  blk <- getBlock sto (coerce href)
+           >>= orThrowError MissedBlockError
+
+  let q = tryDetect (coerce href) blk
+
+  case q of
+
+    Merkle _ -> do
+      readFromMerkle sto (SimpleKey (coerce href))
+
+    MerkleAnn (MTreeAnn {_mtaCrypt = NullEncryption }) -> do
+      readFromMerkle sto (SimpleKey (coerce href))
+
+    MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm gkh _}) -> do
+
+      rcpts  <- Symm.loadGroupKeyMaybe @'HBS2Basic sto (HashRef gkh)
+                  >>= orThrowError (GroupKeyNotFound 11)
+                  <&> HM.keys . Symm.recipients
+
+      let findStuff g = do
+            runKeymanClientRO @IO $ findMatchedGroupKeySecret sto g
+
+      readFromMerkle sto (ToDecryptBS (coerce href) (liftIO . findStuff))
+
+    _ -> throwError UnsupportedFormat
+

hbs2-cli/lib/HBS2/CLI/Run/Internal/RefChan.hs

@@ -0,0 +1,61 @@
+{-# Language AllowAmbiguousTypes #-}
+module HBS2.CLI.Run.Internal.RefChan (createNewRefChan) where
+
+import HBS2.CLI.Prelude hiding (mapMaybe)
+import HBS2.CLI.Run.Internal
+import HBS2.CLI.Run.Internal.KeyMan
+
+import HBS2.Peer.Proto.RefChan
+import HBS2.Storage
+import HBS2.Net.Auth.Credentials
+import HBS2.Net.Auth.Schema()
+import HBS2.Data.Types.SignedBox
+import HBS2.Data.Types.Refs
+import HBS2.Storage.Operations.Class
+import HBS2.KeyMan.Keys.Direct
+
+import HBS2.Peer.RPC.Client.Unix
+import HBS2.Peer.RPC.Client
+import HBS2.Peer.RPC.API.Storage
+import HBS2.Peer.RPC.API.Peer
+import HBS2.Peer.RPC.API.RefChan
+
+import Lens.Micro.Platform
+
+createNewRefChan :: forall c m . ( IsContext c
+                                 , MonadUnliftIO m
+                                 , Exception (BadFormException c)
+                                 , HasClientAPI RefChanAPI UNIX m
+                                 , HasClientAPI StorageAPI UNIX m
+                                 , HasClientAPI PeerAPI UNIX m
+                                 , HasStorage m
+                                 )
+                 => Maybe (PubKey Sign HBS2Basic)
+                 -> RefChanHeadBlock L4Proto
+                 -> m  (PubKey Sign HBS2Basic)
+
+createNewRefChan mbk rch = do
+
+  peerApi  <- getClientAPI @PeerAPI @UNIX
+  rchanApi <- getClientAPI @RefChanAPI @UNIX
+  sto      <- getStorage
+
+  refchan <- maybe1 mbk (keymanNewCredentials (Just "refchan") 0) pure
+
+  creds <- runKeymanClientRO $ loadCredentials refchan
+               >>= orThrowUser "can't load credentials"
+
+  let box = makeSignedBox @'HBS2Basic (view peerSignPk creds) (view peerSignSk creds) rch
+
+  href <- writeAsMerkle sto  (serialise box)
+
+  --FIXME: timeout-hardcode
+  callService @RpcPollAdd peerApi (refchan, "refchan", 17)
+      >>= orThrowUser "can't subscribe to refchan"
+
+  callService @RpcRefChanHeadPost rchanApi (HashRef href)
+      >>= orThrowUser "can't post refchan head"
+
+  pure refchan
+
+

hbs2-cli/lib/HBS2/CLI/Run/Internal/RefLog.hs

@@ -0,0 +1,109 @@
+{-# Language AllowAmbiguousTypes #-}
+module HBS2.CLI.Run.Internal.RefLog (copyTransactions, RefLogCLIException(..),decodeRefLogTx) where
+
+import HBS2.CLI.Prelude hiding (mapMaybe)
+import HBS2.CLI.Run.Internal
+import HBS2.CLI.Run.Internal.KeyMan
+
+import HBS2.Peer.Proto.RefLog
+import HBS2.Base58
+import HBS2.Storage
+import HBS2.Data.Detect
+import HBS2.Net.Auth.Credentials
+import HBS2.Net.Auth.Schema()
+import HBS2.Peer.Proto
+import HBS2.Data.Types.SignedBox
+import HBS2.Data.Types.Refs
+import HBS2.Storage.Operations.Class
+import HBS2.KeyMan.Keys.Direct
+
+import HBS2.Peer.RPC.Client.Unix
+import HBS2.Peer.RPC.Client
+import HBS2.Peer.RPC.API.Storage
+import HBS2.Peer.RPC.API.Peer
+import HBS2.Peer.RPC.API.RefLog
+
+import Codec.Serialise
+import Control.Monad.Trans.Maybe
+import Data.ByteString.Lazy qualified as LBS
+import Data.Coerce
+import Data.Maybe
+import Lens.Micro.Platform
+
+data RefLogCLIException =
+   RefLogRpcTimeout
+ | RefLogNoCredentials String
+ deriving (Typeable, Show)
+
+instance Exception RefLogCLIException
+
+type ForCloneRefLog e s m = ( s ~ Encryption e
+                            , MonadUnliftIO m
+                            , HasClientAPI RefLogAPI UNIX m
+                            , HasClientAPI StorageAPI UNIX m
+                            , HasClientAPI PeerAPI UNIX m
+                            , HasStorage m
+                            , Signatures s
+                            , IsRefPubKey s
+                            , Serialise (Nonce (RefLogUpdate e))
+                            )
+
+
+-- useful for forking git repositories
+-- it accepts credential lookup method
+-- since reflog B may be inferred from some other secret
+-- normally, you dont need this method
+copyTransactions :: forall e s m . (ForCloneRefLog e s m, s ~ Encryption e, e ~ L4Proto)
+                 => m (PeerCredentials s) -- ^ obtain credentials for reflog B
+                 -> PubKey Sign s         -- ^ original reflog
+                 -> PubKey Sign s         -- ^ destination reflog
+                 -> m ()
+
+copyTransactions cre a b  = do
+
+  api <- getClientAPI @RefLogAPI @UNIX
+  sto <- getStorage
+
+  creds <- cre
+
+  let pk = view peerSignPk creds
+  let sk = view peerSignSk creds
+
+  void $ runMaybeT do
+
+    rvA <- lift (callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) api a)
+             >>= orThrow RefLogRpcTimeout
+             >>= toMPlus
+
+    logA <- readLogThrow (getBlock sto) rvA
+
+    new <- for logA $ \h -> runMaybeT do
+      RefLogUpdate{..} <- getBlock sto (coerce h)
+                            >>= toMPlus
+                            <&> deserialiseOrFail @(RefLogUpdate e)
+                            >>= toMPlus
+
+      lift (makeRefLogUpdate @e pk sk _refLogUpdData)
+
+    lift $ for_ (catMaybes new) $ \n -> do
+      void $ callService @RpcRefLogPost api n
+
+
+decodeRefLogTx :: forall c. IsContext c => Maybe HashRef -> LBS.ByteString -> Syntax c
+decodeRefLogTx h lbs = do
+
+  let ha = maybe (hashObject @HbSync lbs) coerce h
+
+  case tryDetect ha lbs of
+
+    SeqRef (SequentialRef n (AnnotatedHashRef ann ha)) ->
+      mkForm "seqref" [mkInt n, mkForm "annref" [mkSym (show $ pretty ann), mkSym (show $ pretty ha)]]
+
+    AnnRef (AnnotatedHashRef ann ha) -> do
+       mkForm "annref" [mkSym (show $ pretty ann), mkSym (show $ pretty ha)]
+
+    Blob{} -> mkForm "blob" [mkSym (show $ pretty ha)]
+
+    _ -> mkForm "tree" [mkSym (show $ pretty ha)]
+
+

hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs

@@ -0,0 +1,54 @@
+module HBS2.CLI.Run.KeyMan
+  ( module HBS2.CLI.Run.KeyMan
+  , keymanNewCredentials
+  ) where
+
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run.Internal
+import HBS2.CLI.Run.Internal.KeyMan
+
+import HBS2.Hash
+import HBS2.System.Dir
+
+import HBS2.KeyMan.Config (getDefaultKeyPath)
+import HBS2.KeyMan.Keys.Direct
+import HBS2.KeyMan.State
+import HBS2.KeyMan.App.Types
+
+import Codec.Serialise
+import Data.Either
+import Data.ByteString.Lazy qualified as LBS
+import Data.Text.Encoding qualified as TE
+import Data.Text.IO qualified as TIO
+import System.Process.Typed
+import Text.InterpolatedString.Perl6 (qc)
+
+
+keymanEntries :: (MonadUnliftIO m, IsContext c) => MakeDictM c m ()
+keymanEntries = do
+  entry $ bindMatch "hbs2:keyman:list" $ nil_ \case
+    _ -> do
+      void $ runKeymanClient  $ KeyManClient $ do
+        k <- listKeys
+        display_ $ vcat (fmap pretty k)
+
+  entry $ bindMatch "hbs2:keyman:update" $ nil_ $ \_ -> do
+    keymanUpdate
+
+  entry $ bindMatch "hbs2:keyman:config" $ \_ -> do
+    mkForm  "dict" <$> keymanGetConfig
+
+  args [ arg "string" "keyring-data"] $
+    entry $ bindMatch "hbs2:keyman:keys:add" $ \case
+      [ LitStrVal ke ] -> do
+        conf <- keymanGetConfig @C
+        path <- getDefaultKeyPath conf
+        let n =  hashObject @HbSync (serialise ke) & pretty & show
+        let fname = n `addExtension` ".key"
+        let fpath = path </> fname
+        liftIO $ TIO.writeFile fpath ke
+        keymanUpdate
+        pure $ mkStr fpath
+
+      _ -> throwIO (BadFormException @C nil)
+

hbs2-cli/lib/HBS2/CLI/Run/Keyring.hs

@@ -0,0 +1,60 @@
+module HBS2.CLI.Run.Keyring where
+
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run.Internal
+
+import HBS2.Net.Auth.Credentials
+import HBS2.KeyMan.App.Types
+
+import Data.ByteString qualified as BS
+import Data.ByteString.Char8 qualified as BS8
+import Data.Text qualified as Text
+
+keyringEntries :: forall c m . ( MonadUnliftIO m
+                               , IsContext c
+                               , Exception (BadFormException c)
+                               ) => MakeDictM c m ()
+keyringEntries = do
+  entry $ bindMatch "hbs2:keyring:list-encryption" $ \syn -> do
+    lbs <- case syn of
+
+          [ ListVal [ SymbolVal "file", StringLike fn ] ] -> do
+            liftIO $ BS.readFile fn
+
+          [ LitStrVal s ] -> do
+            pure (BS8.pack (Text.unpack s))
+
+          _ -> throwIO (BadFormException @C nil)
+
+    cred <- pure (parseCredentials @'HBS2Basic (AsCredFile lbs))
+              `orDie` "bad keyring file"
+
+    let e = [ mkStr @c (show (pretty (AsBase58 p))) | KeyringEntry p _ _ <- view peerKeyring cred ]
+
+    pure $ mkList @c e
+
+  brief "creates a new keyring (credentials)"
+    $ args [arg "int?" "encrypt-keys-num"]
+    $ returns "keyring" "string"
+    $ entry $ bindMatch "hbs2:keyring:new" $ \syn -> do
+      n <- case syn of
+            [LitIntVal k] -> pure k
+            []            -> pure 1
+            _ -> throwIO (BadFormException @C nil)
+
+      cred0 <- newCredentials @'HBS2Basic
+      cred <- foldM (\cred _ -> addKeyPair Nothing cred) cred0 [1..n]
+      pure $ mkStr @c $ show $ pretty $ AsCredFile $ AsBase58 cred
+
+
+  entry $ bindMatch "hbs2:keyring:show" $ \case
+    [StringLike fn] -> do
+      bs <- liftIO $ BS.readFile fn
+      cred <- parseCredentials @'HBS2Basic (AsCredFile bs)
+                  & orThrowUser "bad credentials file"
+
+      pure $ mkStr $ show $ pretty (ListKeyringKeys cred)
+
+    _ -> throwIO $ BadFormException @c nil
+
+

hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs

@@ -0,0 +1,129 @@
+module HBS2.CLI.Run.LWWRef where
+
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run.Internal
+import HBS2.CLI.Run.Internal.KeyMan
+
+import HBS2.Data.Types.Refs
+import HBS2.Storage
+import HBS2.Peer.CLI.Detect
+import HBS2.Peer.RPC.Client.Unix
+import HBS2.Peer.RPC.Client
+import HBS2.Peer.RPC.API.Peer
+import HBS2.Peer.RPC.API.LWWRef
+
+import HBS2.Peer.Proto.LWWRef
+import HBS2.Base58
+import HBS2.Net.Auth.Credentials
+import HBS2.Net.Auth.Schema()
+import HBS2.Data.Types.SignedBox
+
+import HBS2.KeyMan.Keys.Direct
+import HBS2.KeyMan.App.Types
+
+import Control.Monad.Trans.Cont
+
+
+lwwRefEntries :: forall c m . ( IsContext c
+                              , MonadUnliftIO m
+                              , Exception (BadFormException c)
+                              , HasClientAPI PeerAPI UNIX m
+                              , HasClientAPI LWWRefAPI UNIX m
+                              ) => MakeDictM  c m ()
+lwwRefEntries = do
+
+  brief "creates a new lwwref"
+    $ desc "Creates a new keyring; adds it to keyman and subsribes hbs2-peer to listen this lwwref"
+    $ returns "string" "lwwref public key"
+    $ entry $ bindMatch "hbs2:lwwref:create" $ \case
+        [] -> do
+          key <- keymanNewCredentials (Just "lwwref") 0
+          api <- getClientAPI @PeerAPI  @UNIX
+          void $ callService @RpcPollAdd api (key, "lwwref", 31)
+          pure $ mkForm "pk" [mkStr (show $ pretty (AsBase58 key))]
+
+        _ -> throwIO (BadFormException @C nil)
+
+  brief "lists all lwwref that hbs2-peer is subscribed to"
+    $ noArgs
+    $ returns "list of string" "lwwref list"
+    $ entry $ bindMatch "hbs2:lwwref:list" $ \case
+      [] -> do
+        api <- getClientAPI  @PeerAPI @UNIX
+        r <- callService @RpcPollList2 api (Just "lwwref", Nothing)
+               >>= orThrowUser "can't get lwwref list"
+        pure $ mkList $ fmap (mkStr . show . pretty . AsBase58 . view _1) r
+
+      _ -> throwIO (BadFormException @C nil)
+
+
+  brief "fetches lwwref value"
+    $ desc "makes peer to request lwwref from neighbors"
+    $ args [arg "string" "lwwref"]
+    $ returns "atom" "okay"
+    $ entry $ bindMatch "hbs2:lwwref:fetch" $ \case
+      [StringLike puk] -> do
+        lww <- orThrowUser "bad lwwref key" (fromStringMay puk)
+        api <- getClientAPI @LWWRefAPI @UNIX
+        void $ callService @RpcLWWRefFetch api lww
+        pure $ mkStr "okay"
+
+      _ -> throwIO (BadFormException @C nil)
+
+
+  brief "get lwwref value"
+    $ args [arg "string" "lwwref"]
+    $ returns "string" "hashref"
+    $ examples [qc|
+
+(hbs2:lwwref:get BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP)
+(lwwref
+  (seq 4)
+  (value "74vDGwBYebH3oM6xPXC7kqpgu6deqi7E549QpvHvvQKf")
+  )
+    |]
+    $ entry $ bindMatch "hbs2:lwwref:get" $ \case
+      [StringLike puk] -> do
+
+        ref <- orThrowUser "bad lwwref key" (fromStringMay puk)
+        api <- getClientAPI @LWWRefAPI  @UNIX
+        what <- callService @RpcLWWRefGet api ref
+                  >>= orThrowUser "can't get lwwref value"
+        pure $ mkStr (show $ pretty what)
+
+      _ -> throwIO (BadFormException @C nil)
+
+
+  brief "updates lwwref"
+    $ desc "updates lwwref value and increments it's counter"
+    $ args [arg "string" "lwwref", arg "string" "hash"]
+    $ returns "nil" ""
+    $ entry $ bindMatch "hbs2:lwwref:update" $ \case
+      [StringLike puks, HashLike new] -> do
+
+        puk <- orThrowUser "bad lwwref key" (fromStringMay  puks)
+        api <- getClientAPI @LWWRefAPI  @UNIX
+
+        (sk,pk) <- liftIO $ runKeymanClient do
+                     creds  <- loadCredentials puk
+                                 >>= orThrowUser "can't load credentials"
+                     pure ( view peerSignSk  creds, view peerSignPk creds )
+
+        what <- callService @RpcLWWRefGet api puk
+                  >>= orThrowUser "can't get lwwref value"
+
+        sno' <- case what of
+                 Nothing    -> pure 0
+                 Just lwwv  -> pure (lwwSeq lwwv)
+
+        let sno =  succ sno'
+
+        let box =  makeSignedBox pk sk (LWWRef sno new Nothing)
+
+        callService @RpcLWWRefUpdate api box
+          >>= orThrowUser "lww ref update error"
+
+        pure nil
+
+      _ -> throwIO (BadFormException @C nil)
+

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/MetaData.hs

@@ -0,0 +1,307 @@
+{-# Language MultiWayIf #-}
+
+module HBS2.CLI.Run.MetaData
+  ( metaDataEntries
+  , createTreeWithMetadata
+  , getTreeContents
+  , getGroupKeyHash
+  ) 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 Codec.Serialise
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Cont
+import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString.Lazy (ByteString)
+import Data.ByteString.Char8 qualified as BS8
+import Data.Either
+import Data.Set qualified as Set
+import Data.HashMap.Strict qualified as HM
+import Data.Maybe
+import Data.Text.Encoding qualified as TE
+import Data.Text qualified as Text
+import Data.Text.IO qualified as TIO
+
+import Magic.Data
+import Magic.Init       (magicLoadDefault,magicOpen)
+import Magic.Operations (magicFile)
+
+{- HLINT ignore "Functor law" -}
+
+data CreateMetaDataOpt =
+    Auto
+  | Stdin
+  | Encrypted String
+  | MetaDataEntry Id String
+  | MetaDataFile FilePath
+  deriving stock (Eq,Ord,Show,Data,Generic)
+
+txt :: Pretty  a => a -> Text
+txt a = Text.pack (show $ pretty a)
+
+metaFromSyntax :: [Syntax c] -> HashMap Text Text
+metaFromSyntax syn =
+  HM.fromList [ (t k, t v) | (ListVal [ k, v ]) <- syn ]
+  where
+    t x = Text.pack (show $ pretty x)
+
+
+type ForMetadata c m = ( IsContext c
+                       , MonadUnliftIO m
+                       , Exception (BadFormException c)
+                       , HasStorage m
+                       , HasClientAPI StorageAPI UNIX m
+                       )
+
+metaDataEntries :: forall c m . ( ForMetadata c m
+                                ) => MakeDictM c m ()
+metaDataEntries = do
+
+  brief "update group key for tree"
+    $ args [arg "string" "tree", arg "list" "update-ops"]
+    $ desc ( "update-ops is a list of pairs, like" <> line
+               <> indent 4 ( parens ("list"
+                     <+> indent 2 (vcat [ parens "remove . PUBLIC-KEY-ID"
+                                        , parens "add . PUBLIC-KEY-ID"
+                        ]))))
+    $ returns "string" "new-tree-hash"
+    $ examples [qc|
+
+(define gk (hbs2:groupkey:load 6XJGpJszP6f68fmhF17AtJ9PTgE7BKk8RMBHWQ2rXu6N))
+
+(hbs2:groupkey:update gk
+      (list (remove . CcRDzezX1XQdPxRMuMKzJkfHFB4yG7vGJeTYvScKkbP8)
+            (add . EiwWxY3xwTfnLKJdzzxNMZgA2ZvYAZd9e8B8pFeCtnrn)))
+    |]
+    $ entry $ bindMatch "hbs2:tree:metadata:update-gk" $ \case
+      [StringLike tree, ListVal ins] -> do
+
+        ha <- orThrowUser "invalid hash" (fromStringMay tree)
+
+        -- 1. load-group-key
+        (gkh', headBlk) <- getGroupKeyHash ha
+
+        gkh <- orThrowUser "not encrypted" gkh'
+
+        gk <- loadGroupKey gkh
+                >>= orThrowUser "can't load gk"
+
+        gk1 <- modifyGroupKey gk ins
+
+        sto <- getStorage
+        gk1h <- writeAsMerkle sto (serialise gk1)
+
+        case headBlk of
+          w@(MTreeAnn { _mtaCrypt = EncryptGroupNaClSymm _ nonce }) -> do
+            let w1 = w { _mtaCrypt = EncryptGroupNaClSymm gk1h nonce }
+
+            h <- putBlock sto (serialise w1)
+                   >>= orThrowUser "can't put block"
+
+            pure $ mkStr (show $ pretty h)
+
+          _ -> pure nil
+
+      _ -> throwIO (BadFormException @c nil)
+
+  brief "get group key from encrypted tree"
+    $ args [arg "string" "tree-hash"]
+    $ returns "group-key-hash" "string"
+    $ examples [qc|
+
+(hbs2:tree:metadata:get-gk 7J2BZYskBjmDsWZHvVoGGorZDrFYkbbQweRauaYGSTNd)
+5fshZRucawt47YJLuD1rVXRez2dcvCbz17m69YyduTEm
+
+    |]
+    $ entry $ bindMatch "hbs2:tree:metadata:get-gk" $ \case
+      [ StringLike hash ] -> flip runContT pure do
+
+        (gk,_) <- lift $ getGroupKeyHash (fromString hash)
+
+        case gk of
+          Just h -> pure $ mkStr (show $ pretty h)
+          _      -> pure nil
+
+      _ -> throwIO (BadFormException @c nil)
+
+  brief "get metadata from tree"
+    $ args [arg "symbol?" "method", arg "string" "tree-hash"]
+    $ returns "group-key-hash" "string"
+    $ desc ( opt "symbol?" ":parsed" <+> "return metadata as dict" <> line
+              <> "if other value or absense then return metadata as string"
+           )
+    $ examples [qc|
+
+(hbs2:tree:metadata:get 7J2BZYskBjmDsWZHvVoGGorZDrFYkbbQweRauaYGSTNd)
+((mime-type: "text/plain; charset=us-ascii") (file-name: "qqq.txt"))
+
+(hbs2:tree:metadata:get :raw 7J2BZYskBjmDsWZHvVoGGorZDrFYkbbQweRauaYGSTNd
+mime-type: "text/plain; charset=us-ascii"
+file-name: "qqq.txt"
+    |]
+    $ entry $ bindMatch "hbs2:tree:metadata:get"
+    $ \case
+     [ StringLike hash ] -> do
+
+        r <- flip runContT pure do
+
+          sto <- getStorage
+
+          runMaybeT do
+
+            headBlock <- getBlock sto (fromString hash)
+                           >>= toMPlus
+                           <&> deserialiseOrFail @(MTreeAnn [HashRef])
+                           >>= toMPlus
+
+            case headBlock of
+              MTreeAnn { _mtaMeta = ShortMetadata s } -> do
+                pure $ mkStr s
+
+              MTreeAnn { _mtaMeta = AnnHashRef h, _mtaCrypt = NullEncryption } -> do
+                getBlock sto h
+                   >>= toMPlus
+                   <&> LBS.toStrict
+                   <&> TE.decodeUtf8
+                   <&> mkStr
+
+              MTreeAnn { _mtaMeta = AnnHashRef h } -> do
+                getBlock sto h
+                   >>= toMPlus
+                   <&> deserialiseOrFail @(SmallEncryptedBlock AnnMetaData)
+                   >>= toMPlus
+                   >>= lift . lift . G.decryptBlock sto
+                   <&> \case
+                    ShortMetadata s -> mkStr s
+                    _ -> nil
+
+              _ -> mzero
+
+        maybe1 r (pure nil) $ \case
+          TextLike r0 -> do
+
+            let xs = parseTop r0
+                       & either mempty (fmap fixContext)
+
+            pure $ mkList xs
+
+          _ -> pure $ fromMaybe nil r
+
+     _ -> throwIO (BadFormException @c nil)
+
+
+  let metadataCreateMan = brief "creates a tree with metadata"
+  let kw = arg "kw" "opts"
+
+  metadataCreateMan $ args [kw, arg "string" "filename"] $
+    entry $ bindMatch "hbs2:tree:metadata:file" $ \case
+      [ syn@(ListVal{}), StringLike fn ] -> do
+          meta0 <- liftIO do
+            magic <- magicOpen [MagicMimeType,MagicMime,MagicMimeEncoding]
+            magicLoadDefault magic
+            mime <- magicFile magic fn
+            pure $ HM.fromList [ ("file-name", Text.pack (takeFileName fn))
+                               , ("mime-type", Text.pack mime)
+                               ]
+          doCreateMetadataTree meta0 syn (liftIO $ LBS.readFile fn)
+
+      _ -> throwIO (BadFormException @c nil)
+
+  metadataCreateMan $ args [kw] $
+    entry $ bindMatch "hbs2:tree:metadata:stdin" $ \case
+        [syn@(ListVal{})] -> do
+          _reader <- hIsTerminalDevice stdin >>= \case
+             _ -> pure (liftIO LBS.getContents)
+
+          doCreateMetadataTree mempty syn _reader
+
+        _ -> throwIO (BadFormException @c nil)
+
+  metadataCreateMan $ args [kw, arg "string" "input"] $
+    entry $ bindMatch "hbs2:tree:metadata:string" $ \case
+        [ syn@(ListVal{}), TextLike content ] -> do
+          -- liftIO $ TIO.putStr content
+          doCreateMetadataTree mempty syn (pure $ LBS.fromStrict $ TE.encodeUtf8 content)
+
+        _ -> throwIO (BadFormException @c nil)
+
+  entry $ bindMatch "cbor:base58" $ \case
+    [ LitStrVal x ] -> do
+      pure $ mkForm "cbor:base58" [mkStr x]
+
+    _ -> throwIO (BadFormException @c nil)
+
+
+groupKeyFromSyntax :: Syntax c -> Either (Syntax c) (Maybe HashRef)
+groupKeyFromSyntax = \case
+  ListVal es -> do
+    let mbGk = headMay [ z | z@(ListVal [ TextLike "gk", v ]) <- es ]
+
+    case mbGk of
+      Just (ListVal [ TextLike "gk", HashLike v]) -> Right (Just v)
+      Just w@(ListVal [ TextLike "gk", v]) -> Left w
+      _ -> Right Nothing
+
+  _ -> Right Nothing
+
+loadGroupKeyFromSyntax :: ( ForMetadata c m )
+                       => Syntax c
+                       -> RunM c m (Maybe (GroupKey 'Symm 'HBS2Basic))
+
+loadGroupKeyFromSyntax syn = runMaybeT do
+  hash <- case groupKeyFromSyntax syn of
+             Right w -> toMPlus w
+             Left e -> throwIO (BadFormException e)
+
+  toMPlus =<< lift (loadGroupKey hash)
+
+metadataFromSyntax :: Syntax c -> HashMap Text Text
+metadataFromSyntax = \case
+  ListVal es -> HM.fromList [ (k,v) | ListVal [ TextLike k, TextLike v] <- es, k /= "gk" ]
+  _ -> mempty
+
+
+doCreateMetadataTree :: forall c m . ForMetadata c m
+                     => HashMap Text Text
+                     -> Syntax c
+                     -> m ByteString
+                     -> RunM c m (Syntax c)
+doCreateMetadataTree meta0 syn getLbs = do
+  let meta = metadataFromSyntax syn
+  let gkh  = groupKeyFromSyntax syn
+
+  gk <- loadGroupKeyFromSyntax syn
+
+  -- notice $ "GK" <+> pretty (isRight gkh) <+> pretty gk
+
+  case (gkh, gk) of
+    (Right (Just _), Nothing) -> throwIO (GroupKeyNotFound 1)
+    _ -> none
+
+  sto <- getStorage
+
+  lbs <- lift getLbs
+
+  href <- lift (createTreeWithMetadata sto  gk (meta0 <> meta) lbs)
+             >>= orThrow StorageError
+
+  pure $ mkStr (show $ pretty href)
+
+
+

hbs2-cli/lib/HBS2/CLI/Run/Peer.hs

@@ -0,0 +1,145 @@
+{-# Language ViewPatterns #-}
+{-# Language PatternSynonyms #-}
+module HBS2.CLI.Run.Peer where
+
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run.Internal
+
+import HBS2.Hash
+import HBS2.Base58
+import HBS2.Data.Types.Refs
+import HBS2.Storage
+import HBS2.Peer.RPC.Client
+import HBS2.Peer.CLI.Detect
+import HBS2.Peer.RPC.Client.Unix
+import HBS2.Peer.RPC.API.Peer
+import HBS2.Peer.RPC.API.RefLog
+import HBS2.Peer.RPC.API.Storage
+import HBS2.Peer.RPC.API.LWWRef
+import HBS2.Net.Auth.Schema()
+
+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)
+
+{- HLINT ignore "Functor law" -}
+
+putTextLit :: forall c m . (IsContext c, MonadUnliftIO m)
+           => AnyStorage
+           -> Text
+           -> RunM c m (Syntax c)
+
+putTextLit sto s = do
+    h <- putBlock sto (LBS8.pack (Text.unpack s))
+           `orDie` "can't store block"
+         <&> HashRef
+
+    pure (mkStr @c (show $ pretty h))
+
+peerEntries :: forall c m . ( IsContext c
+                            , MonadUnliftIO m
+                            , HasClientAPI PeerAPI UNIX m
+                            , HasClientAPI StorageAPI UNIX m
+                            , HasStorage m
+                            , Exception (BadFormException c)
+                            ) => MakeDictM c m ()
+peerEntries = do
+
+  entry $ bindMatch "hbs2:peer:detect" $ \case
+    _ -> detectRPC <&> maybe (nil @c) mkStr
+
+  entry $ bindMatch "hbs2:peer:storage:block:get" $ \case
+    [StringLike s] -> do
+      flip runContT pure do
+
+        sto <- getStorage
+        ha <- pure (fromStringMay @HashRef s)
+               `orDie` "invalid hash"
+
+        lbs <- getBlock sto (fromHashRef ha)
+                `orDie` show ("missed-block" <+> pretty ha)
+
+        mkOpaque lbs
+
+    _ -> throwIO $ BadFormException @c nil
+
+  entry $ bindMatch "hbs2:peer:storage:block:del" $ \case
+    [HashLike ha] -> do
+      flip runContT pure do
+        sto <- getStorage
+        delBlock sto (fromHashRef ha)
+        pure nil
+
+    _ -> throwIO $ BadFormException @c nil
+
+  entry $ bindMatch "hbs2:peer:storage:block:size" $ \case
+    [HashLike ha] -> do
+      flip runContT pure do
+        sto <- getStorage
+        mbsz <- hasBlock sto (fromHashRef ha)
+        pure $ maybe (mkSym "no-block") mkInt mbsz
+
+    _ -> throwIO $ BadFormException @c nil
+
+  -- stores *small* block
+  entry $ bindMatch "hbs2:peer:storage:block:put" $ \case
+
+    [isOpaqueOf @LBS.ByteString -> Just lbs] -> do
+      sto <- getStorage
+      (putBlock sto lbs <&> fmap (mkSym . show . pretty . HashRef) )
+        >>= orThrowUser "storage error"
+
+    [isOpaqueOf @BS.ByteString -> Just bs] -> do
+      sto <- getStorage
+      (putBlock sto (LBS.fromStrict bs) <&> fmap (mkSym . show . pretty . HashRef) )
+        >>= orThrowUser "storage error"
+
+    -- FIXME: deprecate-this
+    [ListVal [SymbolVal "blob", LitStrVal s]] -> do
+      flip runContT pure do
+        sto <- getStorage
+        lift $ putTextLit sto s
+
+    [LitStrVal s] -> do
+      flip runContT pure do
+        sto <- getStorage
+        lift $ putTextLit sto s
+
+    [] -> do
+        bs <- liftIO BS.getContents
+        sto <- getStorage
+        putBlock sto (LBS.fromStrict bs) >>= \case
+          Nothing -> pure nil
+          Just h  -> pure $ mkSym (show $ pretty $ HashRef h)
+
+    e -> throwIO $ BadFormException @c (mkList e)
+
+  brief "checks if peer available"
+    $ noArgs
+    $ returns "dict" "dictionary of peer attributes"
+    $ examples [qc|
+(hbs2:peer:poke)
+(
+ (peer-key: "35gKUG1mwBTr3tQpjWwR2kBYEnDmHxesoJL5Lj7tMjq3")
+ (udp: "0.0.0.0:7354")
+ (tcp: "tcp://0.0.0.0:3001")
+ (local-multicast: "239.192.152.145:10153")
+ (rpc: "/tmp/hbs2-rpc.socket")
+ (http-port: 5000))
+    |]
+    $ entry $ bindMatch "hbs2:peer:poke" $ \case
+      _ -> do
+        api <- getClientAPI @PeerAPI @UNIX
+        callRpcWaitMay @RpcPoke (TimeoutSec 1) api ()
+          <&> fromMaybe ""
+          <&> parseTop
+          <&> either (const nil) (mkList . fmap fixContext)
+
+

hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs

@@ -0,0 +1,405 @@
+module HBS2.CLI.Run.RefChan
+  ( module HBS2.CLI.Run.RefChan
+  , keymanNewCredentials
+  ) where
+
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run.Internal
+import HBS2.CLI.Run.Internal.KeyMan
+import HBS2.CLI.Run.Internal.RefChan
+
+
+import HBS2.Data.Types.Refs
+import HBS2.Peer.CLI.Detect
+import HBS2.Peer.RPC.Client.Unix
+import HBS2.Peer.RPC.API.Peer
+import HBS2.Peer.RPC.API.RefChan
+import HBS2.Peer.RPC.Client.RefChan as Client
+
+import HBS2.Storage.Operations.ByteString
+
+-- import HBS2.Net.Proto
+-- import HBS2.Net.Auth.Credentials
+-- import HBS2.Base58
+-- import HBS2.Defaults
+-- import HBS2.Events
+-- import HBS2.Peer.Proto.Peer
+-- import HBS2.Net.Proto.Sessions
+import HBS2.Data.Types.Refs
+import HBS2.Data.Detect
+-- import HBS2.Data.Types.SignedBox
+-- import HBS2.Storage
+
+
+import HBS2.Peer.Proto.RefChan
+import Data.Either
+import HBS2.Base58
+import HBS2.Net.Auth.Credentials
+import HBS2.Net.Auth.Schema()
+import HBS2.Data.Types.SignedBox
+import HBS2.Peer.RPC.Client
+import HBS2.Peer.RPC.API.Storage
+import HBS2.Storage
+
+import HBS2.KeyMan.Keys.Direct
+import HBS2.KeyMan.App.Types
+
+import Data.HashMap.Strict qualified as HM
+import Data.HashSet qualified as HS
+import Data.Coerce
+import Control.Monad.Trans.Cont
+import Control.Monad.Trans.Maybe
+import Control.Monad.Except
+import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString.Lazy.Char8 qualified as LBS8
+import Data.ByteString.Char8 qualified as BS8
+import Data.Text qualified as Text
+import Codec.Serialise
+import Control.Concurrent.STM qualified as STM
+
+import Text.InterpolatedString.Perl6 (qc)
+import Streaming.Prelude qualified as S
+
+refchanEntries :: forall c m . ( IsContext c
+                               , MonadUnliftIO m
+                               , Exception (BadFormException c)
+                               , HasClientAPI RefChanAPI UNIX m
+                               , HasClientAPI StorageAPI UNIX m
+                               , HasClientAPI PeerAPI UNIX m
+                               , HasStorage m
+                               ) => MakeDictM  c m ()
+refchanEntries = do
+
+  brief "requests all rechans that peer is subcribed to"
+    $ args []
+    $ returns "list" "list of all refchans"
+    $ examples [qc|
+
+(hbs2:refchan:list)
+("Atg67E6CPMJWKvR9BvwZTTEjg3Hjz4CYCaEARGANepGP"
+ "A5W6jPBjzvdpxaQ2e8xBLYaRZjPXzi4yX7xjC52gTiKk"
+ "EjjK7rpgRRJ4yzAhTcwis4XawwagCbmkns8n73ogY3uS")
+    |]
+    $ entry $ bindMatch "hbs2:refchan:list" $ \case
+        [] -> do
+          flip runContT pure do
+            api <- getClientAPI @PeerAPI @UNIX
+            r <- callService @RpcPollList2 api (Just "refchan", Nothing)
+                   >>= orThrowUser "can't get refchan list"
+            pure $ mkList $ fmap (mkStr . show . pretty . AsBase58 . view _1) r
+
+        _ -> throwIO (BadFormException @c nil)
+
+
+  brief "reads refchan head block"
+    $ args [arg "symbol" "parsed|_", arg "string" "PUBKEY"]
+    $ returns "" "string"
+    $ examples [qc|
+
+(hbs2:refchan:head:get :parsed ExTZuEy2qVBRshWdSwfxeKcMmQLbK2f5NxRwhvXda9qd)
+(version 2)
+(quorum 1)
+(wait 10)
+(peer "5tZfGUoQ79EzFUvyyY5Wh1LzN2oaqhrn9kPnfk6ByHpf" 1)
+(peer "35gKUG1mwBTr3tQpjWwR2kBYEnDmHxesoJL5Lj7tMjq3" 1)
+(peer "5GnroAC8FXNRL8rcgJj6RTu9mt1AbuNd5MZVnDBcCKzb" 1)
+(author "Gu5FxngYYwpRfCUS9DJBGyH3tvtjXFbcZ7CbxmJPWEGH")
+(author "ExTZuEy2qVBRshWdSwfxeKcMmQLbK2f5NxRwhvXda9qd")
+(reader "5UXrEhYECJ2kEQZZPEf4TisfWsLNdh2nGYQQz8X9ioMv")
+(reader "CcRDzezX1XQdPxRMuMKzJkfHFB4yG7vGJeTYvScKkbP8")
+; (head-extensions: (count: 0) (size 0))
+
+
+(hbs2:refchan:head:get :whatever ExTZuEy2qVBRshWdSwfxeKcMmQLbK2f5NxRwhvXda9qd)
+HucjFUznHJeA2UYZCdUFHtnE3pTwhCW5Dp7LV3ArZBcr
+
+    |]
+    $ entry $ bindMatch "hbs2:refchan:head:get" $ \case
+      [StringLike what, SignPubKeyLike puk] -> do
+
+        flip runContT pure do
+
+          callCC $ \exit -> do
+
+            w <- lift (getRefChanHeadHash @UNIX puk)
+
+            hx <- ContT $ maybe1 w (pure nil)
+
+            case what of
+              "parsed"  -> do
+                  hdblk <- lift (Client.getRefChanHead @UNIX puk)
+
+                  exit $ mkStr (show $ pretty hdblk)
+
+              _ -> exit $ mkStr (show $ pretty $ AsBase58 hx)
+
+            pure nil
+
+
+      _ -> throwIO (BadFormException @c nil)
+
+  entry $ bindMatch "hbs2:refchan:head:update" $ \syn -> do
+
+      (rchan, rch) <- case syn of
+        [SignPubKeyLike rchan, StringLike headFile] -> do
+
+            rch <- liftIO (readFile headFile)
+               <&> fromStringMay @(RefChanHeadBlock L4Proto)
+               >>= orThrowUser "can't parse RefChanHeadBlock"
+
+            pure (rchan, rch)
+
+        [SignPubKeyLike rchan, ListVal syn] -> do
+            rch <- fromStringMay @(RefChanHeadBlock L4Proto) (show $ vcat (fmap pretty syn))
+                     & orThrowUser "can't parse RefChanHeadBlock"
+
+            pure (rchan, rch)
+
+        _ -> throwIO (BadFormException @c nil)
+
+      sto <- getStorage
+
+      rchanApi <- getClientAPI @RefChanAPI @UNIX
+
+      creds <- runKeymanClient $ loadCredentials rchan
+                     >>= orThrowUser "can't load credentials"
+
+      let box = makeSignedBox @'HBS2Basic (view peerSignPk creds) (view peerSignSk creds) rch
+
+      href <- writeAsMerkle sto  (serialise box)
+
+      callService @RpcRefChanHeadPost rchanApi (HashRef href)
+          >>= orThrowUser "can't post refchan head"
+
+      pure nil
+
+
+  entry $ bindMatch "hbs2:refchan:get" $ \case
+    [SignPubKeyLike rchan] -> do
+
+      api <- getClientAPI @RefChanAPI @UNIX
+
+      h <- callService @RpcRefChanGet api rchan
+             >>= orThrowUser "can't request refchan head"
+
+      pure $ maybe nil (mkStr . show . pretty . AsBase58) h
+
+    _ -> throwIO (BadFormException @c nil)
+
+
+  entry $ bindMatch "hbs2:refchan:create" $ \syn -> do
+
+    peerApi  <- getClientAPI @PeerAPI @UNIX
+
+    rch <- case syn of
+
+      [ListVal es] -> do
+        fromStringMay @(RefChanHeadBlock L4Proto) (show $ vcat (fmap pretty es))
+             & orThrowUser "Invalid refchan head syntax"
+
+      [StringLike headFile] -> do
+        liftIO (readFile headFile)
+           <&> fromStringMay @(RefChanHeadBlock L4Proto)
+           >>= orThrowUser "can't parse RefChanHeadBlock"
+
+      [] -> do
+       poked <- callService @RpcPoke peerApi ()
+                   >>= orThrowUser "can't poke hbs2-peer"
+                   <&> parseTop
+                   >>= orThrowUser "invalid hbs2-peer attributes"
+
+       ke <- [ x
+             | ListVal [SymbolVal "peer-key:", SignPubKeyLike x] <- poked
+             ] & headMay & orThrowUser "hbs2-peer key not found"
+
+       let rch0 = refChanHeadDefault @L4Proto
+                   & set refChanHeadPeers (HM.singleton ke 1)
+                   & set refChanHeadAuthors (HS.singleton ke)
+
+       pure rch0
+
+      _ -> throwIO (BadFormException @c nil)
+
+    refchan <- createNewRefChan @c Nothing rch
+    pure $ mkSym (show $ pretty (AsBase58 refchan))
+
+  brief "prints refchan head example"
+    $ returns "nil" mempty
+    $ entry $ bindMatch "hbs2:refchan:head:example" $ nil_ $ \case
+        [] -> flip runContT pure do
+
+          let rch0 = refChanHeadDefault @L4Proto
+
+          api <- getClientAPI @PeerAPI  @UNIX
+
+          pips <- callService @RpcPeers api ()
+                    <&> either (const mempty) (HM.fromList . fmap ((,1) . fst) . take 3)
+
+
+          creds <- replicateM 3 (newCredentialsEnc @HBS2Basic 1)
+
+          let authors = fmap (view peerSignPk) creds
+                            & HS.fromList
+
+          let readers = foldMap (view peerKeyring) creds
+                            & fmap (view krPk)
+                            & take 3
+                            & HS.fromList
+
+          let rch = ( set refChanHeadPeers pips
+                    . set refChanHeadAuthors authors
+                    . set refChanHeadReaders readers
+                    . set refChanHeadNotifiers authors
+                    ) rch0
+
+          liftIO $ print $
+               ";" <+> "this is an example of refchan head block config"
+            <> line
+            <> ";" <+> "edit it before applying" <> line
+            <> ";"  <+> "set up the actual keys / credentials you need" <> line
+            <> line <> line
+            <> ";" <+> "(version INT) is the head block version" <> line
+            <> ";" <+> "the refchan head block will be set only" <>line
+            <> ";" <+> "if it's version  if greater than the already existed one" <> line
+            <> line
+
+            <> ";" <+> "(quorum INT) is a number of accept messages issued by peers" <> line
+            <> ";" <+> "to include propose message to the refchan" <> line
+            <> line
+
+            <> ";" <+> "(wait INT) is an quorum  wait time in seconds" <> line
+            <> line
+
+            <> ";" <+> "(peer PUBKEY WEIGHT) sets the peer allowed for posting propose/accept messages" <> line
+            <> ";" <+> "PUBKEY is a SIGNATURE public key as base58 string" <> line
+            <> ";" <+> "only messages from that peers will be accepted" <> line
+            <> ";" <+> "WEIGHT is not used yet but reserved for the future" <> line
+            <> ";" <+> "this parameter is optional but there is should be some peers or" <> line
+            <> ";" <+> "all messages will be sent to nowhere" <> line
+            <> line
+
+            <> ";" <+> "(author PUBKEY) adds 'author' i.e. key that is allowed to sign the propose message" <> line
+            <> ";" <+> "PUBKEY is a SIGNATURE public key as base58 string" <> line
+            <> ";" <+> "only the propose  messages signed by one of thise keys will be accepted" <> line
+            <> line
+
+            <> ";" <+> "(notifier PUBKEY) adds 'notifier' i.e. key that is allowed to sign the notify message" <> line
+            <> ";" <+> "PUBKEY is a SIGNATURE public key as base58 string" <> line
+            <> ";" <+> "only the propose  messages signed by one of thise keys will be accepted" <> line
+            <> ";" <+> "notify messages are not written to the refchan merkle tree" <> line
+            <> ";" <+> "and they useful for implementing any sort of ephemeral messaging" <> line
+            <> ";" <+> "those clauses are OPTIONAL and may be omitted" <> line
+            <> line
+
+            <> ";" <+> "(reader PUBKEY) adds 'author' i.e. key that is allowed to decrypt messages" <> line
+            <> ";" <+> "PUBKEY is a ENCRYPTION public key as base58 string" <> line
+            <> ";" <+> "NOTE: messages in a refchan are not encrypted by default" <> line
+            <> ";" <+> "    it's totally up to an application for this refchan" <> line
+            <> ";" <+> "    therefore this clause is just used for setting reader keys to" <> line
+            <> ";" <+> "    implement any ACL/encrypting mechanism" <> line
+            <> ";" <+> "    i.e. groupkey may be inherited from the RefChanHead block" <> line
+            <> ";" <+> "    to encrypt data posted to a refchan" <> line
+            <> ";" <+> "those clauses are OPTIONAL and may be omitted" <> line
+            <> line
+
+            <> pretty rch
+
+        _ -> throwIO (BadFormException @c nil)
+
+
+  brief "creates RefChanUpdate/AnnotatedHashRef transaction for refchan" $
+    args [arg "string" "sign-key", arg "string" "payload-tree-hash"] $
+    entry $ bindMatch "hbs2:refchan:tx:annref:create" $ \case
+      [SignPubKeyLike signpk, HashLike hash] -> do
+         sto <- getStorage
+         void $ hasBlock sto (fromHashRef hash) `orDie` "no block found"
+         let lbs = AnnotatedHashRef Nothing hash & serialise
+         creds  <- runKeymanClientRO $ loadCredentials signpk >>= orThrowUser "can't find credentials"
+         let box = makeSignedBox @HBS2Basic (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict lbs) & serialise
+         pure $ mkForm @c "blob" [mkStr (LBS8.unpack box)]
+
+      _ -> throwIO (BadFormException @c nil)
+
+
+  brief "creates RefChanUpdate/SeqRef transaction for refchan" $
+    args [arg "string" "sign-key", arg "string" "payload-tree-hash", arg "(-t int)?" "seqno"] $
+    entry $ bindMatch "hbs2:refchan:tx:seqref:create" $ \syn -> do
+      now <- liftIO $ getPOSIXTime <&> round
+      let (opts, argz) = splitOpts [("-s",1)] syn
+      let s = headDef now  [ x | MatchOption "-n" (LitIntVal x) <- opts]
+      case opts of
+        [SignPubKeyLike signpk, HashLike hash] -> do
+           sto <- getStorage
+           void $ hasBlock sto (fromHashRef hash) `orDie` "no block found"
+           let lbs = SequentialRef s (AnnotatedHashRef Nothing hash) & serialise
+           creds  <- runKeymanClientRO $ loadCredentials signpk >>= orThrowUser "can't find credentials"
+           let box = makeSignedBox @HBS2Basic (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict lbs) & serialise
+           pure $ mkForm @c "blob" [mkStr (LBS8.unpack box)]
+        _ -> throwIO (BadFormException @c nil)
+
+  brief "creates RefChanUpdate/Raw transaction for refchan" $
+    args [arg "string" "sign-key", arg "string" "data"] $
+    entry $ bindMatch "hbs2:refchan:tx:raw:create" $ \syn -> do
+      case syn of
+        [SignPubKeyLike signpk, StringLike x] -> do
+           let lbs = LBS8.pack x & serialise
+           creds  <- runKeymanClientRO $ loadCredentials signpk >>= orThrowUser "can't find credentials"
+           let box = makeSignedBox @HBS2Basic (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict lbs) & serialise
+           mkOpaque @c box
+
+        _ -> throwIO (BadFormException @c nil)
+
+
+  entry $ bindMatch "hbs2:refchan:tx:raw:list" $ \case
+    [SignPubKeyLike rchan] -> lift do
+
+      q <- newTQueueIO
+
+      walkRefChanTx @UNIX (const $ pure True) rchan $ \txh u -> do
+
+        case  u of
+
+          A (AcceptTran (Just ts) self what) -> do
+            let tx = fromIntegral ts :: Integer
+            let hs = show $ pretty self
+            let they = show $ pretty what
+            let x = mkForm @c "accept" [ mkSym hs, mkInt tx, mkSym they ]
+            atomically $ writeTQueue q x
+
+          A _  -> none
+
+          P1 ppk h (ProposeTran _ box) -> void $ runMaybeT do
+            (pk, bs) <- unboxSignedBox0 box & toMPlus
+            bss <- deserialiseOrFail @LBS.ByteString (LBS.fromStrict bs) & toMPlus
+            e <- mkOpaque bss
+            let hs = show $ pretty h
+            let ppks = show (pretty (AsBase58 ppk))
+            let pks  = show (pretty (AsBase58 pk))
+            let x = mkForm @c "propose" [ mkSym hs, mkSym ppks, mkSym pks, e ]
+            atomically $ writeTQueue q x
+
+          P0{} -> none
+
+      mkList <$>  atomically (STM.flushTQueue q)
+
+    e -> throwIO (BadFormException @c (mkList e))
+
+  brief "posts Propose transaction to the refchan" $
+    args [arg "string" "refchan", arg "blob" "signed-box"] $
+    entry $ bindMatch "hbs2:refchan:tx:propose" $ nil_ $ \syn -> do
+
+      (chan,lbs) <- case syn of
+         [SignPubKeyLike rchan, ListVal [SymbolVal "blob", LitStrVal box]] -> do
+          bbox <- Text.unpack box & LBS8.pack & deserialiseOrFail & orThrowUser "bad transaction"
+          pure (rchan, bbox)
+
+         [SignPubKeyLike rchan, MatchOpaqueVal @_ @LBS.ByteString lbs] -> do
+           pure (rchan, lbs)
+
+         _ -> throwIO (BadFormException @c (mkList syn))
+
+      api <- getClientAPI @RefChanAPI @UNIX
+      box  <- deserialiseOrFail lbs & orThrowUser "invalid box"
+      void $ callService @RpcRefChanPropose api (chan, box)
+
+

hbs2-cli/lib/HBS2/CLI/Run/RefLog.hs

@@ -0,0 +1,234 @@
+module HBS2.CLI.Run.RefLog
+  ( module HBS2.CLI.Run.RefLog
+  , module HBS2.CLI.Run.Internal.RefLog
+  ) where
+
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run.Internal
+import HBS2.CLI.Run.Internal.KeyMan
+import HBS2.CLI.Run.Internal.RefLog
+
+import HBS2.Data.Types.Refs
+import HBS2.Merkle
+import HBS2.Data.Detect
+import HBS2.Storage
+import HBS2.Peer.RPC.Client
+import HBS2.Peer.CLI.Detect
+import HBS2.Peer.RPC.Client.Unix
+import HBS2.Peer.RPC.API.Peer
+import HBS2.Peer.RPC.API.RefLog
+import HBS2.Peer.RPC.API.Storage
+
+import HBS2.Peer.Proto hiding (request)
+import HBS2.Base58
+import HBS2.Net.Auth.Credentials
+import HBS2.Net.Auth.Schema()
+
+import HBS2.KeyMan.Keys.Direct
+import HBS2.KeyMan.App.Types
+
+import Codec.Serialise
+import Data.Coerce
+import Data.Either
+import Data.ByteString qualified as BS
+import Data.ByteString.Char8 qualified as BS8
+import Data.ByteString (ByteString)
+import Data.ByteString.Lazy.Char8 qualified as LBS8
+import Data.ByteString.Lazy qualified as LBS
+import Data.Text.Encoding qualified as TE
+import Data.Text qualified as Text
+import Control.Monad.Trans.Cont
+
+import Streaming.Prelude qualified as S
+
+getCredentialsForReflog :: MonadUnliftIO m => RefLogKey 'HBS2Basic -> m (PeerCredentials 'HBS2Basic)
+getCredentialsForReflog reflog = do
+  runKeymanClientRO (loadCredentials reflog)
+     >>= orThrowUser "credentials not found"
+
+mkRefLogUpdateFrom :: (MonadUnliftIO m) => RefLogKey 'HBS2Basic -> m ByteString ->  m (RefLogUpdate L4Proto)
+mkRefLogUpdateFrom reflog mbs = do
+  what <- getCredentialsForReflog reflog
+  let puk = view peerSignPk what
+  let privk = view peerSignSk what
+  txraw <- mbs
+  makeRefLogUpdate @L4Proto @'HBS2Basic (coerce puk) privk txraw
+
+
+reflogEntries :: forall c m . ( IsContext c
+                              , Exception (BadFormException c)
+                              , MonadUnliftIO m
+                              , HasStorage m
+                              , HasClientAPI PeerAPI UNIX m
+                              , HasClientAPI RefLogAPI UNIX m
+                              , HasClientAPI StorageAPI UNIX m
+                              ) => MakeDictM  c m ()
+reflogEntries = do
+
+  entry $ bindMatch "hbs2:reflog:create" $ \case
+    [] -> do
+      reflog <- keymanNewCredentials (Just "reflog") 0
+
+      api <- getClientAPI @PeerAPI  @UNIX
+      void $ callService @RpcPollAdd api (reflog, "reflog", 31)
+      pure $ mkStr (show $ pretty (AsBase58 reflog))
+
+    _ -> throwIO (BadFormException @C nil)
+
+  entry $ bindMatch "hbs2:reflog:add" $ \case
+    [SignPubKeyLike reflog] -> do
+      -- reflog <- keymanNewCredentials (Just "reflog") 0
+
+      api <- getClientAPI @PeerAPI @UNIX
+      void $ callService @RpcPollAdd api (reflog, "reflog", 31)
+      pure $ mkStr (show $ pretty (AsBase58 reflog))
+
+    _ -> throwIO (BadFormException @C nil)
+
+
+
+  entry $ bindMatch "hbs2:reflog:tx:annhashref:create" $ \case
+    [StringLike puk, StringLike hash] -> do
+      reflog <- orThrowUser "bad reflog key" (fromStringMay puk)
+      sto <- getStorage
+      hashref <- orThrowUser "bad hash" (fromStringMay @HashRef hash)
+      void $ hasBlock sto (fromHashRef hashref) `orDie` "no block"
+      let sref = AnnotatedHashRef Nothing hashref
+      rlu <- mkRefLogUpdateFrom reflog (pure $ LBS.toStrict $ serialise sref) <&> serialise
+      pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)]
+
+    _ -> throwIO (BadFormException @C nil)
+
+
+  entry $ bindMatch "hbs2:reflog:tx:copy:all" $ nil_ \case
+    [SignPubKeyLike a, SignPubKeyLike b] -> do
+
+      let cre = runKeymanClientRO (loadCredentials b)
+                   >>= orThrow (RefLogNoCredentials (show $ pretty (AsBase58 b)))
+
+      copyTransactions cre a b
+
+    e -> throwIO (BadFormException @c (mkList e))
+
+  entry $ bindMatch "hbs2:reflog:tx:post" $ nil_ \case
+    [BlobLike blob] -> do
+      caller <- getClientAPI @RefLogAPI @UNIX
+      wtf <- deserialiseOrFail @(RefLogUpdate L4Proto) (LBS.fromStrict blob)
+              & orThrowUser "invalid tx"
+      void $ callService @RpcRefLogPost caller wtf
+
+    _ -> throwIO (BadFormException @C nil)
+
+  entry $ bindMatch "hbs2:reflog:tx:seqref:create" $ \case
+    [StringLike puk, LitIntVal sn, StringLike hash] -> do
+      reflog <- orThrowUser "bad reflog key" (fromStringMay puk)
+      sto <- getStorage
+      hashref <- orThrowUser "bad hash" (fromStringMay @HashRef hash)
+      void $ hasBlock sto (fromHashRef hashref) `orDie` "no block"
+      let sref = SequentialRef sn (AnnotatedHashRef Nothing hashref)
+      rlu <- mkRefLogUpdateFrom reflog (pure $ LBS.toStrict $ serialise sref) <&> serialise
+      pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)]
+
+    _ -> throwIO (BadFormException @C nil)
+
+  entry $ bindMatch "hbs2:reflog:tx:raw:create" $ \case
+    [SymbolVal "stdin", SignPubKeyLike reflog] -> do
+
+      rlu <- mkRefLogUpdateFrom (RefLogKey reflog) ( liftIO BS.getContents )
+                <&> serialise
+
+      pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)]
+
+    [LitStrVal s, StringLike rlo] -> do
+      reflog <- orThrowUser "bad reflog" (fromStringMay rlo)
+
+      rlu <- mkRefLogUpdateFrom reflog ( pure (BS8.pack (Text.unpack s)) )
+               <&> serialise
+
+      pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)]
+
+    _ -> throwIO (BadFormException @C nil)
+
+
+  entry $ bindMatch "hbs2:reflog:get" $ \case
+    [StringLike puk] -> do
+
+      flip runContT pure do
+        reflog <- orThrowUser "bad reflog key" (fromStringMay puk)
+        api <- getClientAPI @RefLogAPI  @UNIX
+        what <- callService @RpcRefLogGet api reflog
+                  >>= orThrowUser "can't get reflog"
+        pure $ mkStr (show $ pretty what)
+
+    _ -> throwIO (BadFormException @C nil)
+
+  entry $ bindMatch "hbs2:reflog:fetch" $ \case
+    [StringLike puk] -> do
+      flip runContT pure do
+        reflog <- orThrowUser "bad reflog key" (fromStringMay puk)
+        api <- getClientAPI @RefLogAPI  @UNIX
+        void $ callService @RpcRefLogFetch api reflog
+        pure $ mkStr "okay"
+
+    _ -> throwIO (BadFormException @C nil)
+
+  entry $ bindMatch "hbs2:reflog:list" $ \case
+    [] -> do
+      flip runContT pure do
+        api <- getClientAPI @PeerAPI @UNIX
+        r <- callService @RpcPollList2 api (Just "reflog", Nothing)
+               >>= orThrowUser "can't get reflog list"
+        pure $ mkList $ fmap (mkStr . show . pretty . AsBase58 . view _1) r
+
+    _ -> throwIO (BadFormException @C nil)
+
+
+  entry $ bindMatch "hbs2:reflog:tx:decode" $ \case
+    [HashLike s] -> do
+      sto <- getStorage
+      blk <- getBlock sto (coerce s)
+      pure $ maybe1 blk nil (decodeRefLogTx @c (Just s))
+
+    [MatchOpaqueVal @_ @(HashRef, ByteString) (ha,bs)] -> do
+      pure $ decodeRefLogTx @c (Just ha) (LBS.fromStrict bs)
+
+    e -> throwIO $ BadFormException @c nil
+
+  entry $ bindMatch "hbs2:reflog:tx:list" $ \case
+     [e, SignPubKeyLike puk] -> do
+
+      flip runContT pure do
+
+        callCC \exit -> do
+
+          api <- getClientAPI @RefLogAPI  @UNIX
+          sto <- getStorage
+
+          r <- callService @RpcRefLogGet api puk
+                 >>= orThrowUser "can't get reflog value"
+
+          rlh <- ContT $ maybe1 r (pure nil)
+
+          hashes <- S.toList_ do
+                      walkMerkle @[HashRef] (fromHashRef rlh) (getBlock sto) $ \case
+                        (Left _) -> lift $ exit nil
+                        (Right (hs :: [HashRef]))  -> S.each hs
+
+          rr <- forM hashes $ \ha -> do
+
+            tx <- getBlock sto (coerce ha)
+                     >>= orThrowUser "missed-block"
+                     <&> deserialiseOrFail @(RefLogUpdate L4Proto)
+                     >>= orThrowUser "invalid-tx"
+
+            let bs = view refLogUpdData tx
+
+            payload <- mkOpaque (ha,bs)
+
+            lift $ apply_ e [payload]
+
+          pure $ mkList rr
+
+     _ -> throwIO (BadFormException @C nil)
+
+

hbs2-cli/lib/HBS2/CLI/Run/Sigil.hs

@@ -0,0 +1,135 @@
+{-# OPTIONS_GHC -Wno-name-shadowing #-}
+module HBS2.CLI.Run.Sigil where
+
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run.Internal
+
+import HBS2.Data.Types.Refs
+import HBS2.Base58
+import HBS2.Storage
+import HBS2.Data.Types.SignedBox
+import HBS2.Net.Auth.Credentials
+import HBS2.Net.Auth.Credentials.Sigil
+
+import Data.List qualified as L
+import Data.ByteString.Char8 qualified as BS8
+import Data.ByteString.Lazy qualified as LBS
+import Lens.Micro.Platform
+
+
+sigilEntries :: forall c m . (c ~ C, IsContext c, MonadUnliftIO m, HasStorage m)
+             => MakeDictM c m ()
+sigilEntries = do
+
+  entry $ bindMatch "hbs2:sigil:sign-pubkey" $ \case
+    [ ListVal (SymbolVal sigil : (hasKey "sign-pubkey" -> Just s)) ] -> do
+      pure s
+
+    _ -> throwIO $ BadFormException @C nil
+
+
+  entry $ bindMatch "hbs2:sigil:encrypt-pubkey" $ \case
+    [ ListVal (SymbolVal sigil : (hasKey "encrypt-pubkey" -> Just s)) ] -> do
+      pure s
+
+    _ -> throwIO $ BadFormException @C nil
+
+  brief "parses sigil"
+    $ args [ arg "sigil" "string" ]
+    $ examples [qc|hbs2:sigil:parse [str:read-file some.sigil]|]
+    $ entry $ bindMatch "hbs2:sigil:parse" $ \case
+      [StringLike s] -> do
+
+        let bs = BS8.pack s
+        sigil <- pure (parseSerialisableFromBase58 @(Sigil 'HBS2Basic) bs)
+                    `orDie` "parse sigil failed"
+
+        (_,sd) <- pure (unboxSignedBox0 @(SigilData 'HBS2Basic) (sigilData sigil))
+                    `orDie` "signature check failed"
+
+        pure (parseTop $ show $ parens ("sigil" <> line <> indent 2 (vcat $ [pretty sigil, pretty sd])))
+                `orDie` "bad sigil"
+                <&> head
+
+      _ -> throwIO $ BadFormException @C nil
+
+
+  brief "loads sigil from hbs2 store as base58 string"
+    $ args [arg "hash" "string" ]
+    $ returns  "sigil" "string"
+    $ entry $ bindMatch "hbs2:sigil:load:base58" $ \case
+      [HashLike key] -> lift do
+        sto <- getStorage
+        r <- loadSigil @HBS2Basic sto key >>= orThrowUser "no sigil found"
+        pure $ mkStr @c ( show $ pretty $ AsBase58 r  )
+
+      _ -> throwIO $ BadFormException @c nil
+
+  brief "stores sigil to hbs2 store"
+    $ args [arg "string" "file" ]
+    $ returns "string" "hash"
+    $ entry $ bindMatch "hbs2:sigil:store:file" $ \case
+      [StringLike fn] -> lift do
+        sto <- getStorage
+        lbs <- liftIO (LBS.readFile fn)
+        sigil <- decodeSigil @HBS2Basic lbs & orThrowUser "invalid sigil file"
+        href <- storeSigil sto sigil
+        pure $ mkStr ( show $ pretty href )
+
+      _ -> throwIO $ BadFormException @c nil
+
+
+  brief "create sigil from keyring" $
+   desc [qc|
+
+;; creates from keyring, uses first encryption key if found
+
+hbs2:sigil:create:from-keyring KEYRING-FILE
+
+;; creates from keyring, uses n-th encryption key if found, N starts from 1
+
+hbs2:sigil:create:from-keyring KEYRING-FILE N
+
+;; creates from keyring, uses encryption key wit prefix S if found
+
+hbs2:sigil:create:from-keyring KEYRING-FILE S
+
+   |]
+   $ 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"
+
+      pure $ mkStr (show $ pretty $ AsBase58 sigil)
+
+    where
+      findKey s xs = headMay [ e
+                             | e@(KeyringEntry k _ _) <- xs
+                             , L.isPrefixOf s (show $ pretty (AsBase58 k))
+                             ]
+

hbs2-cli/lib/HBS2/CLI/Run/Tree.hs

@@ -0,0 +1,194 @@
+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.Defaults
+
+import HBS2.Base58
+import HBS2.Data.Types.Refs
+import HBS2.Merkle
+import HBS2.Data.Detect
+import HBS2.System.Dir
+import HBS2.Storage
+import HBS2.Storage.Operations.Class
+import HBS2.Storage.Operations.ByteString
+import HBS2.Storage.Operations.Missed
+import HBS2.Storage.Operations.Delete
+
+import HBS2.Net.Auth.Schema()
+
+import HBS2.Peer.RPC.API.Storage
+import HBS2.Peer.RPC.Client
+import HBS2.Peer.RPC.Client.Unix
+
+import Data.ByteString.Lazy qualified as LBS
+import Data.Coerce
+import Data.Text qualified as Text
+import Control.Monad.Except
+import Codec.Serialise
+import Streaming.Prelude qualified as S
+
+pattern GroveHashes :: forall {c}. [HashRef] -> [Syntax c]
+pattern GroveHashes hashes <- ( groveHashes -> hashes )
+
+groveHashes :: [Syntax c] -> [HashRef]
+groveHashes = \case
+  [ ListVal (HashLikeList hashes) ] -> hashes
+  HashLikeList hashes -> hashes
+  _ -> mempty
+
+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)
+
+
+  brief "reads merkle tree data from storage to stdout"
+    $ args [arg "string" "tree"]
+    $ desc "hbs2:tree:read:stdout HASH"
+    $ returns "nil" ""
+    $ entry $ bindMatch "hbs2:tree:read:stdout" $ nil_ \case
+       [ HashLike h ] -> lift do
+        sto <- getStorage
+
+        runExceptT (getTreeContents sto h)
+                >>= orThrowPassIO
+                >>= liftIO . LBS.putStr
+
+       _ -> throwIO (BadFormException @c nil)
+
+
+  brief "creates a 'grove' -- an annotated hashref list"
+    $ args [arg "list of hashes" "trees"]
+    $ desc [qc|hbs2:grove creates a 'grove' - merkle tree of list of hashes of merkle trees
+It's just an easy way to create a such thing, you may browse it by hbs2 cat -H
+|]
+    $ returns "hash" "string"
+    $ entry $ bindMatch "hbs2:grove" $ \case
+        HashLikeList hashes@(x:_) -> lift do
+          sto <- getStorage
+          let pt = toPTree (MaxSize defHashListChunk) (MaxNum defTreeChildNum) hashes
+          mkSym . show . pretty <$> liftIO (makeMerkle 0 pt $ \(_,_,bss) -> do
+                  void $ putBlock sto bss)
+
+        _ -> throwIO (BadFormException @c nil)
+
+  entry $ bindMatch "hbs2:grove:annotated" $ \case
+    (ListVal ann : GroveHashes hashes) -> lift do
+      sto <- getStorage
+
+      let pt = toPTree (MaxSize defHashListChunk) (MaxNum defTreeChildNum) hashes
+
+      tree <- liftIO (makeMerkle 0 pt $ \(_,_,bss) -> do
+                void $ putBlock sto bss)
+
+      block <- getBlock sto tree
+                  >>= orThrow MissedBlockError
+                  <&> deserialiseOrFail @(MTree [HashRef])
+                  >>= orThrow UnsupportedFormat
+
+      let kwa = Text.unlines $ fmap (Text.pack . show . pretty) ann
+      let mann = MTreeAnn (ShortMetadata kwa) NullEncryption block
+
+      r <- putBlock sto (serialise mann)
+              >>= orThrowUser "can't write tree"
+              <&> HashRef
+
+      pure $ mkSym (show $ pretty r)
+
+    _ -> throwIO (BadFormException @c nil)
+
+
+  entry $ bindMatch "hbs2:tree:missed" $ \case
+    [HashLike href] -> do
+      sto <- getStorage
+      findMissedBlocks sto href
+                <&> mkList . fmap (mkStr @c . show . pretty)
+
+    _ -> throwIO (BadFormException @c nil)
+
+
+  entry $ bindMatch "hbs2:tree:refs" $ \case
+    [HashLike href] -> do
+      sto <- getStorage
+
+      blk <- getBlock sto (coerce href)
+               >>= orThrow MissedBlockError
+
+      let refs = extractBlockRefs (coerce href) blk
+
+      pure $ mkList @c (fmap (mkStr . show . pretty) refs)
+
+    _ -> throwIO (BadFormException @c nil)
+
+
+  brief "shallow scan of a block/tree" $
+    entry $ bindMatch "hbs2:tree:scan" $ \case
+      [HashLike href] -> do
+        sto <- getStorage
+
+        r <- S.toList_ $
+                deepScan ScanShallow (const none) (coerce href) (getBlock sto) $ \ha -> S.yield ha
+
+        -- let refs = extractBlockRefs (coerce href) blk
+        pure $ mkList @c (fmap (mkSym . show . pretty . HashRef) r)
+
+      _ -> throwIO (BadFormException @c nil)
+
+  brief "delete tree" $
+    entry $ bindMatch "hbs2:tree:delete" $ nil_ \case
+      [HashLike href] -> do
+        sto <- getStorage
+        deleteMerkleTree sto href
+
+      _ -> throwIO (BadFormException @c nil)
+
+
+  brief "shallow scan of a block/tree" $
+    entry $ bindMatch "hbs2:tree:scan:deep" $ \case
+      [HashLike href] -> do
+        sto <- getStorage
+
+        r <- S.toList_ $
+                deepScan ScanDeep (const none) (coerce href) (getBlock sto) $ \ha -> S.yield ha
+
+        -- let refs = extractBlockRefs (coerce href) blk
+        pure $ mkList @c (fmap (mkSym . show . pretty . HashRef) r)
+
+      _ -> throwIO (BadFormException @c nil)
+
+
+  brief "shallow scan of a block/tree" $
+    entry $ bindMatch "hbs2:tree:scan:deep:stdout" $ nil_ \case
+      [HashLike href] -> do
+        sto <- getStorage
+
+        deepScan ScanDeep (const none) (coerce href) (getBlock sto) $ \ha -> do
+          liftIO  $ print $ pretty ha
+
+      _ -> throwIO (BadFormException @c nil)
+
+

hbs2-cli/man/man1/hbs2-cli.1

@@ -0,0 +1 @@
+hbs2-cli manual

hbs2-core/hbs2-core.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               hbs2-core
-version:            0.24.1.1
+version:            0.25.3.0
 -- synopsis:
 -- description:
 license:            BSD-3-Clause
@@ -41,8 +41,10 @@ common shared-properties
                      , ConstraintKinds
                      , DataKinds
                      , DeriveDataTypeable
+                     , DeriveFoldable
                      , DeriveFunctor
                      , DeriveGeneric
+                     , DeriveTraversable
                      , DerivingStrategies
                      , DerivingVia
                      , ExtendedDefaultRules
@@ -94,8 +96,9 @@ library
                     , HBS2.Polling
                     , HBS2.Hash
                     , HBS2.Merkle
+                    , HBS2.Merkle.MetaData
+                    , HBS2.Merkle.Walk
                     , HBS2.Net.Auth.Schema
-                    , HBS2.Net.Auth.GroupKeyAsymm
                     , HBS2.Net.Auth.GroupKeySymm
                     , HBS2.Net.Auth.Credentials
                     , HBS2.Net.Auth.Credentials.Sigil
@@ -105,6 +108,7 @@ library
                     , HBS2.Net.Messaging.UDP
                     , HBS2.Net.Messaging.TCP
                     , HBS2.Net.Messaging.Unix
+                    , HBS2.Net.Messaging.Pipe
                     , HBS2.Net.Messaging.Stream
                     , HBS2.Net.Messaging.Encrypted.RandomPrefix
                     , HBS2.Net.Messaging.Encrypted.ByPass
@@ -119,17 +123,15 @@ library
                     , HBS2.Prelude
                     , HBS2.Prelude.Plated
                     , HBS2.Storage
+                    , HBS2.Storage.AdHocStorage
                     , HBS2.Storage.Operations.Class
                     , HBS2.Storage.Operations.ByteString
                     , HBS2.Storage.Operations.Missed
+                    , HBS2.Storage.Operations.Delete
                     , HBS2.System.Logger.Simple
                     , HBS2.System.Logger.Simple.ANSI
                     , HBS2.System.Logger.Simple.Class
                     , HBS2.System.Dir
-                    , HBS2.Net.Dialog.Core
-                    , HBS2.Net.Dialog.Client
-                    , HBS2.Net.Dialog.Helpers.List
-                    , HBS2.Net.Dialog.Helpers.Streaming
                     , HBS2.Misc.PrettyStuff
                     , HBS2.Version
 
@@ -172,6 +174,7 @@ library
                     , network-multicast
                     , network-simple
                     , network-byte-order
+                    , psqueues
                     , prettyprinter
                     , prettyprinter-ansi-terminal
                     , mwc-random
@@ -180,7 +183,7 @@ library
                     , resourcet
                     , safe
                     , safe-exceptions
-                    , saltine ^>=0.2.0.1
+                    , saltine >=0.2.0.1
                     , serialise
                     , sockaddr
                     , split
@@ -188,6 +191,7 @@ library
                     , stm-chans
                     , string-conversions
                     , streaming
+                    , streaming-bytestring
                     , string-conversions
                     , suckless-conf
                     , template-haskell
@@ -196,6 +200,7 @@ library
                     , time
                     , transformers
                     , uniplate
+                    , unix
                     , unordered-containers
                     , unliftio
                     , unliftio-core
@@ -216,7 +221,6 @@ test-suite test
                   -- , TestUniqProtoId
                   , FakeMessaging
                   , HasProtocol
-                  , DialogSpec
                   , TestScheduled
                   , TestDerivedKey
 

hbs2-core/lib/HBS2/Actors.hs

@@ -7,18 +7,21 @@ module HBS2.Actors
   ) where
 
 import HBS2.Prelude
-import HBS2.Clock
 
 import Control.Concurrent.STM
 import Control.Concurrent.STM.TBMQueue qualified as TBMQ
 import Control.Concurrent.STM.TBMQueue (TBMQueue)
 import Control.Concurrent.STM.TVar qualified as TVar
-import Control.Monad
-import Control.Concurrent.Async
-import Data.Function
-import Data.Functor
 import Data.Kind
 import Control.Concurrent
+import Control.Concurrent.Async
+import Control.Exception
+
+data PipelineExcepion =
+  PipelineAddJobTimeout
+  deriving stock (Show,Typeable)
+
+instance Exception PipelineExcepion
 
 data Pipeline m a =
   Pipeline
@@ -51,9 +54,15 @@ stopPipeline pip = liftIO $ do
       pause ( 0.01 :: Timeout 'Seconds) >> next
 
 addJob :: forall a m m1 . (MonadIO m, MonadIO m1) => Pipeline m a -> m a -> m1 ()
-addJob pip act = liftIO $ do
-  doWrite <- atomically $ TVar.readTVar ( stopAdding pip )
-  unless doWrite $ do
+addJob pip' act' = liftIO $ do
+  doWrite <- atomically $ TVar.readTVar ( stopAdding pip' )
+  -- FIXME: exception-timeout-hardcode
+  race (pause @'Seconds 3) (doAddJob doWrite pip' act') >>= \case
+    Left{} -> throwIO PipelineAddJobTimeout
+    _ -> pure ()
+
+  where
+    doAddJob w pip act =
+      unless w $ do
         atomically $ TBMQ.writeTBMQueue (toQueue pip) act
 
-

hbs2-core/lib/HBS2/Actors/Peer.hs

@@ -17,8 +17,6 @@ import HBS2.Events
 import HBS2.Net.Auth.Credentials
 import HBS2.Net.Messaging
 import HBS2.Net.PeerLocator
-import HBS2.Net.PeerLocator.Static
-import HBS2.Net.Proto
 import HBS2.Net.Proto.Sessions
 import HBS2.Prelude.Plated
 import HBS2.Storage
@@ -26,23 +24,26 @@ import HBS2.System.Logger.Simple
 
 import Data.Config.Suckless.KeyValue (HasConf(..))
 
+import Control.Monad
 import Control.Monad.Trans.Maybe
-import Control.Concurrent.Async
+import Control.Monad.Trans.Cont
 import Control.Monad.Reader
+import Control.Monad.Trans.Writer.CPS qualified as CPS
 import Data.ByteString.Lazy (ByteString)
 import Data.Cache (Cache)
 import Data.Cache qualified as Cache
 import Data.Dynamic
-import Data.Foldable hiding (find)
 import Data.Map qualified as Map
 import Data.Maybe
 import GHC.TypeLits
 import Lens.Micro.Platform as Lens
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HashMap
-import Control.Concurrent.STM.TVar
-import Control.Concurrent.STM
 import Control.Monad.IO.Unlift
+import Data.List qualified as L
+import Data.Monoid qualified as Monoid
+import UnliftIO
+import UnliftIO.Concurrent (getNumCapabilities)
 
 import Codec.Serialise (serialise, deserialiseOrFail)
 
@@ -129,6 +130,9 @@ data PeerEnv e =
   , _envSweepers      :: TVar (HashMap SKey [PeerM e IO ()])
   , _envReqMsgLimit   :: Cache (Peer e, Integer, Encoded e) ()
   , _envReqProtoLimit :: Cache (Peer e, Integer) ()
+  , _envSentCounter   :: TVar Int
+  , _envRecvCounter   :: TVar Int
+  , _envProbe         :: TVar AnyProbe
   }
 
 newtype PeerM e m a = PeerM { fromPeerM :: ReaderT (PeerEnv e) m a }
@@ -263,8 +267,9 @@ instance ( MonadIO m
          , Show (Peer e)
          ) => Request e msg m where
   request peer_e msg = do
+
     let proto = protoId @e @msg (Proxy @msg)
-    pipe <- getFabriq @e
+    pip <- getFabriq @e
     me <- ownPeer @e
 
     -- TODO: check if a request were sent to peer and timeout is here
@@ -281,7 +286,7 @@ instance ( MonadIO m
       trace $ "REQUEST: not allowed to send for proto" <+> viaShow proto
 
     when allowed do
-      sendTo pipe (To peer_e) (From me) (AnyMessage @(Encoded e) @e proto (encode msg))
+      sendTo pip (To peer_e) (From me) (AnyMessage @(Encoded e) @e proto (encode msg))
       -- trace $ "REQUEST: after sendTo" <+> viaShow peer_e
 
 
@@ -330,6 +335,11 @@ sweep = do
 
   liftIO $ atomically $ modifyTVar' sw (<> HashMap.fromList (mconcat alive))
 
+addJobIO :: IO () -> PeerM e IO ()
+addJobIO m = do
+  PeerEnv{..} <- ask
+  addJob _envDeferred m
+
 instance ( Typeable (EventKey e p)
          , Typeable (Event e p)
          , Hashable (EventKey e p)
@@ -390,32 +400,81 @@ newPeerEnv pl s bus p = do
   _envSweepers      <- liftIO (newTVarIO mempty)
   _envReqMsgLimit   <- liftIO (Cache.newCache (Just defRequestLimit))
   _envReqProtoLimit <- liftIO (Cache.newCache (Just defRequestLimit))
+  _envSentCounter   <- liftIO (newTVarIO 0)
+  _envRecvCounter   <- liftIO (newTVarIO 0)
+  _envProbe         <- liftIO (newTVarIO (AnyProbe ()))
   pure PeerEnv {..}
 
-runPeerM :: forall e m . ( MonadIO m
+peerEnvSetProbe :: (MonadIO m) => PeerEnv e -> AnyProbe -> m ()
+peerEnvSetProbe PeerEnv {..} p = liftIO $ atomically $ writeTVar _envProbe p
+
+-- peerEnvAddProbe :: (MonadIO m) => PeerEnv e -> AnyProbe -> m ()
+-- peerEnvAddProbe PeerEnv {..} p = liftIO $ atomically $ modifyTVar _envProbe p
+
+
+peerEnvCollectProbes :: (MonadIO m) => PeerEnv e -> m ()
+peerEnvCollectProbes PeerEnv {..} = do
+  probe <- liftIO $ readTVarIO _envProbe
+  acceptReport probe =<< CPS.execWriterT do
+    -- _envDeferred :: Pipeline IO ()
+
+    item "sessions" =<< (liftIO . Cache.size) _envSessions
+
+    events <- liftReadTVar _envEvents
+    item "events-keys" $ HashMap.size events
+    item "events-values-all" $ calcValuesLengthTotal events
+
+    item "expire-times" =<< (liftIO . Cache.size) _envExpireTimes
+
+    sweepers <- liftReadTVar _envSweepers
+    item "sweepers-keys" $ HashMap.size sweepers
+    item "sweepers-values-all" $ calcValuesLengthTotal sweepers
+
+    item "req-msg-limit" =<< (liftIO . Cache.size) _envReqMsgLimit
+    item "req-proto-limit" =<< (liftIO . Cache.size) _envReqProtoLimit
+
+    item "data-sent" =<< (liftIO . readTVarIO) _envSentCounter
+    item "data-recv" =<< (liftIO . readTVarIO) _envRecvCounter
+
+  where
+    calcValuesLengthTotal = Monoid.getSum . foldMap (Monoid.Sum . L.length)
+    liftReadTVar = liftIO . readTVarIO
+    item k v = CPS.tell [(k, fromIntegral v)]
+
+runPeerM :: forall e m . ( MonadUnliftIO m
                          , HasPeer e
                          , Ord (Peer e)
                          , Pretty (Peer e)
+                         , Hashable (Encoded e)
                          , HasNonces () m
                          )
          => PeerEnv e
          -> PeerM e m ()
          -> m ()
 
-runPeerM env f  = do
+runPeerM env@PeerEnv{..} f  = flip runContT pure do
 
-  let de = view envDeferred env
-  as <- liftIO $ replicateM 16 $ async $ runPipeline de
+  n <- liftIO getNumCapabilities <&> max 2 . div 2
+
+  as <- liftIO $ replicateM n $ asyncLinked $ runPipeline _envDeferred
 
   sw <- liftIO $ async $ forever $ withPeerM env $ do
       pause defSweepTimeout
-          se <- asks (view envSessions)
-          liftIO $ Cache.purgeExpired se
+
+      liftIO do
+        Cache.purgeExpired _envSessions
+        Cache.purgeExpired _envReqMsgLimit
+        Cache.purgeExpired _envReqProtoLimit
+
       sweep
 
-  void $ runReaderT (fromPeerM f) env
-  void $ liftIO $ stopPipeline de
+  void $ ContT $ bracket none $ const $ do
+    void $ liftIO $ stopPipeline _envDeferred
     liftIO $ mapM_ cancel (as <> [sw])
+    pure ()
+
+  lift $ void $ runReaderT (fromPeerM f) env
+
 
 withPeerM :: MonadIO m => PeerEnv e -> PeerM e m a -> m a
 withPeerM env action = runReaderT (fromPeerM action) env
@@ -431,7 +490,7 @@ runProto :: forall e m  . ( MonadIO m
 
 runProto hh = do
   me       <- ownPeer @e @m
-  pipe     <- getFabriq @e
+  pipf     <- getFabriq @e
 
   let resp = [ (pid, a) | a@AnyProtocol { myProtoId = pid } <- hh ]
 
@@ -439,7 +498,7 @@ runProto hh = do
 
   forever $ do
 
-    messages <- receive @_ @e pipe (To me)
+    messages <- receive @_ @e pipf (To me)
 
     for_ messages $ \(From pip, AnyMessage n msg :: AnyMessage (Encoded e) e) -> do
 
@@ -453,6 +512,7 @@ runProto hh = do
                           }) -> maybe (pure ()) (runResponseM pip . h) (decoder msg)
 
 
+
 instance (Monad m, HasProtocol e p) => HasThatPeer p e (ResponseM e m) where
   thatPeer = asks (view answTo)
 
@@ -480,7 +540,9 @@ instance ( HasProtocol e p
     who <-  thatPeer @p
     self <- lift $ ownPeer @e
     fab  <- lift $ getFabriq @e
-    sendTo fab (To who) (From self) (AnyMessage @(Encoded e) @e proto (encode msg))
+    let raw = encode msg
+    -- atomically $ modifyTVar
+    sendTo fab (To who) (From self) (AnyMessage @(Encoded e) @e proto raw)
 
 instance ( MonadIO m
          -- , HasProtocol e p

hbs2-core/lib/HBS2/Actors/Peer/Types.hs

@@ -2,15 +2,10 @@
 module HBS2.Actors.Peer.Types where
 
 import HBS2.Prelude
-import HBS2.Storage
 import HBS2.Net.Proto.Types
 import HBS2.Net.Messaging
-import HBS2.Hash
 
 import Control.Monad.Trans.Class
-import Data.ByteString.Lazy (ByteString)
-import Control.Monad
-import Codec.Serialise
 
 class HasProtocol e p => HasTimeLimits e p m where
   tryLockForPeriod :: Peer e -> p -> m Bool
@@ -24,7 +19,16 @@ instance {-# OVERLAPPABLE #-}
 
 -- instance HasConf m => HasConf (ResponseM e m)
 
+data PeerCounters =
+  PeerStats
+  { peerDataSent :: Int
+  , peerDataRecv :: Int
+  }
 
+class HasPeerCounters m where
+  getPeerCounters   :: m PeerCounters
+  setPeerCounters   :: PeerCounters -> m ()
+  updatePeerCountes :: (PeerCounters -> PeerCounters) -> m ()
 
 class (Monad m, HasProtocol e p) => HasGossip e p m where
   gossip :: p -> m ()

hbs2-core/lib/HBS2/Base58.hs

@@ -4,10 +4,8 @@ import Data.ByteString.Base58 (encodeBase58, bitcoinAlphabet, decodeBase58,Alpha
 import Data.ByteString  qualified as BS
 import Data.ByteString.Char8 qualified as BS8
 import Data.ByteString.Char8 (ByteString)
-import Data.ByteString.Lazy.Char8 qualified as LBS8
 import Data.ByteString.Lazy qualified as LBS
 import Data.Word
-import Data.Char (ord)
 import Numeric
 
 import Prettyprinter
@@ -41,6 +39,9 @@ instance Pretty (AsBase58 LBS.ByteString) where
 instance Show (AsBase58 ByteString) where
   show (AsBase58 bs) = BS8.unpack $ toBase58 bs
 
+instance Show (AsBase58 LBS.ByteString) where
+  show (AsBase58 bs) = BS8.unpack . toBase58 . LBS.toStrict $ bs
+
 
 byteToHex :: Word8 -> String
 byteToHex byte = pad $ showHex byte ""

hbs2-core/lib/HBS2/Clock.hs

@@ -1,8 +1,9 @@
 {-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 module HBS2.Clock
   ( module HBS2.Clock
   , module System.Clock
-  , POSIXTime, getPOSIXTime, getEpoch
+  , POSIXTime, getPOSIXTime, NominalDiffTime
   )where
 
 import Data.Functor
@@ -14,7 +15,6 @@ import Data.Proxy
 import Data.Time
 import Prettyprinter
 import System.Clock
-import Data.Time.Clock
 import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
 import Data.Word
 
@@ -50,7 +50,7 @@ instance IsTimeout t => Expired (Timeout t) TimeSpec where
 -- expired timeout ts = False
 
 toNominalDiffTime :: IsTimeout t => Timeout t -> NominalDiffTime
-toNominalDiffTime = fromRational . (/ (10^6)) . fromIntegral . toMicroSeconds
+toNominalDiffTime = fromRational . (/ (10^(6 :: Integer))) . fromIntegral . toMicroSeconds
 
 class IsTimeout a => MonadPause a m where
   pause :: Timeout a -> m ()
@@ -97,7 +97,7 @@ instance IsTimeout 'Minutes where
   toNanoSeconds (TimeoutMin x) = round (x * 60 * 1e9)
 
 instance IsTimeout 'NomDiffTime where
-  toNanoSeconds (TimeoutNDT t) = round (realToFrac (nominalDiffTimeToSeconds t) * 1e9)
+  toNanoSeconds (TimeoutNDT t) = round (realToFrac (nominalDiffTimeToSeconds t) * (1e9 :: Double))
 
 instance IsTimeout 'TS where
   toNanoSeconds (TimeoutTS s) = fromIntegral $ toNanoSecs s
@@ -108,6 +108,9 @@ class Expires a where
   -- FIXME: dangerous!
   expiresIn _ = Nothing
 
+timeSpecDeltaSeconds :: RealFrac a => TimeSpec -> TimeSpec -> a
+timeSpecDeltaSeconds a b = realToFrac . (*1e-9) . realToFrac $ toNanoSecs (max a b - min a b)
+
 getEpoch :: MonadIO m => m Word64
 getEpoch = liftIO getPOSIXTime <&> floor
 

hbs2-core/lib/HBS2/Data/Bundle.hs

@@ -26,8 +26,8 @@ import Streaming()
 
 {- HLINT ignore "Use newtype instead of data" -}
 
-data BundleRefValue e =
-  BundleRefValue (SignedBox BundleRef e)
+data BundleRefValue s =
+  BundleRefValue (SignedBox BundleRef s)
   deriving stock (Generic)
 
 instance ForSignedBox e => Serialise (BundleRefValue e)
@@ -39,13 +39,13 @@ data BundleRef =
 instance Serialise BundleRef
 
 
-makeBundleRefValue :: forall e . (ForSignedBox e, Signatures (Encryption e))
-                   => PubKey 'Sign (Encryption e)
-                   -> PrivKey 'Sign (Encryption e)
+makeBundleRefValue :: forall s . (ForSignedBox s, Signatures s)
+                   => PubKey 'Sign s
+                   -> PrivKey 'Sign s
                    -> BundleRef
-                   -> BundleRefValue e
+                   -> BundleRefValue s
 
-makeBundleRefValue pk sk ref = BundleRefValue $ makeSignedBox @e pk sk ref
+makeBundleRefValue pk sk ref = BundleRefValue $ makeSignedBox @s pk sk ref
 
 -- у нас может быть много способов хранить данные:
 --   сжимать целиком (эффективно, но медленно)
@@ -178,7 +178,7 @@ instance MonadIO m => ImportBundle HashRef m where
       go hd bs
         | LBS.null bs = pure $ Right ()
         | otherwise = do
-            let ss = bundleHeadSectionSize hd
+            let _ss = bundleHeadSectionSize hd
             let (bsh, allBsRest) = LBS.splitAt sectionHeadSize bs
             case deserialiseOrFail @BundleSection bsh of
               Left{} -> do

hbs2-core/lib/HBS2/Data/Detect.hs

@@ -1,30 +1,38 @@
-module HBS2.Data.Detect where
+module HBS2.Data.Detect
+  ( module HBS2.Data.Detect
+  , module HBS2.Merkle.Walk
+  , module HBS2.Merkle
+  )
+  where
 
 import HBS2.Prelude.Plated
 import HBS2.Hash
 import HBS2.Data.Types
 import HBS2.Merkle
+import HBS2.Merkle.Walk
 import HBS2.Storage
 
-import HBS2.System.Logger.Simple
+-- import HBS2.System.Logger.Simple
 
-import Data.Foldable (for_)
+-- import Data.Foldable (for_)
 import Control.Monad.Trans.Maybe
 import Codec.Serialise (deserialiseOrFail)
 import Data.ByteString.Lazy (ByteString)
 import Data.ByteString.Lazy qualified as LBS
 import Data.Either
-import Data.Function
-import Data.Functor
+-- import Data.Function
+-- import Data.Functor
 
+import Data.Coerce
 import Data.Maybe
 import Control.Concurrent.STM
 import Data.HashMap.Strict qualified as HashMap
-import Data.HashMap.Strict (HashMap)
+-- import Data.HashMap.Strict (HashMap)
 import Data.List qualified as List
+import UnliftIO qualified
 
 import Streaming.Prelude qualified as S
-import Streaming qualified as S
+-- import Streaming qualified as S
 
 data BlobType =  Merkle (MTree [HashRef])
                | MerkleAnn (MTreeAnn [HashRef])
@@ -46,6 +54,38 @@ tryDetect hash obj = rights [mbAnn, mbLink, mbMerkle, mbSeq] & headDef orBlob
 
 data ScanLevel = ScanShallow | ScanDeep
 
+extractBlockRefs :: Hash HbSync -> ByteString -> [HashRef]
+extractBlockRefs hx bs =
+  case tryDetect hx bs of
+   (SeqRef (SequentialRef _ (AnnotatedHashRef a' b))) ->
+    coerce <$> catMaybes [a', Just b]
+
+   AnnRef (AnnotatedHashRef ann h) -> do
+    coerce <$> catMaybes [ann, Just h]
+
+   Merkle (MNode _ hs) -> fmap HashRef hs
+
+   MerkleAnn (MTreeAnn{..}) -> do
+
+     let meta = case _mtaMeta of
+                  AnnHashRef ha -> [ha]
+                  _ -> mempty
+
+     let c = case _mtaCrypt of
+               CryptAccessKeyNaClAsymm hs -> [hs]
+               EncryptGroupNaClSymm1 hs _ -> [hs]
+               EncryptGroupNaClSymm2 _ hs _ -> [hs]
+               _ -> mempty
+
+     let t = case _mtaTree of
+               MNode _ hs -> hs
+               _ -> mempty
+
+     fmap HashRef (meta <> c <> t)
+
+   _ -> mempty
+
+
 
 -- TODO: control-nesting-level-to-avoid-abuse
 
@@ -159,6 +199,15 @@ readLog getBlk (HashRef h)  =
         Left{} -> pure ()
         Right (hrr :: [HashRef]) -> S.each hrr
 
+readLogThrow :: forall m . ( MonadIO m )
+        => ( Hash HbSync -> IO (Maybe ByteString) )
+        -> HashRef
+        -> m [HashRef]
+readLogThrow getBlk (HashRef h)  =
+  S.toList_ do
+      either UnliftIO.throwIO pure =<<
+          streamMerkle (liftIO . getBlk) h
+
 
 -- FIXME: make-it-stop-after-first-missed-block
 checkComplete :: forall sto m . (MonadIO m, Storage sto HbSync ByteString IO)

hbs2-core/lib/HBS2/Data/KeyRing.hs

@@ -9,7 +9,6 @@ import System.FilePath
 import System.Directory
 import Data.List as L
 import Data.Maybe
-import Data.ByteString.Lazy qualified as LBS
 import Data.ByteString qualified as BS
 import Lens.Micro.Platform
 import UnliftIO
@@ -23,7 +22,7 @@ splitPattern fp = (pref, flt)
     pref = joinPath pref'
     flt = case flt' of
       [] -> "*"
-      xs -> joinPath flt'
+      _xs -> joinPath flt'
     (pref', flt') = L.span isNotP (splitDirectories fp)
     isNotP s = isNothing (find isP s)
     isP c = c `elem` ("?*" :: [Char])

hbs2-core/lib/HBS2/Data/Types.hs

@@ -2,7 +2,6 @@ module HBS2.Data.Types
   ( module X
   -- , module HBS2.Data.Types.Crypto
   , AsSyntax(..)
-  , LoadedRef(..)
   )
   where
 

hbs2-core/lib/HBS2/Data/Types/EncryptedBox.hs

@@ -8,7 +8,7 @@ import Data.ByteString (ByteString)
 -- TODO: encryption-type-into-tags
 -- FIXME: show-scrambled?
 newtype EncryptedBox t = EncryptedBox { unEncryptedBox :: ByteString }
-  deriving stock (Generic,Show,Data)
+  deriving stock (Eq,Generic,Show,Data)
 
 instance Serialise (EncryptedBox t)
 

hbs2-core/lib/HBS2/Data/Types/Peer.hs

@@ -1,14 +1,12 @@
 {-# Language UndecidableInstances #-}
 module HBS2.Data.Types.Peer where
 
-import Codec.Serialise
 import Data.ByteString qualified as BS
 import Data.Hashable
 import Lens.Micro.Platform
 
 import HBS2.Prelude
 import HBS2.Net.Auth.Credentials
-import HBS2.Net.Proto.Types
 
 
 type PingSign e = Signature (Encryption e)