[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[gnunet-scheme] branch master updated (6c136b9 -> 5c7bf08)
|
From: |
gnunet |
|
Subject: |
[gnunet-scheme] branch master updated (6c136b9 -> 5c7bf08) |
|
Date: |
Sat, 25 Dec 2021 22:59:37 +0100 |
This is an automated email from the git hooks/post-receive script.
maxime-devos pushed a change to branch master
in repository gnunet-scheme.
from 6c136b9 NEWS: Document NSE bug fix regarding NaN as standard
deviation.
new 8df726c Rename messge type 156.
new c53f0c9 bv-slice: Support signed integers.
new f576342 netstruct/procedural: Support signed integers.
new 3e989df dht/struct: New module.
new b18725c Define block types.
new ed18068 dht/client: Implement message verifiers.
new f379451 dht/client: Implement reconnecting.
new 4d6af80 examples: Consider extending the web interface with other
services.
new 6a5c592 examples/web: Connect to the DHT service.
new a86a0cf dht/client: Register new get operations for processing.
new 299ad57 config: Define default UNIXPATH for DHT service.
new 7279d5d dht/client: Send messages for new get operations.
new 008e48e dht/client: Send PUT messages.
new 0ada42b Merge branch 'master' into dht
new df3a2ec Update copyright notices
new 05a86d1 Merge branch 'master' into dht
new 23c3bd4 dht/struct: Fix typo in synopsis.
new e11cdb4 dht/client: Correct struct access when verifying messages.
new 6b1ee34 dht/client: Recognise client result messages.
new 891e3ea dht/client: Call the callback on the client result.
new f5d5053 examples/web: Respond with HTML.
new f66adf0 examples/web: Make a non-functional web form for searching
the DHT.
new ef6d626 examles/web: Add a non-functional form for DHT insertions.
new 1abaf10 examples/web: Put different information on separate pages.
new 2e0d472 web/form: New module.
new 4487ea1 examples/web.scm: Parse the answer to the DHT insertion form.
new a3dd8ce examples/web: Process DHT insertion forms.
new 716a580 dht/client: Copy the key into the put message.
new bafe48e guix: Add guile-gcrypt.
new 64a9aed doc: Remove URLs.
new 7e61e4b doc: Document dependency on Guile-Gcrypt.
new 56eaffa crypto: Implement a wrapper for hashing with bytevector
slices.
new 15918dd examples/web: Hash free-form text first.
new d68778f crypto: Implement functional variants.
new fa0ded4 examples/web: Allow module reloading.
new 3430d19 examples/web: License as AGPL.
new 8fee893 examples/web: Correct destination of search form.
new 128a976 examples/web: Implement searching form.
new a2345b0 examples/web: Dissect search result.
new e127bf6 examples/web: Don't hash the data.
new 316558b dht/client: Impose some bounds on the replication level.
new e6d9e0a dht/client: Resolve race condition.
new 89e65eb examples/web: Display UTF-8 keys and data as text.
new 8dbb40a guix: Skip tests in guile package.
new 204d4b2 guix: Skip tests in guile-fibers/patched.
new 26ac940 Merge branch 'dht'.
new 75d5781 web: Extract HTTP implementation from Cuirass.
new 0d94808 examples/web (search-dht): Fail gracefully in case of invalid
input
new 5c7bf08 crypto: Fix type confusion in hash-slice [bugfix]
The 49 revisions listed above as "new" are entirely new to this
repository and will be described in separate emails. The revisions
listed as "add" were already present in the repository and have only
been added to this reference.
Summary of changes:
Makefile.am | 16 +-
ROADMAP.org | 2 +-
doc/scheme-gnunet.tm | 37 +--
examples/nse-web.scm | 45 ----
examples/web.scm | 252 ++++++++++++++++++++
gnu/gnunet/block.scm | 139 +++++++++++
gnu/gnunet/config/default.conf | 2 +
gnu/gnunet/crypto.scm | 69 ++++++
gnu/gnunet/dht/client.scm | 458 ++++++++++++++++++++++++++++++++++++
gnu/gnunet/dht/struct.scm | 214 +++++++++++++++++
gnu/gnunet/message/enum-dht.scmfrag | 2 +-
gnu/gnunet/netstruct/procedural.scm | 40 +++-
gnu/gnunet/utils/bv-slice.scm | 31 ++-
guix.scm | 16 +-
tests/bv-slice.scm | 50 ++++
tests/crypto.scm | 89 +++++++
tests/distributed-hash-table.scm | 76 ++++++
tests/form.scm | 93 ++++++++
web/form.scm | 118 ++++++++++
web/server/fiberized.scm | 216 +++++++++++++++++
20 files changed, 1886 insertions(+), 79 deletions(-)
delete mode 100644 examples/nse-web.scm
create mode 100644 examples/web.scm
create mode 100644 gnu/gnunet/block.scm
create mode 100644 gnu/gnunet/crypto.scm
create mode 100644 gnu/gnunet/dht/client.scm
create mode 100644 gnu/gnunet/dht/struct.scm
create mode 100644 tests/crypto.scm
create mode 100644 tests/distributed-hash-table.scm
create mode 100644 tests/form.scm
create mode 100644 web/form.scm
create mode 100644 web/server/fiberized.scm
diff --git a/Makefile.am b/Makefile.am
index a82f3f1..a400c10 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -29,6 +29,8 @@ SUFFIXES = .scm .go
# Scheme code that works
modules = \
+ web/form.scm \
+ \
gnu/extractor/enum.scm \
\
gnu/gnunet/scripts/download-store.scm \
@@ -55,18 +57,25 @@ modules = \
gnu/gnunet/utils/platform-enum.scm \
gnu/gnunet/utils/tokeniser.scm \
\
+ gnu/gnunet/block.scm \
+ \
gnu/gnunet/config/parser.scm \
gnu/gnunet/config/value-parser.scm \
gnu/gnunet/config/expand.scm \
gnu/gnunet/config/db.scm \
gnu/gnunet/config/fs.scm \
\
+ gnu/gnunet/crypto.scm \
+ gnu/gnunet/crypto/struct.scm \
+ \
+ gnu/gnunet/dht/client.scm \
+ gnu/gnunet/dht/struct.scm \
+ \
gnu/gnunet/util/cmsg.scm \
gnu/gnunet/util/time.scm \
gnu/gnunet/icmp/struct.scm \
\
gnu/gnunet/util/struct.scm \
- gnu/gnunet/crypto/struct.scm \
gnu/gnunet/hashcode/struct.scm \
\
gnu/gnunet/nse/client.scm \
@@ -168,6 +177,9 @@ SCM_TESTS = \
tests/config-expand.scm \
tests/config-db.scm \
tests/config-fs.scm \
+ tests/crypto.scm \
+ tests/distributed-hash-table.scm \
+ tests/form.scm \
tests/netstruct.scm \
tests/time.scm \
tests/tokeniser.scm
@@ -200,7 +212,7 @@ doc/scheme-gnunet.html: doc/scheme-gnunet.tm
$(TEXMACS_CONVERT) -x $(TEXMACS_HTML_SETTINGS) -c "$<" "$@" -q
dist_doc_DATA = doc/scheme-gnunet.tm doc/fdl.tm
-nobase_dist_doc_DATA = examples/nse-web.scm
+nobase_dist_doc_DATA = examples/web.scm
nodist_html_DATA = doc/scheme-gnunet.html
nodist_pdf_DATA = doc/scheme-gnunet.pdf
diff --git a/ROADMAP.org b/ROADMAP.org
index 3d7b089..a62eff9 100644
--- a/ROADMAP.org
+++ b/ROADMAP.org
@@ -12,7 +12,7 @@
** DONE NSE client
See examples/nse-web.scm
*** TODO A GUI (use guile-gnome)
- I made a web interface instead. (examples/nse-web.scm)
+ I made a web interface instead. (examples/web.scm)
*** DONE Load configuration from a file
** DONE Documentation [6/6]
*** DONE Concurrency basics
diff --git a/doc/scheme-gnunet.tm b/doc/scheme-gnunet.tm
index e504622..f388f79 100644
--- a/doc/scheme-gnunet.tm
+++ b/doc/scheme-gnunet.tm
@@ -208,21 +208,8 @@
<item><hlink|(Guile) Fibers|https://github.com/wingo/fibers/>
<item><hlink|Guile-QuickCheck|https://ngyro.com/software/guile-quickcheck.html>
- </itemize>
-
- For the benefit of dead tree readers, the invisible hyperlinks above are
- reproduced as visible URLs below.
-
- <\itemize>
- <item><slink|https://www.gnu.org/software/autoconf/>
- <item><slink|https://www.gnu.org/software/guile/>
-
- <item><slink|https://github.com/ijp/pfds/>
-
- <item><slink|https://github.com/wingo/fibers/>
-
- <item><slink|https://ngyro.com/software/guile-quickcheck.html>
+ <item><hlink|Guile-Gcrypt|https://notabug.org/cwebber/guile-gcrypt>
</itemize>
A few patches to guile and guile-fibers are required (some bug fixes, some
@@ -340,7 +327,7 @@
<chapter|Application guide>
Scheme-GNUnet doesn't have any example applications, except the half-baked
- <verbatim|examples/nse-web.scm>,
<verbatim|gnu/gnunet/scripts/download-store.scm>
+ <verbatim|examples/web.scm>, <verbatim|gnu/gnunet/scripts/download-store.scm>
and <verbatim|gnu/gnunet/scripts/publish-store.scm>.<space|1em>Over time,
we hope we have something to write here, but for now, this chapter is
empty.
@@ -1062,6 +1049,26 @@
<scm|estimate:standard-deviation> can be used to put probablistic error
bounds on the number of peers on the network. <todo|example>
+ <section|Cryptography>
+
+ The module <scm|(gnu gnunet crypto)> has a few small wrappers around
+ procedures from Guile-Gcrypt for performing cryptography on bytevector
+ slices.
+
+ <\explain>
+ <scm|(hash/sha512! <var|slice> <var|to>)>
+ </explain|Compute the SHA-512 hash of <var|slice>, a readable bytevector
+ slice of arbitrary length, and write it to <var|to>, a writable bytevector
+ slice of length 512 bits / 64 bytes.<space|1em>The result is unspecified if
+ <var|slice> and <var|to> overlap.>
+
+ <\explain>
+ <scm|(hash/sha512 <var|slice>)>
+ <|explain>
+ Like <scm|hash/sha512!>, but allocate the <var|>destination slice
+ <var|to> and return it.
+ </explain>
+
<chapter|Implementation details>
TODO<appendix|GNU Free Documentation License>
diff --git a/examples/nse-web.scm b/examples/nse-web.scm
deleted file mode 100644
index 2f6f9dc..0000000
--- a/examples/nse-web.scm
+++ /dev/null
@@ -1,45 +0,0 @@
-;; Copyright (C) 2021 GNUnet e.V.
-;; SPDX-License-Identifier: FSFAP
-;; Copying and distribution of this file, with or without modification,
-;; are permitted in any medium without royalty provided the copyright
-;; notice and this notice are preserved. This file is offered as-is,
-;; without any warranty.
-
-(use-modules (fibers)
- (gnu gnunet config db)
- (gnu gnunet config fs)
- (rnrs hashtables)
- (gnu gnunet nse client)
- (web server)
- (srfi srfi-11))
-
-(define config (load-configuration))
-
-(define (url-handler server request body)
- (define current-estimate (estimate server))
- (define body
- (if current-estimate
- (format #f "timestamp: ~a~%number peers: ~a~%stddev logarithm: ~a"
- (estimate:timestamp current-estimate)
- (estimate:number-peers current-estimate)
- (estimate:standard-deviation current-estimate))
- "no estimate available yet ..."))
- (values '((content-type text/plain)) body #f))
-
-(define (start config)
- (define nse-server (connect config))
- (define impl (lookup-server-impl 'fiberized))
- (define server (open-server impl `(#:port 8089)))
- (define (url-handler* request body)
- (url-handler nse-server request body))
- (let loop ()
- (let-values (((client request body)
- (read-client impl server)))
- (spawn-fiber
- (lambda ()
- (let-values (((response body state)
- (handle-request url-handler* request body '())))
- (write-client impl server client response body)))))
- (loop)))
-
-(run-fibers (lambda () (start config)))
diff --git a/examples/web.scm b/examples/web.scm
new file mode 100644
index 0000000..2564dc4
--- /dev/null
+++ b/examples/web.scm
@@ -0,0 +1,252 @@
+;; This file is part of scheme-GNUnet.
+;; Copyright (C) 2021 GNUnet e.V.
+;;
+;; scheme-GNUnet is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU Affero General Public License as published
+;; by the Free Software Foundation, either version 3 of the License,
+;; or (at your option) any later version.
+;;
+;; scheme-GNUnet is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Affero General Public License for more details.
+;;
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+;;
+;; SPDX-License-Identifier: AGPL-3.0-or-later
+
+;; Go to localhost:8089/reload to reload the module
+(define-module (guile-user)
+ #:declarative? #f)
+
+(use-modules (fibers)
+ (fibers conditions)
+ (rnrs bytevectors)
+ (gnu extractor enum)
+ (gnu gnunet block)
+ (gnu gnunet crypto)
+ (gnu gnunet utils bv-slice)
+ (gnu gnunet config db)
+ (gnu gnunet config fs)
+ (rnrs hashtables)
+ ((gnu gnunet nse client)
+ #:prefix #{nse:}#)
+ ((gnu gnunet dht client)
+ #:prefix #{dht:}#)
+ (web response)
+ (web server)
+ (web uri)
+ (web request)
+ (web form)
+ (srfi srfi-11)
+ (ice-9 match)
+ (sxml simple))
+
+(define config (load-configuration))
+
+(define* (respond/html body #:key (status-code 200))
+ "@var{status-code}: the HTTP status code to return. By default, the status
code
+for success is used."
+ (values (build-response
+ #:code status-code
+ #:headers `((content-type application/xhtml+xml) (charset .
"utf-8")))
+ (lambda (port)
+ (display "<!DOCTYPE html>\n" port)
+ (sxml->xml `(html (@ (xmlns "http://www.w3.org/1999/xhtml";))
+ (head (title "Hello"))
+ (body ,body))
+ port))))
+
+;; TODO: make the form work, defaults, ...
+
+(define (data-encoding-input name id)
+ `(select
+ (@ (name ,name) (id ,id))
+ (option (@ (value "utf-8-text")) "free-form text encoded as UTF-8")
+ (option (@ (value "hexadecimal")) "binary data encoded in hexadecimal")))
+
+(define (common-get/put-form-parts %prefix)
+ (define (prefix id) ; ids must be unique within a document
+ (string-append %prefix id))
+ `((li (label (@ (for "type")) "Type: ")
+ (input (@ (type "number") (id "type") (name "type"))))
+ (li (label (@ (for "replication-level")) "Replication level: ")
+ (input (@ (type "number") (id ,(prefix "replication-level"))
+ (name "replication-level"))))
+ (li (label (@ (for "key-encoding")) "Key encoding: ")
+ ,(data-encoding-input "key-encoding" (prefix "key-encoding")))
+ (li (label (@ (for "key")) "Key: ")
+ (input (@ (type "text") (id ,(prefix "key")) (name "key"))))))
+
+(define search-form
+ `(form
+ (@ (action "/search-dht") (method "post")) ; TODO should be "get"
+ (ul ,@(common-get/put-form-parts "get-"))
+ (input (@ (type "submit") (value "Search the DHT")))))
+
+;; TODO: make the form work, defaults, ...
+(define put-form
+ `(form
+ (@ (action "/put-dht") (method "post"))
+ (ul ,@(common-get/put-form-parts "put-")
+ (li (label (@ (for "put-data-encoding")) "Encoding of data: ")
+ ,(data-encoding-input "data-encoding" "put-data-encoding"))
+ (li (label (@ (for "put-data")) "Data to insert: ")
+ (input (@ (type "text") (id "put-data") (name "data")))))
+ (input (@ (type "submit") (value "Put it into the DHT")))))
+
+(define (estimate->html estimate)
+ `(dl (dt "Timestamp")
+ (dd ,(number->string (nse:estimate:timestamp estimate)))
+ (dt "Number of peers")
+ (dd ,(number->string (nse:estimate:number-peers estimate)))
+ (dt "Standard deviation")
+ (dd ,(number->string (nse:estimate:standard-deviation estimate)))))
+
+(define (decode/key encoding data)
+ (match encoding
+ ("utf-8-text"
+ (hash/sha512 (bv-slice/read-write (string->utf8 data))))
+ ;; TODO other encodings
+ ))
+
+(define (decode/data encoding data)
+ (match encoding
+ ("utf-8-text"
+ (bv-slice/read-write (string->utf8 data))
+ ;; TODO other encodings
+ )))
+
+(define (process-put-dht dht-server parameters)
+ ;; TODO replication level, expiration ...
+ (dht:put! dht-server
+ (string->number (assoc-ref parameters "type"))
+ (decode/key (assoc-ref parameters "key-encoding")
+ ;; TODO the key is 00000.... according to
gnunet-dht-monitor
+ (assoc-ref parameters "key"))
+ (decode/data (assoc-ref parameters "data-encoding")
+ (assoc-ref parameters "data"))))
+
+(define (try-utf8->string bv) ; TODO: less duplication
+ (catch 'decoding-error
+ (lambda () (utf8->string bv))
+ (lambda _ #false)))
+
+(define (data->string slice)
+ (define bv (make-bytevector (slice-length slice)))
+ (slice-copy! slice (bv-slice/read-write bv))
+ (define as-string (try-utf8->string bv))
+ (or as-string (object->string bv)))
+
+(define (process-search-dht dht-server parameters)
+ (define what)
+ (define found? (make-condition))
+ (define (found type key data expiration get-path put-path)
+ (set! what (list type
+ (slice-copy key)
+ (slice-copy data)
+ expiration
+ (slice-copy get-path)
+ (slice-copy put-path)))
+ (signal-condition! found?))
+ ;; Perform rudimentary input parameter validation (TODO: more validation).
+ (let* ((type (and=> (assoc-ref parameters "type") string->number))
+ (key-encoding (assoc-ref parameters "key-encoding"))
+ (key (assoc-ref parameters "key"))
+ (replication-level (assoc-ref parameters "key"))
+ (desired-replication-level
+ (and=> (assoc-ref parameters "replication-level") string->number)))
+ (if (and type key-encoding key replication-level desired-replication-level)
+ (begin
+ (dht:start-get! dht-server type
+ (decode/key key-encoding key)
+ found
+ #:desired-replication-level
+ desired-replication-level)
+ (wait found?)
+ ;; TODO: properly format the result, streaming, stop searching
+ ;; after something has been found or if the client closes the
connection ...
+ (respond/html `(div (p "Found! ")
+ ;; TODO: better output, determine why the data is
bogus
+ (dl ,@(match what
+ ((type key data expiration get-path
put-path)
+ `((dt "Type: ")
+ (dd ,type)
+ (dt "Key: ")
+ (dd ,(data->string key))
+ (dt "Data: ")
+ (dd ,(data->string data))
+ (dt "Expiration: ")
+ (dd ,(object->string expiration))
+ (dt "Get path: ") ; TODO as list
+ (dd ,(object->string get-path))
+ (dt "Put path: ")
+ (dd ,(object->string put-path)))))))))
+ (respond/html `(p "Some fields were missing / invalid")
+ #:status-code 400))))
+
+(define-once started? #f)
+
+(define (slice-copy slice) ; TODO: move to (gnu gnunet utils bv-slice), use
elsewhere?
+ (define s (make-slice/read-write (slice-length slice)))
+ (slice-copy! slice s)
+ s)
+
+(define (url-handler dht-server server request body)
+ (match (uri-path (request-uri request))
+ ("/" (respond/html
+ `(div (p "A few links")
+ (ul (li (a (@ (href "/network-size")) "network size"))
+ (li (a (@ (href "/search-dht")) "search the DHT")
+ (li (a (@ (href "/put-dht")) "add things to the
DHT")))))))
+ ("/reload" ; TODO form with PUT request?
+ (reload-module (current-module))
+ (respond/html "reloaded!"))
+ ("/network-size"
+ (respond/html
+ (let ((current-estimate (nse:estimate server)))
+ (if current-estimate
+ (estimate->html current-estimate)
+ '(p "No etimate yet")))))
+ ("/search-dht" ; TODO check method and Content-Type, validation ...
+ (if (pk 'b body)
+ (process-search-dht dht-server (urlencoded->alist body))
+ (respond/html search-form)))
+ ("/put-dht" ; TODO check method and Content-Type, validation ...
+ (if body
+ (begin
+ (process-put-dht dht-server (urlencoded->alist body))
+ (respond/html '(p "Success!")))
+ (respond/html put-form)))
+ (_ (respond/html '(p "not found"))))) ; TODO 404
+
+(define (start config)
+ (define nse-server (nse:connect config))
+ (define dht-server (dht:connect config))
+ (define impl (lookup-server-impl 'fiberized))
+ (define server (open-server impl `(#:port 8089)))
+ (define (url-handler* request body)
+ (url-handler dht-server nse-server request body))
+ ;; TODO: Form to start GET and PUT requests?
+ ;; For now, hard code the data to insert.
+ (dht:put! dht-server
+ (symbol-value block-type block:test)
+ (bv-slice/read-write (make-bytevector 64))
+ (bv-slice/read-write #vu8(#xde #xad #xbe #xef)))
+ (dht:start-get! dht-server
+ (symbol-value block-type block:test)
+ (bv-slice/read-write (make-bytevector 64)) pk)
+ (let loop ()
+ (let-values (((client request body)
+ (read-client impl server)))
+ (spawn-fiber
+ (lambda ()
+ (let-values (((response body state)
+ (handle-request url-handler* request body '())))
+ (write-client impl server client response body)))))
+ (loop)))
+
+(when (not started?)
+ (set! started? #t)
+ (run-fibers (lambda () (start config))))
diff --git a/gnu/gnunet/block.scm b/gnu/gnunet/block.scm
new file mode 100644
index 0000000..7374cd2
--- /dev/null
+++ b/gnu/gnunet/block.scm
@@ -0,0 +1,139 @@
+;; This file is part of GNUnet.
+;; Copyright (C) 2010, 2021 GNUnet e.V.
+;;
+;; GNUnet is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU Affero General Public License as published
+;; by the Free Software Foundation, either version 3 of the License,
+;; or (at your option) any later version.
+;;
+;; GNUnet is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Affero General Public License for more details.
+;;
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+;;
+;; SPDX-License-Identifier: AGPL-3.0-or-later
+
+;; Author: Christian Grothoff
+;; Adjusted for Scheme by Maxime Devos
+(define-library (gnu gnunet block)
+ (export block-type block-type?)
+ (import (only (rnrs base)
+ begin)
+ (only (gnu extractor enum)
+ define-enumeration value))
+ (begin
+ ;; Blocks in the datastore and the datacache must have a unique type.
+ ;; Corresponds to GNUNET_BLOCK_Type in the C implementation.
+ (define-enumeration (block-type block-type?)
+ (#:documentation "Types of blocks in the datastore and the datacache.")
+ (#:max (- (expt 2 32) 1))
+ (#:known
+ (value
+ (symbol block:any)
+ (index 0)
+ (documentation "Any type of block, used as a wildcard when searching.
+Should never be attached to a specific block."))
+ (value
+ (symbol block:fs:data)
+ (index 1)
+ (documentation "Data block (leaf) in the CHK tree"))
+ (value
+ (symbol block:fs:inner)
+ (index 2)
+ (documentation "Data block (leaf) in the CHK tree"))
+ (value
+ (symbol block:fs:k)
+ (index 3)
+ (documentation "Legacy type, no longer in use"))
+ (value
+ (symbol block:fs:s)
+ (index 4)
+ (documentation "Legacy type, no longer in use"))
+ (value
+ (symbol block:fs:n)
+ (index 5)
+ (documentation "Legacy type, no longer in use"))
+ (value
+ (symbol block:fs:on-demand)
+ (index 6)
+ (documentation "Type of a block representing a block to be encoded \
+on demand from disk.\nShould never appear on the network directly."))
+ (value
+ (symbol block:dht:hello)
+ (index 7)
+ (documentation "Type of a block that contains a HELLO for a peer (for \
+ DHT and CADET find-peer operations)"))
+ (value
+ (symbol block:test)
+ (index 8)
+ (documentation "Block for testing"))
+ (value
+ (symbol block:fs:universal)
+ (index 9)
+ (documentation "Type of a block representing any type of search result \
+(universal). Implemented in the context of #2564, replaces block:fs:s, \
+block:fs:k and block:fs:n"))
+ (value
+ (symbol block:dns)
+ (index 10)
+ (documentation "Block for storing DNS exit service advertisements"))
+ (value
+ (symbol block:gns:name-record)
+ (index 11)
+ (documentation "Block for storing record data"))
+ (value
+ (symbol block:revocation)
+ (index 12)
+ (documentation "Block type for a revocation message by which a key is \
+revoked"))
+ (value
+ (symbol block:filler:13)
+ (index 13))
+ (value
+ (symbol block:filler:14)
+ (index 14))
+ (value
+ (symbol block:filler:15)
+ (index 15))
+ (value
+ (symbol block:filler:16)
+ (index 16))
+ (value
+ (symbol block:filler:17)
+ (index 17))
+ (value
+ (symbol block:filler:18)
+ (index 18))
+ (value
+ (symbol block:filler:19)
+ (index 19))
+ (value
+ (symbol block:filler:20)
+ (index 20))
+ (value
+ (symbol block:filler:21)
+ (index 21))
+ (value
+ (symbol block:regex)
+ (index 22)
+ (documentation "Block to store a cadet regex state"))
+ (value
+ (symbol block:regex:accept)
+ (index 23)
+ (documentation "Block to store a cadet regex accepting state"))
+ (value
+ ;; GNUNET_BLOCK_TYPE_SET_TEST, GNUNET_BLOCK_TYPE_SETI_TEST,
+ ;; GNUNET_BLOCK_TYPE_SETU_TEST
+ (symbol block:filler:24)
+ (index 24)
+ (documentation
+ "Block for testing set/consensus. If first byte of the block \
+is non-zero, the block is considered invalid."))
+ (value
+ (symbol block:consensus-element)
+ (index 25)
+ (documentation "Block type for consensus elements.
+Contains either special marker elements or a nested block."))))))
diff --git a/gnu/gnunet/config/default.conf b/gnu/gnunet/config/default.conf
index 11cc463..9351a17 100644
--- a/gnu/gnunet/config/default.conf
+++ b/gnu/gnunet/config/default.conf
@@ -9,6 +9,8 @@
# For compatibility with C GNUnet, it is important that the default UNIXPATH,
# GNUNET_RUNTIME_DIR and GNUNET_USER_RUNTIME_DIR is the same.
+[dht]
+UNIXPATH = $GNUNET_RUNTIME_DIR/gnunet-service-dht.sock
[nse]
UNIXPATH = $GNUNET_RUNTIME_DIR/gnunet-service-nse.sock
diff --git a/gnu/gnunet/crypto.scm b/gnu/gnunet/crypto.scm
new file mode 100644
index 0000000..eb86c47
--- /dev/null
+++ b/gnu/gnunet/crypto.scm
@@ -0,0 +1,69 @@
+;; This file is part of GNUnet
+;; Copyright (C) 2021 GNUnet e.V.
+;;
+;; GNUnet is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU Affero General Public License as published
+;; by the Free Software Foundation, either version 3 of the License,
+;; or (at your option) any later version.
+;;
+;; GNUnet is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Affero General Public License for more details.
+;;
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+;;
+;; SPDX-License-Identifier: AGPL-3.0-or-later
+
+;; Small wrapper around guile-gcrypt
+(define-library (gnu gnunet crypto)
+ (export hash/sha512 hash/sha512!)
+ (import (only (gcrypt hash)
+ hash-algorithm open-hash-port sha512)
+ (gnu gnunet utils bv-slice)
+ (only (srfi srfi-8)
+ receive)
+ (only (guile)
+ %make-void-port close-port)
+ (only (ice-9 binary-ports)
+ put-bytevector)
+ (only (rnrs base)
+ begin lambda define))
+ (begin
+ ;; TODO: Extend bytevector-hash with offset + length.
+ (define (hash-slice/bytevector algorithm slice)
+ "Hash the data in the readable bytevector slice @var{slice} and
+return a bytevector with the resulting hash."
+ (define slice/read (slice/read-only slice))
+ (receive (port get-hash) (open-hash-port algorithm)
+ (put-bytevector port
+ (slice-bv slice/read)
+ (slice-offset slice/read)
+ (slice-length slice/read))
+ (close-port port)
+ (get-hash)))
+
+ (define (hash-slice! algorithm slice to)
+ "Hash the data in the readable bytevector slice @var{slice} and write the
+hash to the bytevector slice @var{to}."
+ (slice-copy! (bv-slice/read-write (hash-slice/bytevector algorithm
slice))
+ to))
+
+ (define (hash-slice algorithm slice)
+ "Hash the data in the readable bytevector slice @var{slice} and return a
+fresh readable bytevector slice with the hash."
+ (slice/read-only
+ (bv-slice/read-write (hash-slice/bytevector algorithm slice))))
+
+ (define (hasher! algorithm)
+ (lambda (slice to)
+ (hash-slice! algorithm slice to)))
+
+ (define (hasher algorithm)
+ (lambda (slice)
+ (hash-slice algorithm slice)))
+
+ ;; (hash/sha512! data-to-hash-slice destination-slice) --> (nothing)
+ (define hash/sha512! (hasher! (hash-algorithm sha512)))
+ (define hash/sha512 (hasher (hash-algorithm sha512)))))
diff --git a/gnu/gnunet/dht/client.scm b/gnu/gnunet/dht/client.scm
new file mode 100644
index 0000000..7055458
--- /dev/null
+++ b/gnu/gnunet/dht/client.scm
@@ -0,0 +1,458 @@
+;; This file is part of GNUnet
+;; Copyright (C) 2004-2013, 2016, 2021 GNUnet e.V.
+;;
+;; GNUnet is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU Affero General Public License as published
+;; by the Free Software Foundation, either version 3 of the License,
+;; or (at your option) any later version.
+;;
+;; GNUnet is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Affero General Public License for more details.
+;;
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+;;
+;; SPDX-License-Identifier: AGPL-3.0-or-later
+
+;; Author: Christian Grothoff
+;; Author: Nathan Evans
+;; ^^ TODO: not visible yet, but once more parts are ported ...
+;; Author: Maxime Devos (Scheme port)
+(define-library (gnu gnunet dht client)
+ (export %effective-minimum-replication-level
+ %effective-maximum-replication-level
+ %minimum-replication-level
+ %maximum-replication-level
+ bound-replication-level
+ connect
+ disconnect!
+ put!
+ cancel-put!
+ start-get!
+ filter-get:known-results!
+ stop-get!
+ ;; Extended API: monitor
+ start-monitor!
+ stop-monitor!)
+ (import (gnu extractor enum)
+ (gnu gnunet block)
+ (gnu gnunet concurrency repeated-condition)
+ (gnu gnunet hashcode struct)
+ (gnu gnunet mq)
+ (gnu gnunet mq handler)
+ (gnu gnunet mq-impl stream)
+ (gnu gnunet mq envelope)
+ (only (guile)
+ pk define-syntax-rule define* error
+ make-hash-table hashq-set! hashq-remove! hashv-set! hashv-ref
+ hash-map->list)
+ (only (ice-9 atomic)
+ make-atomic-box atomic-box-ref atomic-box-set!)
+ (only (gnu extractor enum)
+ symbol-value)
+ (only (fibers)
+ spawn-fiber)
+ (only (fibers conditions)
+ make-condition signal-condition! wait-operation)
+ (only (fibers operations)
+ perform-operation choice-operation)
+ (only (gnu gnunet mq error-reporting)
+ report-error)
+ (gnu gnunet dht struct)
+ (only (gnu gnunet crypto struct)
+ /peer-identity)
+ (only (gnu gnunet message protocols)
+ message-type)
+ (only (gnu gnunet netstruct syntactic)
+ read% sizeof set%! select)
+ (only (gnu gnunet utils bv-slice)
+ slice-length slice/read-only make-slice/read-write slice-copy!
+ slice-slice)
+ (only (rnrs base)
+ and >= = quote * + - define begin ... let*
+ quote case else values apply let cond if >
+ <= expt assert integer? lambda for-each
+ not expt min max)
+ (only (rnrs control)
+ unless when)
+ (only (rnrs records syntactic)
+ define-record-type))
+ (begin
+ ;; The minimal and maximal replication levels the DHT service allows.
+ ;; While the service won't reject replication levels outside this range,
+ ;; it will clip them to within this range, so choosing replication levels
+ ;; outside this range is useless.
+ ;;
+ ;; Also, GNUnet v0.15.3 and earlier has a bug where the DHT service can
crash
+ ;; if the replication level 0 is passed, see
https://bugs.gnunet.org/view.php?id=7029.
+ ;;
+ ;; These values are based on the MINIMUM_REPLICATION_LEVEL and
+ ;; MAXIMUM_REPLICATION_LEVEL values in
src/dht/gnunet-service-dht_neighbours.c
+ ;; of the C implementation.
+ (define %effective-minimum-replication-level 1)
+ (define %effective-maximum-replication-level 16)
+ (define %minimum-replication-level 0)
+ (define %maximum-replication-level (- (expt 2 32) 1))
+
+ ;; Called by 'send-get!'.
+ (define (bound-replication-level replication-level)
+ "Bound the replication level @var{replication-level}, which must be a
+valid replication to the level, to the range the DHT service likes."
+ (unless (<= %minimum-replication-level replication-level
+ %maximum-replication-level)
+ (error "replication level is out of bounds"))
+ ;; OOPS swap them
+ (max %effective-minimum-replication-level
+ (min %effective-maximum-replication-level replication-level)))
+
+ ;; New get or put operations are initially in new-get-operations or
+ ;; new-put-operation, and not in id->operation-map. They are moved
+ ;; in the background by 'process-new-get-operations' and
+ ;; 'process-new-put-operations'.
+ ;;
+ ;; Operations must be put in id->operation-map before sending them
+ ;; to the service!
+ (define-record-type (<server> %make-server server?)
+ (fields (immutable request-close?/box server-request-close?/box)
+ (immutable request-close-condition
+ server-request-close-condition)
+ ;; Hash table from new <get> to #true. These get operations
+ ;; are not yet sent to the services, and not yet queued for
+ ;; sending. Guile's hash tables are thread safe, so no locking
+ ;; is required.
+ (immutable new-get-operations server-new-get-operations)
+ ;; After adding new entries to 'new-get-operations', this
+ ;; ‘repeated condition’ is triggered to interrupt the fiber
+ ;; responsible for processing the new get operations.
+ (immutable new-get-operaton-trigger
+ server-new-get-operation-trigger)
+ ;; Hash table from new <put> to #true. These put operations
+ ;; are not yet sent to the service, and not yet queued for
+ ;; sending.
+ (immutable new-put-operations
+ server-new-put-operations)
+ (immutable new-put-operation-trigger
+ server-new-put-operation-trigger)
+ ;; Atomic box holding an unsigned 64-bit integer.
+ (immutable next-unique-id/box server-next-unique-id/box)
+ ;; Hash table from operation ids to their corresponding
+ ;; <get> object.
+ (immutable id->operation-map server-id->operation-map)))
+
+ (define-record-type (<get> %make-get get?)
+ (fields (immutable server get:server)
+ (immutable found get:iterator)
+ (immutable key get:key) ; bytevector slice (/hashcode:512)
+ (immutable unique-id get:unique-id)
+ (immutable desired-replication-level
+ get:desired-replication-level)
+ (immutable type get:type)
+ (immutable options get:options)))
+
+ (define-record-type (<put> %make-put put?)
+ (fields (immutable server put:server)
+ (immutable inserted put:inserted) ; thunk
+ ;; bytevector slice (/:msg:dht:client:put)
+ (immutable message put:message)))
+
+ (define (send-get! mq get)
+ "Send a GET message for @var{get}."
+ (pk 'new get)
+ (define s (make-slice/read-write (sizeof /:msg:dht:client:get '())))
+ (set%! /:msg:dht:client:get '(header size) s (slice-length s))
+ (set%! /:msg:dht:client:get '(header type) s
+ (value->index (symbol-value message-type msg:dht:client:get)))
+ (set%! /:msg:dht:client:get '(options) s (get:options get))
+ (set%! /:msg:dht:client:get '(desired-replication-level) s
+ (bound-replication-level (get:desired-replication-level get)))
+ (set%! /:msg:dht:client:get '(type) s (get:type get))
+ (slice-copy! (get:key get) (select /:msg:dht:client:get '(key) s))
+ (set%! /:msg:dht:client:get '(unique-id) s (get:unique-id get))
+ (send-message! mq s))
+
+ (define (fresh-id server)
+ "Generate a fresh numeric ID to use for communication with @var{server}."
+ ;; Atomically increment the ‘next unique id’, but avoid
+ ;; overflow (the GNUnet network structures limit the ‘unique id’
+ ;; to being less than (expt 2 64)).
+ (%%bind-atomic-boxen
+ ((next-unique-id (server-next-unique-id/box server) swap!))
+ (let loop ((expected next-unique-id))
+ (define desired (+ 1 expected))
+ ;; TODO(low-priority): handle overflow without errors
+ (when (> desired (- (expt 2 64) 1))
+ (error "you overflowed an 64-bit counter."))
+ (define actual (swap! expected desired))
+ (if (= expected actual)
+ ;; Always returning ‘desired’ instead of ‘expected’ would work
+ ;; too.
+ expected
+ (loop actual)))))
+
+ (define (canonical-block-type type)
+ "Return the numeric value of the block type @var{type}
+(a @code{block-type?} or in-bounds integer)."
+ (cond ((integer? type)
+ (unless (and (<= 0 type (- (expt 2 32) 1)))
+ (error "block type out of bounds"))
+ type)
+ (#t
+ (assert (block-type? type))
+ (value->index type))))
+
+ (define* (start-get! server type key found
+ #:key (desired-replication-level 3))
+ "Perform an asynchronous GET operation on the DHT, and return a handle
+to control the GET operation. Search for a block of type @var{type} (a
+@code{block-type} or its numeric value) and key @var{key}, a readable
bytevector
+slice. Call the procedure @var{found} on every search result.
+
+This procedure is called as @code((found type key data expiration get-path
put-path)w},
+where @var{key}, @var{data}, @var{get-path} and @var{put-path} are readable
+bytevector slices and @var{type} is the numeric value of the block type.
+(TODO: why does the DHT service include the key and type?).
+
+These slices must not be used after @var{found} returns, as the underlying
buffer
+might be reused."
+ ;; TODO: options, xquery ...
+ (unless (= (slice-length key) (sizeof /hashcode:512 '()))
+ (error "length of key incorrect"))
+ (define id (fresh-id server))
+ (define handle (%make-get server found (slice/read-only key)
+ id
+ desired-replication-level
+ (canonical-block-type type)
+ 0)) ; TODO
+ ;; Tell 'process-new-get-operations' about the new get operation.
+ ;; That fiber will take care of putting it into the operation map.
+ (hashq-set! (server-new-get-operations server) handle #t)
+ (trigger-condition! (server-new-get-operation-trigger server))
+ handle)
+
+ (define* (put! server type key data #:key (desired-replication-level 3)
+ (confirmed values))
+ "Perform an asynchronous PUT operation on the DHT, inserting @var{data}
+(a readable bytevector slice) under @var{key} (a readable bytevector slice
+holding a @code{/hashcode:512}). The block type is @var{type} (a
+@code{block-type} or its numeric value).
+
+TODO expiration, replication, confirm ..."
+ ;; Prepare the message to send.
+ (define put-message
+ (make-slice/read-write (+ (sizeof /:msg:dht:client:put '())
+ (slice-length data))))
+ (define meta (slice-slice put-message 0
+ (sizeof /:msg:dht:client:put '())))
+ (set%! /:msg:dht:client:put '(header type) meta
+ (value->index (symbol-value message-type msg:dht:client:put)))
+ (set%! /:msg:dht:client:put '(header size) meta (slice-length
put-message))
+ (set%! /:msg:dht:client:put '(type) meta (pk 'can (canonical-block-type
type)))
+ (set%! /:msg:dht:client:put '(option) meta 0) ; TODO
+ (set%! /:msg:dht:client:put '(desired-replication-level) meta
+ desired-replication-level)
+ (set%! /:msg:dht:client:put '(expiration) meta 0) ; TODO
+ ;; Copy key-data pair to insert into the DHT.
+ (slice-copy! key (select /:msg:dht:client:put '(key) meta))
+ (slice-copy! data
+ (slice-slice put-message (sizeof /:msg:dht:client:put '())))
+ (define handle (%make-put server confirmed put-message))
+ (hashq-set! (server-new-put-operations server) handle #t)
+ (trigger-condition! (server-new-put-operation-trigger server))
+ handle)
+
+ (define-syntax-rule (well-formed?/path-length slice type (field ...)
compare)
+ "Verify the TYPE message in @var{slice}, which has @var{field ...} ...
+(e.g. one or more of get-path-length or put-path-length) and corresponding
+/peer-identities at the end of the message is well-formed -- i.e., check if
the length
+of @var{slice} corresponds to the size of @var{type} and the get-path-length
and
+put-path-length.
+
+@var{compare} must be @code{=} if no additional payload follows, or @code{>=}
+if an addiional payload may follow. The message type and the size in the
+message header is assumed to be correct."
+ ;; Warning: slice is evaluated multiple times!
+ (and (>= (slice-length slice) (sizeof type '()))
+ (let* ((header (slice/read-only slice 0 (sizeof type '())))
+ (extra-size (- (slice-length slice) (sizeof type '())))
+ (field (read% type '(field) header))
+ ...)
+ (compare extra-size (* (+ field ...) (sizeof /peer-identity
'()))))))
+
+ ;; TODO reduce duplication with (gnu gnunet nse client) --- maybe introduce
+ ;; (gnu gnunet client) as in the C implementation?
+ (define (disconnect! server)
+ "Asynchronuously disconnect from the DHT service and stop reconnecting,
+even if not connected. This is an idempotent operation."
+ (atomic-box-set! (server-request-close?/box server) #t)
+ (signal-condition! (server-request-close-condition server)))
+
+ (define* (connect config #:key (spawn spawn-fiber))
+ "Connect to the DHT service in the background."
+ (define request-close?/box (make-atomic-box #f))
+ (define request-close-condition (make-condition))
+ (define new-get-operation-trigger (make-repeated-condition))
+ (define new-get-operations (make-hash-table))
+ (define new-put-operation-trigger (make-repeated-condition))
+ (define new-put-operations (make-hash-table))
+ (define id->operation-map (make-hash-table))
+ (reconnect new-get-operations new-get-operation-trigger
+ new-put-operations new-put-operation-trigger
+ request-close?/box request-close-condition config
+ id->operation-map
+ #:spawn spawn)
+ (%make-server request-close?/box request-close-condition
+ new-get-operations new-get-operation-trigger
+ new-put-operations new-put-operation-trigger
+ ;; Any ‘small’ exact natural number will do.
+ (make-atomic-box 0)
+ id->operation-map))
+
+ (define* (reconnect new-get-operations new-get-operation-trigger
+ new-put-operations new-put-operation-trigger
+ request-close?/box request-close-condition config
+ id->operation-map
+ #:key (spawn spawn-fiber)
+ #:rest rest)
+ (define (process-client-result handle slice)
+ "Process a reply @var{slice} (a @code{/:msg:dht:client:result}
+structure) to the get request @var{handle}."
+ (define header (slice/read-only slice 0
+ (sizeof /:msg:dht:client:result '())))
+ (define rest (slice/read-only slice
+ (sizeof /:msg:dht:client:result '())))
+ (define put-path-length
+ (read% /:msg:dht:client:result '(put-path-length) header))
+ (define get-path-length
+ (read% /:msg:dht:client:result '(get-path-length) header))
+ (define put-path
+ (slice-slice rest 0 (* (sizeof /peer-identity '()) put-path-length)))
+ (define get-path
+ (slice-slice rest (* (sizeof /peer-identity '()) put-path-length)
+ (* (sizeof /peer-identity '()) get-path-length)))
+ (define data
+ (slice-slice rest (* (sizeof /peer-identity '())
+ (+ put-path-length get-path-length))))
+ ;; TODO: maybe validate 'key' and 'type'
+ ((get:iterator handle)
+ (read% /:msg:dht:client:result '(type) header)
+ (select /:msg:dht:client:result '(key) header)
+ data
+ (read% /:msg:dht:client:result '(expiration) header)
+ get-path put-path))
+ (define handlers
+ (message-handlers
+ (message-handler
+ (type (symbol-value message-type msg:dht:monitor:get))
+ ((interpose exp) exp)
+ ((well-formed? slice)
+ ;; The C implementation verifies that 'get-path-length' at most
+ ;; (- (expt 2 16) 1), but this seems only to prevent integer
overflow,
+ ;; which cannot happen in Scheme due to the use of bignums.
+ ;;
+ ;; This message does _not_ have a payload, so use = instead of >=.
+ (well-formed?/path-length slice /:msg:dht:monitor:get-response
+ (get-path-length) =))
+ ((handle! slice) ???))
+ (message-handler
+ (type (symbol-value message-type msg:dht:monitor:get-response))
+ ((interpose exp) exp)
+ ((well-formed? slice)
+ ;; Payload follows, hence >= instead of =.
+ (well-formed?/path-length slice /:msg:dht:monitor:get-response
+ (get-path-length put-path-length) >=))
+ ((handle! slice) ???))
+ (message-handler
+ (type (symbol-value message-type msg:dht:monitor:put))
+ ((interpose exp) exp)
+ ((well-formed? slice)
+ ;; Payload follows, hence >= instead of =.
+ (well-formed?/path-length slice /:msg:dht:monitor:put
+ (put-path-length) >=))
+ ((handle! slice) ???))
+ (message-handler
+ (type (symbol-value message-type msg:dht:client:result))
+ ((interpose exp) exp)
+ ((well-formed? slice)
+ ;; Actual data follows, hence >= instead of =.
+ (well-formed?/path-length slice /:msg:dht:client:result
+ (get-path-length put-path-length) >=))
+ ((handle! slice)
+ ;; The DHT service found some data we were looking for.
+ (let* ((header (slice-slice slice 0
+ (sizeof /:msg:dht:client:result '())))
+ (id (read% /:msg:dht:client:result '(unique-id) header))
+ (handle (hashv-ref id->operation-map id)))
+ (cond ((not handle)
+ (pk 'id id)
+ TODO-error-reporting/1)
+ ((get? handle)
+ ;; TODO might not be true once monitoring operations
+ ;; are supported.
+ (process-client-result handle slice))
+ (#true TODO-error-reporting/2)))))))
+ ;; TODO: abstract duplication in (gnu gnunet nse client)
+ (define mq-closed (make-condition))
+ (define (error-handler error . arguments)
+ (case error
+ ((connection:connected)
+ (pk 'todo-connected)
+ 'todo)
+ ((input:regular-end-of-file input:premature-end-of-file)
+ (signal-condition! mq-closed)
+ (unless (atomic-box-ref request-close?/box)
+ (apply reconnect
+ new-get-operations new-get-operation-trigger
+ new-put-operations new-put-operation-trigger
+ request-close?/box request-close-condition
+ config id->operation-map rest)))
+ ((connection:interrupted)
+ (values))
+ (else
+ (apply report-error error arguments)
+ (close-queue! mq))))
+ (define (request-close-handler)
+ (perform-operation
+ (choice-operation
+ (wait-operation request-close-condition)
+ ;; Make sure the fiber exits after a reconnect.
+ (wait-operation mq-closed)))
+ (close-queue! mq))
+ (define (process-new-get-operations)
+ "Process newly-added get operations, that still need to be communicate
+to the DHT service."
+ (await-trigger! new-get-operation-trigger)
+ (pk 'newstuff!)
+ ;; Extract the latest new operations ...
+ (define new (hash-map->list (lambda (get _) get) new-get-operations))
+ ;; remove them from the list of new operations and add them
+ ;; to the hash table of operations ...
+ (for-each (lambda (get)
+ (hashq-remove! new-get-operations get)
+ (hashq-set! id->operation-map (get:unique-id get) get))
+ new)
+ ;; and (asynchronuously) sent the GET message
+ (for-each (lambda (get) (send-get! mq get)) new)
+ ;; TODO reconnection, closing queues and cancelling get operations,
+ ;; processing answers ...
+ (process-new-get-operations))
+ ;; TODO: remove duplication with process-new-get-operations
+ (define (process-new-put-operations)
+ (await-trigger! new-put-operation-trigger)
+ ;; Extract the latest new put operations
+ (define new (hash-map->list (lambda (put _) put) new-put-operations))
+ ;; And remove them from the hash table
+ (for-each (lambda (put) (hashq-remove! new-put-operations put)) new)
+ ;; and (asynchronuously) sent the PUT message
+ (for-each (lambda (put) (send-message! mq (put:message put))) new)
+ ;; TODO notify-sent callbacks, closing queues, cancelling put
operations,
+ ;; processing answers ...
+ (process-new-put-operations))
+ (define mq (connect/fibers config "dht" handlers error-handler
+ #:spawn spawn))
+ (spawn request-close-handler)
+ (spawn process-new-get-operations)
+ (spawn process-new-put-operations)
+ ;; TODO: use new-get-operations
+ 'todo)))
diff --git a/gnu/gnunet/dht/struct.scm b/gnu/gnunet/dht/struct.scm
new file mode 100644
index 0000000..b2e8688
--- /dev/null
+++ b/gnu/gnunet/dht/struct.scm
@@ -0,0 +1,214 @@
+;; This file is part of GNUnet.
+;; Copyright (C) 2001, 2002, 2003, 2004, 2009, 2011 GNUnet e.V.
+;;
+;; GNUnet is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU Affero General Public License as published
+;; by the Free Software Foundation, either version 3 of the License,
+;; or (at your option) any later version.
+;;
+;; GNUnet is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Affero General Public License for more details.
+;;
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+;;
+;; SPDX-License-Identifier: AGPL-3.0-or-later
+
+(define-library (gnu gnunet dht struct)
+ (export %DHT_BLOOM_SIZE
+ /:msg:dht:client:get:stop
+ /:msg:dht:client:get
+ /:msg:dht:client:get-result-known
+ /:msg:dht:client:result
+ /:msg:dht:client:put
+ /:msg:dht:monitor:put
+ /:msg:dht:monitor:start
+ /:msg:dht:monitor:stop
+ /:msg:dht:monitor:get
+ /:msg:dht:monitor:get-response)
+ (import (only (rnrs base)
+ define begin)
+ (only (gnu gnunet util struct)
+ /:message-header /time-absolute)
+ (only (gnu gnunet hashcode struct)
+ /hashcode:512)
+ (only (gnu gnunet netstruct syntactic)
+ define-type structure/packed)
+ (only (gnu gnunet netstruct procedural)
+ u32/big u64/big s16/big))
+ (begin
+ ;; Size of the bloom filter the DT uses to filter peers.
+ (define %DHT_BLOOM_SIZE 128)
+
+ (define-type /:msg:dht:client:get:stop
+ (structure/packed
+ (synopsis "Message indicating the DHT should cancel outstanding requests
+and discard any state.")
+ (field (header /:message-header)
+ (synopsis "Type: msg:dht:client:get:stop"))
+ (field (reserved u32/big)
+ (synopsis "Always zero"))
+ (field (reserved u64/big)
+ (synopsis "Unique ID identifying this request"))
+ (field (key /hashcode:512)
+ (synopsis "Key of this request"))))
+
+ ;; Possibly followed by xquery.
+ (define-type /:msg:dht:client:get
+ (structure/packed
+ (synopsis "DHT GET message sent from clients to service, indicating a
GET
+request should be issued.")
+ (field (header /:message-header)
+ (synopsis "Type: msg:dht:client:get"))
+ (field (options u32/big)
+ (synopsis "Message options")) ; TODO enum
+ (field (desired-replication-level u32/big)
+ (synopsis "Replication level for this message"))
+ (field (type u32/big)
+ (synopsis "The type for the data for the GET request")) ; TODO
enum
+ (field (key /hashcode:512)
+ (synopsis "The key to search for"))
+ (field (unique-id u64/big)
+ (synopsis "Unique ID identifying this request, if 0 then the
client
+will not expect a response"))))
+
+ ;; Followed by an array of the hash codes of known results.
+ (define-type /:msg:dht:client:get-result-known ;; XXX plural?
+ (structure/packed
+ (synopsis "Message sent from clients to service, indicating a GET
request
+should exclude certain results which are already known.")
+ (field (header /:message-header)
+ (synopsis "Type: msg:dht:client:get-results-known"))
+ (field (reserved u32/big)
+ (synopsis "Reserved, always 0"))
+ (field (key /hashcode:512)
+ (synopsis "The key we are searching for (to make it easy to find
the
+corresponding GET inside the service)."))
+ (field (unique-id u64/big)
+ (synopsis "Unique ID identifying this request"))))
+
+ ;; put path, get path and actual data are copied to the end of this
structure
+ (define-type /:msg:dht:client:result
+ (structure/packed
+ (synopsis "Reply to a GET sent from the service to a client")
+ (field (header /:message-header)
+ (synopsis "Type: msg:dht:client:result"))
+ (field (type u32/big)
+ (synopsis "The type for the data"))
+ (field (put-path-length u32/big)
+ (synopsis "Number of peers recorded in the outgoing path from
+source to the storage location of this message"))
+ (field (get-path-length u32/big)
+ (synopsis "The number of peer identities recorded from the storage
+location to this peer."))
+ (field (unique-id u64/big)
+ (synopsis "Unique ID of the matching GET request"))
+ (field (expiration /time-absolute)
+ (synopsis "Expiration date of this entry"))
+ (field (key /hashcode:512)
+ (synopsis "The key that was searched for"))))
+
+ ;; Data is copied to the end of the message
+ (define-type /:msg:dht:client:put
+ (structure/packed
+ (synopsis "Message to insert data into the DHT, sent from clients to DHT
+service")
+ (field (header /:message-header)
+ (synopsis "Type msg:dht:client:put"))
+ (field (type u32/big)
+ (synopsis "The type of data to insert"))
+ (field (option u32/big)
+ (synopsis "Message options")) ; TODO enum
+ (field (desired-replication-level u32/big)
+ (synopsis "Replication level for this message"))
+ (field (expiration /time-absolute)
+ (synopsis "Requested expiration data of this data"))
+ (field (key /hashcode:512)
+ (synopsis "The key to store the value under"))))
+
+ ;; Followed by put path (if tracked) and payload
+ (define-type /:msg:dht:monitor:put
+ (structure/packed
+ (synopsis "Message to monitor put requests going through peer
+(DHT service -> clients)")
+ (field (header /:message-header)
+ (synopsis "Type: msg:dht:monitor:put"))
+ (field (options u32/big)
+ (synopsis "Message options")) ; TODO enum
+ (field (type u32/big)
+ (synopsis "The type of data in the request"))
+ (field (hop-count u32/big)
+ (synopsis "Hop count so far"))
+ (field (desired-replication-level u32/big)
+ (synopsis "Replication level for this message"))
+ (field (put-path-length u32/big)
+ (synopsis "Number of peers recorded in the outgoing path from
+source to the target location of this message."))
+ (field (expiration-time /time-absolute)
+ (synopsis "How long the data should persist"))
+ (field (key /hashcode:512)
+ (synopsis "The key to store the value under"))))
+
+ (define-type /:msg:dht:monitor:start/stop
+ (structure/packed
+ ;; TODO: also to stop monitoring messages?
+ (synopsis "Message to request monitoring messages, client -> DHT
service")
+ (field (header /:message-header)
+ (synopsis "Type: msg:dht:monitor:start or msg:dht:monitor:stop"))
+ (field (type u32/big)
+ ;; XXX block types
+ (synopsis "The type of data desired, GNUNET_BLOCK_TYPE_ANY for
all"))
+ ;; FIXME: grammar
+ (field (get? s16/big)
+ (synopsis "Flag whether to notify about GET messages"))
+ (field (get-response? s16/big)
+ (synopsis "Flag whether to notify about GET_RESPONSE messages"))
+ (field (put? s16/big)
+ (synopsis "Flag whether to notify about PUT messages"))
+ (field (filter-key? s16/big)
+ (synopsis "Flag whether to use the provided key to filter
messages"))
+ (field (key /hashcode:512)
+ (synopsis "The key to filter messages by"))))
+
+ (define-type /:msg:dht:monitor:start /:msg:dht:monitor:start/stop)
+ (define-type /:msg:dht:monitor:stop /:msg:dht:monitor:start/stop)
+
+ ;; Followed by get path (if tracked)
+ (define-type /:msg:dht:monitor:get
+ (structure/packed
+ (synopsis "Message to monitor get requests going through peer,
+DHT service -> clients.")
+ (field (header /:message-header)
+ (synopsis "Type: msg:dht:monitor:get"))
+ (field (options u32/big)
+ (synopsis "Message options")) ; TODO enum
+ (field (type u32/big)
+ (synopsis "The type of data in the request"))
+ (field (hop-count u32/big)
+ (synopsis "Hop count"))
+ (field (desired-replication-level u32/big)
+ (synopsis "Replication level for this message"))
+ (field (get-path-length u32/big)
+ (synopsis "Number of peers recorded in the outgoing path from
+source to the storage location of this message"))
+ (field (key /hashcode:512)
+ (synopsis "The key to store the value under"))))
+
+ ;; followed by put path (if tracked), get path (if tracked) and payload
+ (define-type /:msg:dht:monitor:get-response
+ (structure/packed
+ (synopsis "Message to monitor get requests going through peer,
+DHT service -> clients")
+ (field (header /:message-header)
+ ;; XXX correct?
+ (synopsis "Type: msg:dht:p2p:result"))
+ (field (type u32/big)
+ (synopsis "Content type"))
+ (field (put-path-length u32/big)
+ (synopsis "Length of the PUT path that follows (if tracked)"))
+ (field (get-path-length u32/big)
+ (synopsis "Length of the GET path that follows (if tracked)"))
+ (field (expiration-time /time-absolute)
+ (synopsis "When does the content expire?"))))))
diff --git a/gnu/gnunet/message/enum-dht.scmfrag
b/gnu/gnunet/message/enum-dht.scmfrag
index 55514e0..3223133 100644
--- a/gnu/gnunet/message/enum-dht.scmfrag
+++ b/gnu/gnunet/message/enum-dht.scmfrag
@@ -55,6 +55,6 @@
(documentation ""))
msg:155
(value
- (symbol msg:dht:client-get-result-known)
+ (symbol msg:dht:client:get-result-known)
(index 156)
(documentation ""))
diff --git a/gnu/gnunet/netstruct/procedural.scm
b/gnu/gnunet/netstruct/procedural.scm
index efcff58..8850322 100644
--- a/gnu/gnunet/netstruct/procedural.scm
+++ b/gnu/gnunet/netstruct/procedural.scm
@@ -43,6 +43,8 @@
u8 u16/big u32/big u64/big
u16/little u32/little u64/little
+ s8 s16/big s32/big s64/big
+ s16/little s32/little s64/little
ieee-double/big ieee-double/little
u8vector
@@ -371,37 +373,40 @@ accepting a bytevector slice and a value."
#:reader primitive-reader
#:setter primitive-setter))
- (define (unsigned-N-bytes length slice-ref slice-set! . rest)
+ (define (N-bytes length slice-ref slice-set! . rest)
(apply make-netprimitive length slice-ref slice-set! rest))
;; Not used at run-time, only when expanding,
;; so this doesn't need to end up in the .go.
(eval-when (expand)
- (define-syntax define-unsigned-N-bytes
+ (define-syntax define-N-bytes
(syntax-rules ()
- ((_ (length slice-ref slice-set!)
+ ((_ signedness
+ (length slice-ref slice-set!)
(name-big name-little))
(begin
(define name-big
- (unsigned-N-bytes
+ (N-bytes
length
(cute slice-ref <> 0 (endianness big))
(cute slice-set! <> 0 <> (endianness big))
#:properties '((endianness . big)
- (integer-type . unsigned))))
+ (integer-type . signedness))))
(define name-little
- (unsigned-N-bytes
+ (N-bytes
length
(cute slice-ref <> 0 (endianness little))
(cute slice-set! <> 0 <> (endianness little))
#:properties '((endianness . little)
- (integer-type . unsigned))))))))
- (define-syntax define-unsigned-N-bytes*
+ (integer-type . signedness))))))))
+ (define-syntax define-N-bytes*
(syntax-rules ()
- ((_ ((length slice-ref slice-set!)
+ ((_ signedness
+ ((length slice-ref slice-set!)
(name-big name-little)) ...)
(begin
- (define-unsigned-N-bytes
+ (define-N-bytes
+ signedness
(length slice-ref slice-set!) (name-big name-little))
...)))))
@@ -409,11 +414,22 @@ accepting a bytevector slice and a value."
(cut slice-u8-ref <> 0)
(cut slice-u8-set! <> 0 <>)
#:properties '((integer-type . unsigned))))
+ (define s8 (make-netprimitive 1
+ (cut slice-s8-ref <> 0)
+ (cut slice-s8-set! <> 0 <>)
+ #:properties '((integer-type . signed))))
- (define-unsigned-N-bytes*
+ (define-N-bytes*
+ unsigned
((2 slice-u16-ref slice-u16-set!) (u16/big u16/little))
((4 slice-u32-ref slice-u32-set!) (u32/big u32/little))
- ((8 slice-u64-ref slice-u64-set!) (u64/big u64/little))
+ ((8 slice-u64-ref slice-u64-set!) (u64/big u64/little)))
+
+ (define-N-bytes*
+ signed
+ ((2 slice-s16-ref slice-s16-set!) (s16/big s16/little))
+ ((4 slice-s32-ref slice-s32-set!) (s32/big s32/little))
+ ((8 slice-s64-ref slice-s64-set!) (s64/big s64/little))
((8 slice-ieee-double-ref slice-ieee-double-set!)
(ieee-double/big ieee-double/little)))
diff --git a/gnu/gnunet/utils/bv-slice.scm b/gnu/gnunet/utils/bv-slice.scm
index 2f0639e..6637852 100644
--- a/gnu/gnunet/utils/bv-slice.scm
+++ b/gnu/gnunet/utils/bv-slice.scm
@@ -44,6 +44,14 @@
slice-u16-set!
slice-u32-set!
slice-u64-set!
+ slice-s8-ref
+ slice-s16-ref
+ slice-s32-ref
+ slice-s64-ref
+ slice-s8-set!
+ slice-s16-set!
+ slice-s32-set!
+ slice-s64-set!
slice-ieee-double-ref
slice-ieee-double-set!
;; Large operations
@@ -209,8 +217,15 @@ the bytevector in place."
(wrap-rnrs-ref bytevector-u32-ref slice-readable? 4))
(define slice-u64-ref
(wrap-rnrs-ref bytevector-u64-ref slice-readable? 8))
- (define slice-ieee-double-ref
- (wrap-rnrs-ref bytevector-ieee-double-ref slice-readable? 8))
+
+ (define slice-s8-ref
+ (wrap-rnrs-ref bytevector-s8-ref slice-readable? 1))
+ (define slice-s16-ref
+ (wrap-rnrs-ref bytevector-s16-ref slice-readable? 2))
+ (define slice-s32-ref
+ (wrap-rnrs-ref bytevector-s32-ref slice-readable? 4))
+ (define slice-s64-ref
+ (wrap-rnrs-ref bytevector-s64-ref slice-readable? 8))
(define slice-u8-set!
(wrap-rnrs-ref bytevector-u8-set! slice-writable? 1))
@@ -220,6 +235,18 @@ the bytevector in place."
(wrap-rnrs-ref bytevector-u32-set! slice-writable? 4))
(define slice-u64-set!
(wrap-rnrs-ref bytevector-u64-set! slice-writable? 8))
+
+ (define slice-s8-set!
+ (wrap-rnrs-ref bytevector-s8-set! slice-writable? 1))
+ (define slice-s16-set!
+ (wrap-rnrs-ref bytevector-s16-set! slice-writable? 2))
+ (define slice-s32-set!
+ (wrap-rnrs-ref bytevector-s32-set! slice-writable? 4))
+ (define slice-s64-set!
+ (wrap-rnrs-ref bytevector-s64-set! slice-writable? 8))
+
+ (define slice-ieee-double-ref
+ (wrap-rnrs-ref bytevector-ieee-double-ref slice-readable? 8))
(define slice-ieee-double-set!
(wrap-rnrs-ref bytevector-ieee-double-set! slice-writable? 8))
diff --git a/guix.scm b/guix.scm
index 4b6968b..a5e6419 100644
--- a/guix.scm
+++ b/guix.scm
@@ -22,10 +22,12 @@
(gnu packages guile-xyz)
(gnu packages autotools)
(gnu packages gettext)
+ (gnu packages gnupg)
(gnu packages pkg-config)
(gnu packages xorg)
(gnu packages text-editors)
(guix packages)
+ (guix utils)
(guix gexp)
(guix git)
(guix git-download)
@@ -40,7 +42,15 @@
(origin
(inherit (package-source guile-3.0-latest))
(patches (list (local-file
"0001-Fix-non-revealed-port-is-closed-ports.test.patch")
- (local-file "0001-ice-9-read-Parse-properly.patch")))))))
+ (local-file "0001-ice-9-read-Parse-properly.patch")))))
+ (arguments
+ (substitute-keyword-arguments
+ (package-arguments guile-3.0-latest)
+ ;; Tests can take long to run.
+ ;; Also, it fails with
+ ;; ERROR: web-server.test: GET / - arguments: ((system-error "connect"
"~A" ("Connection refused") (111)))
+ ;; and likewise for /latin1, /user-agent and /does-not-exist.
+ ((#:tests? _) #f)))))
;; This has some I/O patches (wait-until-port-readable-operation),
;; see <https://github.com/wingo/fibers/pull/50>.
@@ -54,6 +64,8 @@
(commit "4658b62b402e7d4920ab528da1b42835cea03429")))
(sha256
(base32 "1956rz411p3yf7a75z2k1hii88kmn25y2p32bw6w45yy8pynm1rg"))))
+ ;; Tests take a lot of time.
+ (arguments `(#:tests? #f))
(native-inputs
`(("autoconf" ,autoconf)
("gettext" ,gettext-minimal)
@@ -79,9 +91,11 @@
(propagated-inputs `(("guile-zlib" ,guile-zlib)
("guile-bytestructures" ,guile-bytestructures)
("guile-fibers" ,guile-fibers/patched)
+ ("guile-gcrypt" ,guile-gcrypt)
("guile-json" ,guile-json-4)
("guile-pfds" ,guile-pfds)))
(native-inputs `(("guile" ,guile-3.0/fixed)
+ ("guile-gcrypt" ,guile-gcrypt)
("guile-json-4" ,guile-json-4)
("guile-pfds" ,guile-pfds)
("automake" ,automake)
diff --git a/tests/bv-slice.scm b/tests/bv-slice.scm
index 44c45fb..e8f5bb7 100644
--- a/tests/bv-slice.scm
+++ b/tests/bv-slice.scm
@@ -18,6 +18,7 @@
(import (gnu gnunet utils bv-slice)
(srfi srfi-26)
+ (ice-9 match)
(rnrs conditions)
(rnrs bytevectors))
@@ -89,6 +90,55 @@
&assertion
(slice-zero! (slice/write-only (make-slice/read-write 0))))
+(define (some-numbers N)
+ (map (cut expt 2 <>) (iota N)))
+(define sizes/u `(#(16 ,slice-u16-ref ,slice-u16-set!)
+ #(32 ,slice-u32-ref ,slice-u32-set!)
+ #(64 ,slice-u64-ref ,slice-u64-set!)))
+(define sizes/s `(#(16 ,slice-s16-ref ,slice-s16-set!)
+ #(32 ,slice-s32-ref ,slice-s32-set!)
+ #(64 ,slice-s64-ref ,slice-s64-set!)))
+
+(for-each
+ (match-lambda
+ (#(bits ref set!)
+ (test-equal
+ (string-append "slice-u" (number->string bits) "-ref/set! round-trips")
+ (some-numbers bits)
+ (map (lambda (number)
+ ;; #xde: filler that should be unused
+ (define bv (make-bytevector (/ bits 8) #xde))
+ (define sl (bv-slice/read-write bv))
+ (set! sl 0 number (endianness little))
+ (ref sl 0 (endianness little)))
+ (some-numbers bits)))))
+ sizes/u)
+
+(for-each
+ (match-lambda
+ (#(bits ref set!)
+ (test-equal
+ (string-append "slice-s" (number->string bits) "-ref/set! round-trips")
+ (append (map - (some-numbers bits))
+ ;; -1: avoid the sign bit
+ (some-numbers (- bits 1)))
+ (map (lambda (number)
+ ;; #xde: filler that should be unused
+ (define bv (make-bytevector (/ bits 8) #xde))
+ (define sl (bv-slice/read-write bv))
+ (set! sl 0 number (endianness little))
+ (ref sl 0 (endianness little)))
+ (append (map - (some-numbers bits))
+ (some-numbers (- bits 1)))))))
+ sizes/s)
+
+;; Signed integer representations are used in some network messages,
+;; so make sure they will be interpreted the same no matter the
+;; architecture.
+(test-equal "two's complement is used"
+ -128
+ (slice-s8-ref (bv-slice/read-write #vu8(#b10000000)) 0))
+
(test-end "bv-slice")
;; ^ TODO: test other procedures
diff --git a/tests/crypto.scm b/tests/crypto.scm
new file mode 100644
index 0000000..1920bf0
--- /dev/null
+++ b/tests/crypto.scm
@@ -0,0 +1,89 @@
+;; This file is part of scheme-GNUnet.
+;; Copyright (C) 2021 GNUnet e.V.
+;;
+;; scheme-GNUnet is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU Affero General Public License as published
+;; by the Free Software Foundation, either version 3 of the License,
+;; or (at your option) any later version.
+;;
+;; scheme-GNUnet is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Affero General Public License for more details.
+;;
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+;;
+;; SPDX-License-Identifier: AGPL3.0-or-later
+
+(import (gnu gnunet utils bv-slice)
+ (gnu gnunet crypto)
+ (gnu gnunet hashcode struct)
+ (only (gnu gnunet netstruct syntactic)
+ sizeof)
+ (only (gcrypt base16)
+ base16-string->bytevector)
+ (only (rnrs bytevectors)
+ make-bytevector string->utf8)
+ (srfi srfi-64)
+ (only (srfi srfi-43)
+ vector-every)
+ (only (ice-9 match)
+ match))
+
+;; Two test vectors from
+;;
https://www.cosic.esat.kuleuven.be/nessie/testvectors/hash/sha/Sha-2-512.unverified.test-vectors
+(define test-vectors/sha512
+ #(#(""
+ "CF83E1357EEFB8BDF1542850D66D8007"
+ "D620E4050B5715DC83F4A921D36CE9CE"
+ "47D0D13C5D85F2B0FF8318D2877EEC2F"
+ "63B931BD47417A81A538327AF927DA3E")
+ #("abc"
+ "DDAF35A193617ABACC417349AE204131"
+ "12E6FA4E89A97EA20A9EEEE64B55D39A"
+ "2192992A274FC1A836BA3C23A3FEEBBD"
+ "454D4423643CE80E2A9AC94FA54CA49F")))
+
+(define (test-vector bits hash-slice! test-vector)
+ (match test-vector
+ (#(string hash-part/0 hash-part/1 hash-part/2 hash-part/3)
+ (define hash/base16 (string-append hash-part/0 hash-part/1 hash-part/2
+ hash-part/3))
+ (define hash/expected
+ (base16-string->bytevector (string-downcase hash/base16)))
+ ;; #xde: bogus filler, should be overwritten
+ (define hash/received (make-bytevector (/ bits 8) #xde))
+ (hash-slice! (slice/read-only
+ (bv-slice/read-write
+ (string->utf8 (string-append "don't" string "useme")))
+ ;; The string length is also the bytevector
+ ;; length, because the strings are restricted to ASCII.
+ (string-length "don't")
+ (string-length string))
+ (slice/write-only
+ (bv-slice/read-write hash/received)))
+ (when (not (equal? hash/expected hash/received))
+ (pk 'oops hash/expected hash/received))
+ (pk 'ok)
+ (equal? hash/expected hash/received))))
+
+(define (test-vectors bits hash-slice! vectors)
+ (vector-every (lambda (vector)
+ (test-vector bits hash-slice! vector))
+ vectors))
+
+(test-assert "hash/sha512!, test vectors"
+ (test-vectors 512 hash/sha512! test-vectors/sha512))
+
+(test-error "hash/sha512!, requires readability"
+ (hash/sha512! (slice/write-only (make-slice/read-write 400))
+ (make-slice/read-write (/ 512 8))))
+
+(test-error "hash/sha512!, requires writability"
+ (hash/sha512! (make-slice/read-write 400)
+ (slice/read-only (make-slice/read-write (/ 512 8)))))
+
+(test-equal "size of /hashcode:512"
+ 512
+ (* 8 (sizeof /hashcode:512 '())))
diff --git a/tests/distributed-hash-table.scm b/tests/distributed-hash-table.scm
new file mode 100644
index 0000000..1cb134b
--- /dev/null
+++ b/tests/distributed-hash-table.scm
@@ -0,0 +1,76 @@
+;; This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
+;; Copyright (C) 2021 GNUnet e.V.
+;;
+;; scheme-GNUnet is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU Affero General Public License as published
+;; by the Free Software Foundation, either version 3 of the License,
+;; or (at your option) any later version.
+;;
+;; scheme-GNUnet is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Affero General Public License for more details.
+;;
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+;;
+;; SPDX-License-Identifier: AGPL-3.0-or-later
+(define-module (test-distributed-hash-table))
+(import (gnu gnunet dht client)
+ (rnrs base)
+ (srfi srfi-26)
+ (srfi srfi-64))
+
+;; It's easy to accidentally swap the min and the max,
+;; or use theoretical bounds instead of effective bounds.
+(test-begin "bound-replication-level")
+
+(define-syntax test-bound-equals
+ (syntax-rules (->)
+ ((_ (name argument -> expected) ...)
+ (begin
+ (test-equal name (list expected)
+ (call-with-values
+ (lambda ()
+ (bound-replication-level argument))
+ list))
+ ...))))
+
+(test-bound-equals
+ ;; Boundaries of set of fixed points
+ ("effective minimum" %effective-minimum-replication-level
+ -> %effective-minimum-replication-level)
+ ("effective maximum" %effective-maximum-replication-level
+ -> %effective-maximum-replication-level)
+ ;; off by one
+ ("zero" ; remove this test if %effective-minimum-replication-level becomes
zero
+ (begin (assert (> %effective-minimum-replication-level
%minimum-replication-level))
+ %effective-minimum-replication-level)
+ -> %effective-minimum-replication-level)
+ ("effective maximum + 1"
+ (begin (assert (< %effective-maximum-replication-level
%maximum-replication-level))
+ (+ 1 %effective-maximum-replication-level))
+ -> %effective-maximum-replication-level)
+ ;; Extreme values
+ ("theoretical minimum" %minimum-replication-level
+ -> %effective-minimum-replication-level)
+ ("theoretical maximum" %maximum-replication-level
+ -> %effective-maximum-replication-level))
+
+(define between
+ (map (cut + %effective-minimum-replication-level <>)
+ (iota (- %effective-maximum-replication-level
+ %effective-minimum-replication-level))))
+
+;; Inner fixed points
+(test-equal "between effective extrema"
+ between
+ (map bound-replication-level between))
+
+(test-error "too large" (bound-replication-level (+ 1
%maximum-replication-level)))
+(test-error "way too large" (bound-replication-level (* #e1e20
%maximum-replication-level)))
+(test-error "too small" (bound-replication-level (- %minimum-replication-level
1)))
+(test-error "way too small" (bound-replication-level (-
%minimum-replication-level #e1e20)))
+(test-error "non-numeric" (bound-replication-level 'what))
+
+(test-end)
diff --git a/tests/form.scm b/tests/form.scm
new file mode 100644
index 0000000..7edd7e2
--- /dev/null
+++ b/tests/form.scm
@@ -0,0 +1,93 @@
+;; This file is part of scheme-GNUnet. -*- coding: utf-8 -*-
+;; Copyright (C) 2021 GNUnet e.V.
+;;
+;; scheme-GNUnet is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU Affero General Public License as published
+;; by the Free Software Foundation, either version 3 of the License,
+;; or (at your option) any later version.
+;;
+;; scheme-GNUnet is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Affero General Public License for more details.
+;;
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+;;
+;; SPDX-License-Identifier: AGPL3.0-or-later
+
+(use-modules (web form)
+ (rnrs bytevectors)
+ (srfi srfi-64))
+
+(define (urlencoded-string->alist string)
+ (urlencoded->alist (string->utf8 string)))
+
+(define-syntax-rule (test-decode name from to)
+ (test-equal name (list to) (list (urlencoded-string->alist from))))
+
+(test-begin "w-www-form-urlencoded")
+
+(test-decode "empty list" "" '())
+(test-decode "one field" "x=y" '(("x" . "y")))
+(test-decode "two fields" "x=y&z=w" '(("x" . "y") ("z" . "w")))
+(test-decode "spaces" "x+x+x=z+z+z" '(("x x x" . "z z z")))
+(test-decode "forgot to encode spaces" "x x x=z z z" #f)
+(test-decode "%-encoding" "x%01%02=x%03z" '(("x\x01\x02" . "x\x03z")))
+(test-decode "%-encoding (NULL)" "%00x%01%02=x%03z" '(("\x00x\x01\x02" .
"x\x03z")))
+(test-decode "= in keys and values" "x%3Dz=0%3D1" '(("x=z" . "0=1")))
+
+(test-decode "zero-length values" "x=&y=" '(("x" . "") ("y" . "")))
+(test-decode "zero-length keys" "=z" '(("" . "z")))
+
+;; IceCat 78.14.0 (a Firefox derivative) doesn't encode - and _, even though
they should
+;; be according to RFC 1866.
+(test-decode "Firefox compatibility" "x-yz_w=0-12_3" '(("x-yz_w" . "0-12_3")))
+(test-decode "Correct %-encoding of - and _" "%5F=%2D" '(("_" . "-")))
+
+;; The specification uses uppercase letters.
+(test-decode "no lowercase % (0)" "%aA=0" #false)
+(test-decode "no lowercase % (1)" "%Aa=0" #false)
+
+(test-decode "no %-encoding of A" "%41=0" #false)
+(test-decode "no %-encoding of Z" "%5A=0" #false)
+(test-decode "no %-encoding of a" "%61=0" #false)
+(test-decode "no %-encoding of z" "%7A=0" #false)
+(test-decode "no %-encoding of 0" "%30=0" #false)
+(test-decode "no %-encoding of 9" "%39=0" #false)
+
+;; While it might not be advisable, RFC 1866 does not forbid duplicate
+;; field names.
+(test-decode "duplicate field names" "field=value&field=value2"
+ '(("field" . "value") ("field" . "value2")))
+
+(test-decode "leading &" "&oop=s" #false)
+(test-decode "trailing &" "oop=s&" #false)
+(test-decode "duplicated &" "o=o&&p=s" #false)
+(test-decode "duplicated =" "oo==ps" #false)
+(test-decode "too many =" "o=o=ps" #false)
+
+;; RFC 1866 doesn't specify any character encoding, so assume UTF-8.
+(define unicode-input "%C3%A9=%F0%9F%AA%82")
+(define unicode-output '(("é" . "🪂")))
+(test-decode "non-ASCII" unicode-input unicode-output)
+(test-decode "bogus UTF-8" "%ED%9F%C0=z" #f)
+
+(define (test-decode-with-encoding encoding)
+ (parameterize (((fluid->parameter %default-port-encoding) encoding))
+ (test-decode (string-append "non-ASCII, with " encoding
+ " default port encoding")
+ unicode-input unicode-output)))
+
+;; 'unescape' calls 'call-with-output-bytevector' without explicitely setting
+;; the port encoding appropriately
+(test-decode-with-encoding "UTF-8")
+(test-decode-with-encoding "ISO-88519") ; doesn't support Unicode
+(test-decode-with-encoding "UTF-16") ; two to four bytes per character
+(test-decode-with-encoding "EBCDIC") ; non-ASCII compatible, doesn't support
Unicode
+
+(test-decode "non-ASCII input" "é=é" #f)
+(test-assert "bogus UTF-8 (before decoding)"
+ (not (urlencoded->alist #vu8(237 159 192 61 49))))
+
+(test-end "w-www-form-urlencoded")
diff --git a/web/form.scm b/web/form.scm
new file mode 100644
index 0000000..1a191ae
--- /dev/null
+++ b/web/form.scm
@@ -0,0 +1,118 @@
+;; This file is part of scheme-GNUnet
+;; Copyright (C) 2021 GNUnet e.V.
+;;
+;; scheme-GNUnet is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU Affero General Public License as published
+;; by the Free Software Foundation, either version 3 of the License,
+;; or (at your option) any later version.
+;;
+;; GNUnet is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Affero General Public License for more details.
+;;
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+;;
+;; SPDX-License-Identifier: AGPL-3.0-or-later
+
+;; TODO: look into integrating this into Guile proper.
+(define-module (web form)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (ice-9 textual-ports)
+ #:use-module (ice-9 control)
+ #:use-module (ice-9 string-fun)
+ #:export (urlencoded->alist))
+
+
+;; application/x-www-form-urlencoded, documented in 8.2.1.
+;; of RFC 1866
+
+;; 8.2.1 ‘[...] space characters are replaced by #\+ [...]’
+;;
+;; Presumably only #\ is meant here and not the non-breaking space (NBSP),
+;; otherwise NBSP could not be distinguished from the regular space character
+;; #\ .
+;;
+;; 8.2.1 ‘[...] [non-alphanumeric] characters are replaced by %HH [...]’.
+;;
+;; Presumably with ‘non-alphanumeric’, ‘non-alphanumeric or non-ASCII’
+;; is meant here, otherwise the validity of application/x-www-form-urlencoded
+;; data could depend on the Unicode standard used.
+;;
+;; In practice, Firefox doesn't escape - and _, so include those as well
+;; for compatibility.
+
+;; TODO: isn't a-zA-Z0-9 problematic under some locales?
+(define encoded-pat "^(\\+|[a-zA-Z0-9_-]|%[0-9A-F][0-9A-F])*$")
+(define encoded-regex (make-regexp encoded-pat))
+
+(define (try-utf8->string bv)
+ "Like utf8->string, but return #false instead of raising an error if
+@var{bv} is not valid UTF-8."
+ (catch 'decoding-error
+ ;; RFC 1866 doesn't specify the character encoding, so assume UTF-8.
+ (lambda () (utf8->string bv))
+ (lambda _ #false)))
+
+(define (urlencoded-string->alist string)
+ (let/ec return
+ (let ()
+ (define (oops)
+ (return #false))
+ (when (string-null? string)
+ (return '()))
+ (define fields (string-split string #\&))
+ (define (unescape string)
+ ;; Validate the syntax of STRING ...
+ (unless (regexp-exec encoded-regex string)
+ (oops))
+ ;; ... replace #\+ with #\ ...
+ (define string-with-space (string-replace-substring string "+" " "))
+ (define bv
+ (call-with-output-bytevector
+ (lambda (port)
+ ;; ... and undo % escapes.
+ (define (search remainder)
+ (define next-% (string-index remainder #\%))
+ (if next-%
+ (begin
+ (put-string port (substring remainder 0 next-%))
+ (undo-% (substring remainder next-%)))
+ (put-string port remainder)))
+ (define (undo-% remainder)
+ (define octet
+ (string->number (substring remainder 1 3) 16))
+ ;; 8.2.1 ‘[...] [non-alphanumeric] characters are replaced by
+ ;; %HH [...]’.
+ ;;
+ ;; The syntax of application/x-www-form-urlencoded is given in
+ ;; terms of how to encode the fields, and alphanumeric characters
+ ;; are not included there, thus alphanumeric characters are
+ ;; forbidden.
+ (when (or (<= (char->integer #\a) octet (char->integer #\z))
+ (<= (char->integer #\A) octet (char->integer #\Z))
+ (<= (char->integer #\0) octet (char->integer #\9)))
+ (oops))
+ (put-u8 port octet)
+ (search (substring remainder 3)))
+ (search string-with-space))))
+ ;; RFC 1866 doesn't specify the character encoding, so assume UTF-8.
+ ;; The resulting bytevector could be bogus UTF-8, so catch
+ ;; 'decoding-error'.
+ (or (try-utf8->string bv)
+ (oops)))
+ (define (decode-field field)
+ (match (string-split field #\=)
+ ((escaped-field-name escaped-field-value)
+ (cons (unescape escaped-field-name) (unescape escaped-field-value)))
+ (_ (oops))))
+ (map decode-field fields))))
+
+(define (urlencoded->alist body)
+ "Decode body, a bytevector holding a application/x-www-form-urlencoded,
+to an association list of string-valued key-value pairs. Return #false
+if the bytevector could not be parsed."
+ (and=> (try-utf8->string body) urlencoded-string->alist))
diff --git a/web/server/fiberized.scm b/web/server/fiberized.scm
new file mode 100644
index 0000000..e44dcaa
--- /dev/null
+++ b/web/server/fiberized.scm
@@ -0,0 +1,216 @@
+;;; Web I/O: Non-blocking HTTP
+
+;; Copyright (C) 2012, 2018 Free Software Foundation, Inc.
+
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+;; 02110-1301 USA
+
+;;; Commentary:
+;;;
+;;; This is the non-blocking HTTP implementation of the (web server)
+;;; interface.
+;;;
+;;; It is a modified version of (web server fibers) from Fibers 1.0.0 that
+;;; does not create new threads and does not call 'run-fibers'. Instead it
+;;; expects to be running directly in a fiberized program.
+;;;
+;;; (Modifications by Ludovic Courtès, 2018-01.)
+;;;
+;;; More commentary: Cuirass code has been removed
+;;;
+;;;
+;;; Code:
+
+
+(define-module (web server fiberized)
+ #:use-module ((srfi srfi-1) #:select (fold
+ alist-delete
+ alist-cons))
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (web http)
+ #:use-module (web request)
+ #:use-module (web response)
+ #:use-module (web server)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (ice-9 match)
+ #:use-module (fibers)
+ #:use-module (fibers channels))
+
+(define (make-default-socket family addr port)
+ (let ((sock (socket PF_INET SOCK_STREAM 0)))
+ (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
+ (fcntl sock F_SETFD FD_CLOEXEC)
+ (bind sock family addr port)
+ (fcntl sock F_SETFL (logior O_NONBLOCK (fcntl sock F_GETFL)))
+ sock))
+
+(define-record-type <server>
+ (make-server request-channel)
+ server?
+ (request-channel server-request-channel))
+
+;; -> server
+(define* (open-server #:key
+ (host #f)
+ (family AF_INET)
+ (addr (if host
+ (inet-pton family host)
+ INADDR_LOOPBACK))
+ (port 8080)
+ (socket (make-default-socket family addr port)))
+ ;; We use a large backlog by default. If the server is suddenly hit
+ ;; with a number of connections on a small backlog, clients won't
+ ;; receive confirmation for their SYN, leading them to retry --
+ ;; probably successfully, but with a large latency.
+ (listen socket 1024)
+ (fcntl socket F_SETFL (logior O_NONBLOCK (fcntl socket F_GETFL)))
+ (sigaction SIGPIPE SIG_IGN)
+ (let ((request-channel (make-channel)))
+ (spawn-fiber
+ (lambda ()
+ (socket-loop socket request-channel)))
+ (make-server request-channel)))
+
+(define (bad-request msg . args)
+ (throw 'bad-request msg args))
+
+(define (keep-alive? response)
+ (let ((v (response-version response)))
+ (and (or (< (response-code response) 400)
+ (= (response-code response) 404))
+ (case (car v)
+ ((1)
+ (case (cdr v)
+ ((1) (not (memq 'close (response-connection response))))
+ ((0) (memq 'keep-alive (response-connection response)))))
+ (else #f)))))
+
+;; This procedure and the next one are copied from (guix scripts publish).
+(define (strip-headers response)
+ "Return RESPONSE's headers minus 'Content-Length' and our internal headers."
+ (fold alist-delete
+ (response-headers response)
+ '(content-length x-raw-file x-nar-compression)))
+
+(define (with-content-length response length)
+ "Return RESPONSE with a 'content-length' header set to LENGTH."
+ (set-field response (response-headers)
+ (alist-cons 'content-length length
+ (strip-headers response))))
+
+(define (client-loop client have-request)
+ ;; Always disable Nagle's algorithm, as we handle buffering
+ ;; ourselves.
+ (setsockopt client IPPROTO_TCP TCP_NODELAY 1)
+ (setvbuf client 'block 1024)
+ (catch #t
+ (lambda ()
+ (let ((response-channel (make-channel)))
+ (let loop ()
+ (cond
+ ((eof-object? (lookahead-u8 client))
+ (close-port client))
+ (else
+ (call-with-values
+ (lambda ()
+ (catch #t
+ (lambda ()
+ (let* ((request (read-request client))
+ (body (read-request-body request)))
+ (have-request response-channel request body)))
+ (lambda (key . args)
+ (display "While reading request:\n"
+ (current-error-port))
+ (print-exception (current-error-port) #f key args)
+ (values (build-response #:version '(1 . 0) #:code 400
+ #:headers
+ '((content-length . 0)))
+ #vu8()))))
+ (lambda (response body)
+ (match (assoc-ref (response-headers response) 'x-raw-file)
+ ((? string? file)
+ (non-blocking
+ (call-with-input-file file
+ (lambda (input)
+ (let* ((size (stat:size (stat input)))
+ (response (write-response
+ (with-content-length response size)
+ client))
+ (output (response-port response)))
+ (setsockopt client SOL_SOCKET SO_SNDBUF
+ (* 128 1024))
+ (if (file-port? output)
+ (sendfile output input size)
+ (dump-port input output))
+ (close-port output)
+ (values))))))
+ (#f (begin
+ (write-response response client)
+ (when body
+ (put-bytevector client body))
+ (force-output client))
+ (if (and (keep-alive? response)
+ (not (eof-object? (peek-char client))))
+ (loop)
+ (close-port client)))))))))))
+ (lambda args
+ ;; Ignore premature client disconnections.
+ (unless (memv (system-error-errno args)
+ (list EPIPE ECONNRESET))
+ (apply throw args)))
+ (lambda (k . args)
+ (catch #t
+ (lambda () (close-port client))
+ (lambda (k . args)
+ (display "While closing port:\n" (current-error-port))
+ (print-exception (current-error-port) #f k args))))))
+
+(define (socket-loop socket request-channel)
+ (define (have-request response-channel request body)
+ (put-message request-channel (vector response-channel request body))
+ (match (get-message response-channel)
+ (#(response body)
+ (values response body))))
+ (let loop ()
+ (match (accept socket (logior SOCK_NONBLOCK SOCK_CLOEXEC))
+ ((client . sockaddr)
+ (spawn-fiber (lambda () (client-loop client have-request))
+ #:parallel? #t)
+ (loop)))))
+
+;; -> (client request body | #f #f #f)
+(define (server-read server)
+ (match (get-message (server-request-channel server))
+ (#(response-channel request body)
+ (let ((client response-channel))
+ (values client request body)))))
+
+;; -> 0 values
+(define (server-write server client response body)
+ (let ((response-channel client))
+ (put-message response-channel (vector response body)))
+ (values))
+
+;; -> unspecified values
+(define (close-server server)
+ ;; FIXME: We should terminate the 'socket-loop' fiber somehow.
+ *unspecified*)
+
+(define-server-impl fiberized
+ open-server
+ server-read
+ server-write
+ close-server)
--
To stop receiving notification emails like this one, please contact
gnunet@gnunet.org.
- [gnunet-scheme] branch master updated (6c136b9 -> 5c7bf08),
gnunet <=
- [gnunet-scheme] 04/49: dht/struct: New module., gnunet, 2021/12/25
- [gnunet-scheme] 01/49: Rename messge type 156., gnunet, 2021/12/25
- [gnunet-scheme] 06/49: dht/client: Implement message verifiers., gnunet, 2021/12/25
- [gnunet-scheme] 02/49: bv-slice: Support signed integers., gnunet, 2021/12/25
- [gnunet-scheme] 05/49: Define block types., gnunet, 2021/12/25
- [gnunet-scheme] 03/49: netstruct/procedural: Support signed integers., gnunet, 2021/12/25
- [gnunet-scheme] 08/49: examples: Consider extending the web interface with other services., gnunet, 2021/12/25
- [gnunet-scheme] 07/49: dht/client: Implement reconnecting., gnunet, 2021/12/25
- [gnunet-scheme] 09/49: examples/web: Connect to the DHT service., gnunet, 2021/12/25
- [gnunet-scheme] 10/49: dht/client: Register new get operations for processing., gnunet, 2021/12/25