records: New API for record types, specialised to bytevector slices.

This simplifies many record definitions and is less prone to errors
-- if there is an error in the generation code, it will likely
impact multiple record types, so tests for one record type also
partially test other record types.

It also reduces the amount of code to be written -- reducing
boilerplate, in other words.

* gnu/gnunet/utils/records.scm: New module.
* Makefile.am (modules): Add it.
* gnu/gnunet/cadet/client.scm: Use it.
* gnu/gnunet/hashcode.scm: Likewise.
* gnu/gnunet/fs/uri.scm: Likewise.

5 files changed, 310 insertions, 100 deletions

diff --git a/Makefile.am b/Makefile.am
index 1c9fbe3..a0437f4 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -68,6 +68,7 @@ modules = \
   gnu/gnunet/utils/cut-syntax.scm \
   gnu/gnunet/utils/netstruct.scm \
   gnu/gnunet/utils/platform-enum.scm \
+  gnu/gnunet/utils/records.scm \
   gnu/gnunet/utils/tokeniser.scm \
   \
   gnu/gnunet/block.scm \
diff --git a/gnu/gnunet/cadet/client.scm b/gnu/gnunet/cadet/client.scm
index 7306cb4..970c75a 100644
--- a/gnu/gnunet/cadet/client.scm
+++ b/gnu/gnunet/cadet/client.scm
@@ -1,6 +1,6 @@
 ;#!r6rs
 ;; This file is part of Scheme-GNUnet.
-;; Copyright © 2022 GNUnet e.V.
+;; Copyright © 2022--2023 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
@@ -80,19 +80,19 @@
                 sizeof %sizeof read% r% s% define-analyser analyse
                 construct =>! =>slice!)
           (only (gnu gnunet utils bv-slice)
-                make-slice/read-write slice-copy/read-only slice-length
-                slice-copy! slice-slice)
+                slice-copy/read-only slice-length
+                slice-copy! slice-slice slice-contents-equal?)
           (only (gnu gnunet utils hat-let)
                 let^)
           (only (rnrs base)
-                begin define lambda assert quote cons apply values
-                case else = define-syntax + expt - let and >
-                not if < append list)
+                begin define lambda assert apply values
+                = + expt - let and > not if < list quote)
           (only (rnrs control)
                 when)
           (only (pfds bbtrees)
                 bbtree-set make-bbtree bbtree-ref)
           (only (rnrs records syntactic) define-record-type)
+          (only (gnu gnunet utils records) define-record-type*)
           (only (ice-9 control) let/ec)
           (only (ice-9 match) match)
           (only (guile) define* error)
@@ -370,20 +370,25 @@
           rest message-queue (loop:terminal-condition loop)
           (cut k/reconnect! channel-number->channel-map)))))
 
-    (define-record-type (<cadet-address> make-cadet-address cadet-address?)
-      (fields (immutable peer cadet-address-peer)
-              (immutable port cadet-address-port))
-      (protocol (lambda (%make)
-                  "Make a CADET address for contacting the peer @var{peer}
+    (define-record-type* (<cadet-address> cadet-address?)
+      #:constructor (make-cadet-address
+                     "Make a CADET address for contacting the peer @var{peer}
 (a readable bytevector slice containing a @code{/peer-identity}) at port
 @var{port} (a readable bytevector slice containing a @code{/hashcode:512}).
 The slices @var{peer} and @var{port} are copied, so future changes to them
-do not have any impact on the cadet address."
-                  (lambda (peer port)
-                    (assert (= (sizeof /peer-identity '()) (slice-length peer)))
-                    (assert (= (sizeof /hashcode:512 '()) (slice-length port)))
-                    (%make (slice-copy/read-only peer)
-                           (slice-copy/read-only port))))))
+do not have any impact on the cadet address.")
+      #:field (peer #:getter cadet-address-peer
+                    #:predicate (lambda (peer)
+                                  (= (sizeof /peer-identity '())
+                                     (slice-length peer)))
+                    #:preprocess slice-copy/read-only
+                    #:equality slice-contents-equal?)
+      #:field (query #:getter cadet-address-port
+                     #:predicate (lambda (port)
+                                   (= (sizeof /hashcode:512 '())
+                                      (slice-length port)))
+                     #:preprocess slice-copy/read-only
+                     #:equality slice-contents-equal?))
 
     (define* (construct-local-channel-create cadet-address channel-number
                                              #:optional (options 0))
diff --git a/gnu/gnunet/fs/uri.scm b/gnu/gnunet/fs/uri.scm
index 88cdb56..8e0200d 100644
--- a/gnu/gnunet/fs/uri.scm
+++ b/gnu/gnunet/fs/uri.scm
@@ -1,6 +1,6 @@
 ;#!r6rs
 ;;   This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
-;;   Copyright (C) 2003--2014, 2020, 2022 GNUnet e.V.
+;;   Copyright (C) 2003--2014, 2020, 2022--2023 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
@@ -84,7 +84,6 @@
           chk-uri? make-chk-uri chk-uri-file-length chk-uri-chk
           chk-uri-parse)
   (import (rnrs base)
-          (rnrs records syntactic)
           (gnu gnunet hashcode)
           (gnu gnunet hashcode-ascii)
           (only (gnu gnunet fs struct) /content-hash-key)
@@ -92,59 +91,55 @@
           (only (guile) make-regexp regexp-exec)
           (only (ice-9 regex) match:substring)
           (only (srfi srfi-2) and-let*)
-          (only (gnu gnunet netstruct syntactic)
-                define-analyser s%))
+          (only (gnu gnunet netstruct syntactic) s%)
+          (only (gnu gnunet utils records)
+                define-record-type*))
 
   ;; Size of the individual blocks used for file-sharing.
   ;; TODO: what is the proper place to define this constant
   #;(define DBLOCK_SIZE (* 32 1024))
 
   ;; Content hash key
-  (define-record-type (<content-hash-key> %make-content-hash-key
-                                          content-hash-key?)
-    (fields ;; Hash of the original content, used for encryption.
-            ;; Of type <hashcode:512>.
-            (immutable key content-hash-key-key)
-            ;; Hash of the encrypted content, used for querying.
-            ;; Of type <hashcode:512>
-            (immutable query content-hash-key-query)))
-
-  (define (make-content-hash-key key query)
-    "Construct a <content-hash-key>"
-    (assert (hashcode:512? key))
-    (assert (hashcode:512? query))
-    (%make-content-hash-key key query))
-
-  (define-analyser make-content-hash-key/share /content-hash-key
-    "Construct a <content-hash-key> corresponding to the
+  (define-record-type* (<content-hash-key> content-hash-key?)
+    #:constructor (make-content-hash-key "Construct a <content-hash-key>")
+    #:network-structure /content-hash-key
+    #:analyse (make-content-hash-key/share
+               "Construct a <content-hash-key> corresponding to the
 @code{/content-hash-key} slice.  The slice may not be modified
-while the content hash key is in use."
-    (make-content-hash-key
-     (make-hashcode:512/share (s% key))
-     (make-hashcode:512/share (s% query))))
+while the content hash key is in use.")
+    ;; Hash of the original content, used for encryption.
+    #:field (key #:getter content-hash-key-key
+                 #:predicate hashcode:512?
+                 #:analyse make-hashcode:512/share
+                 #:network-structure-select (s% key))
+    ;; Hash of the encrypted content, used for querying.
+    #:field (query #:getter content-hash-key-query
+                   #:predicate hashcode:512?
+                   #:analyse make-hashcode:512/share
+                   #:network-structure-select (s% query)))
 
   ;; Information needed to retrieve a file (content-hash-key
   ;; plus file size)
-  (define-record-type (<chk-uri> %make-chk-uri chk-uri?)
-    (fields ;; Total size of the file referred to in bytes.
-            (immutable file-length chk-uri-file-length)
-            ;; Query and key of the top GNUNET_EC_IBlock.
-            ;; Of type <content-hash-key>.
-            (immutable chk chk-uri-chk)))
+  (define-record-type* (<chk-uri> chk-uri?)
+    #:constructor (make-chk-uri "Make a chk-URI")
+    ;; Total size of the file referred to in bytes.
+    #:field (file-length #:getter chk-uri-file-length
+                         #:predicate
+                         (lambda (n)
+                           (and (exact? file-length)
+                                (integer? file-length)
+                                (<= 0 file-length)
+                                (< file-length file-length-limit)))
+                         #:equality =)
+    ;; Query and key of the top GNUNET_EC_IBlock.
+    ;; Of type <content-hash-key>.
+    #:field (chk #:getter chk-uri-chk
+                 #:predicate content-hash-key?))
 
   ;; TODO: is this limitation on file size
   ;; merely a limit of the implementation?
   (define file-length-limit (expt 2 64))
 
-  (define (make-chk-uri file-length chk)
-    "Make a chk-URI"
-    (assert (and (exact? file-length)
-                 (integer? file-length)))
-    (assert (and (<= 0 file-length)
-                 (< file-length file-length-limit)))
-    (assert (content-hash-key? chk))
-    (%make-chk-uri file-length chk))
-
   ;; TODO: location URIs, ksk URIs?
   ;; Why does GNUnet have location URIs?
 
@@ -163,7 +158,7 @@ error."
                    (query-hashcode (ascii->hashcode query-match))
                    (size (string->number size-match 10))
                    (size-ok (< size file-length-limit)))
-          (%make-chk-uri size
-                         (%make-content-hash-key key-hashcode
-                                                 query-hashcode)))))))
+          (make-chk-uri size
+                        (make-content-hash-key key-hashcode
+                                               query-hashcode)))))))
 
diff --git a/gnu/gnunet/hashcode.scm b/gnu/gnunet/hashcode.scm
index 2137755..d1b9c6b 100644
--- a/gnu/gnunet/hashcode.scm
+++ b/gnu/gnunet/hashcode.scm
@@ -1,6 +1,6 @@
 ;#!r6rs
 ;;   This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
-;;   Copyright (C) 2006--2020, 2022 GNUnet e.V.
+;;   Copyright (C) 2006--2020, 2022--2023 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
@@ -29,7 +29,10 @@
           copy-hashcode:512 copy-hashcode:256)
   (import (rnrs base)
           (gnu gnunet utils bv-slice)
-          (rnrs records syntactic))
+          (only (gnu gnunet hashcode struct)
+                /hashcode:512 /hashcode:256)
+          (only (gnu gnunet utils records)
+                define-record-type*))
 
   (define hashcode:512-bit-length 512)
   (define hashcode:256-bit-length 256)
@@ -38,51 +41,35 @@
 
   ;; A 512-bit hashcode.  These are the default length for GNUnet,
   ;; using SHA-512.
-  (define-record-type (<hashcode:512> make-hashcode:512/share hashcode:512?)
-    (fields (immutable slice hashcode:512->slice))
-    (opaque #t)
-    (sealed #t)
-    (protocol
-     (lambda (%make)
-       (lambda (slice)
-         "Make a hashcode, containing @var{slice} (a readable
+  (define-record-type* (<hashcode:512> hashcode:512?)
+    #:network-structure /hashcode:512
+    #:read-only-slice-wrapper #true
+    #:unwrap hashcode:512->slice
+    #:constructor (make-hashcode:512/share
+                   "Make a hashcode, containing @var{slice} (a readable
 @code{/hashcode:512} bytevector slice).  @var{slice} may not be mutated
-while the constructed hashcode is in use."
-         (assert (= (slice-length slice) hashcode:512-u8-length))
-         (%make (slice/read-only slice))))))
-
-  (define (make-hashcode:512 slice)
-    "Make a hashcode, containing @var{slice} (a readable @code{/hashcode:512}
-bytevector slice).  @var{slice} may not be mutated while the constructed
-hashcode is in use."
-    (make-hashcode:512/share (slice-copy/read-only slice)))
-
-  (define (copy-hashcode:512 hashcode:512)
-    "Make a copy of the hashcode:512 @var{hashcode:512}.  This can be useful if
+while the constructed hashcode is in use.")
+    #:constructor/copy make-hashcode:512
+    #:copy (copy-hashcode:512
+            "Make a copy of the hashcode:512 @var{hashcode:512}.  This can be useful if
 the slice used during the construction of @var{hashcode:512} is potentially
-going to be mutated while a hashcode will still be in use."
-    (make-hashcode:512 (hashcode:512->slice hashcode:512)))
+going to be mutated while a hashcode will still be in use."))
 
   ;; A 256-bit hashcode.  Used under special conditions, like when space
   ;; is critical and security is not impacted by it.
-  (define-record-type (<hashcode:256> make-hashcode:256/share hashcode:256?)
-    (fields (immutable slice hashcode:256->slice))
-    (opaque #t)
-    (sealed #t)
-    (protocol
-     (lambda (%make)
-       (lambda (slice)
-         "Make a short hashcode, containing @var{slice} (a readable
+  (define-record-type* (<hashcode:256> hashcode:256?)
+    #:network-structure /hashcode:256
+    #:read-only-slice-wrapper #true
+    #:unwrap hashcode:256->slice
+    #:constructor (make-hashcode:256/share
+                   "Make a short hashcode, containing @var{slice} (a readable
 @code{/hashcode:256} bytevector slice).  @var{slice} may not be mutated
-while the constructed short hashcode is in use."
-         (assert (= (slice-length slice) hashcode:256-u8-length))
-         (%make (slice/read-only slice))))))
-
-  (define (copy-hashcode:256 hashcode:256)
-    "Make a copy of the hashcode:256 @var{hashcode:256}.  This can be useful if
+while the constructed short hashcode is in use.")
+    #:constructor/copy make-hashcode:256
+    #:copy (copy-hashcode:256
+            "Make a copy of the hashcode:256 @var{hashcode:256}.  This can be useful if
 the slice used during the construction of @var{hashcode:256} is potentially
-going to be mutated while a hashcode will still be in use."
-    (make-hashcode:256 (hashcode:256->slice hashcode:256)))
+going to be mutated while a hashcode will still be in use."))
 
   (define (bv->hashcode:512 bv)
     "Read a hashcode from a bytevector (deprecated)."
diff --git a/gnu/gnunet/utils/records.scm b/gnu/gnunet/utils/records.scm
new file mode 100644
index 0000000..a4cefd8
--- /dev/null
+++ b/gnu/gnunet/utils/records.scm
@@ -0,0 +1,222 @@
+;; This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
+;; Copyright (C) 2023 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-library (gnu gnunet utils records)
+  (export define-record-type*)
+  ;; keyword? cannot be used from (srfi srfi-88) because that sets
+  ;; a reader option.
+  (import (only (guile) define* keyword? error define-values pk)
+          (only (ice-9 match) match)
+          (only (rnrs base)
+                begin define lambda define-syntax cons quasiquote quote unquote
+                unquote-splicing apply reverse append null? eq? and not if
+                string? values map assert car cdr cadr cddr let or pair?)
+          (only (rnrs control) when unless)
+          (only (rnrs syntax-case)
+                syntax quasisyntax unsyntax unsyntax-splicing syntax-case
+                syntax->datum identifier? generate-temporaries)
+          (only (rnrs records syntactic) define-record-type)
+          (only (srfi srfi-1) assoc)
+          ;; in generated code
+          (only (rnrs base) =)
+          (only (gnu gnunet netstruct syntactic)
+                define-analyser sizeof)
+          (only (gnu gnunet utils bv-slice)
+                slice? slice-readable? slice-length
+                slice-contents-equal? slice/read-only
+                slice-copy/read-only))
+  (begin
+    (define unset (cons #false #false))
+
+    (define* (process fields^ <type> type?
+                      #:key
+                      (constructor unset)
+                      (constructor/copy unset)
+                      (read-only-slice-wrapper #false)
+                      (equality unset)
+                      (analyse unset)
+                      (copy unset)
+                      (unwrap unset)
+                      (network-structure unset))
+      (define fields*
+        (match (syntax->datum read-only-slice-wrapper)
+          (#true
+           (unless (null? fields^)
+             (error "fields may not be manually defined when #:read-only-slice-wrapper is #true"))
+           (when (eq? network-structure unset)
+             (error "when #:read-only-slice-wrapper is set, #:network-structure must be defined"))
+           (when (eq? unwrap unset)
+             (error "when #:read-only-slice-wrapper is set, #:unwrap must be defined"))
+           `((,#'slice
+              (#:getter . ,unwrap)
+              (#:predicate . ,#`(lambda (s)
+                                  (and (slice? s)
+                                       (slice-readable? s)
+                                       (= (slice-length s)
+                                          (sizeof #,network-structure '())))))
+              (#:preprocess . ,#'slice/read-only)
+              (#:equality . ,#'slice-contents-equal?))))
+          (#false fields^)))
+      (when (and (not (eq? unwrap unset))
+                 (eq? read-only-slice-wrapper unset))
+        (error "#:unwrap can only be used in combination with #:read-only-slice-wrapper #true"))
+      ;; s: unset, or syntax of the form '(identifier "docstring")',
+      ;; or syntax of the form 'identifier'.
+      ;;
+      ;; Return types: (unset | identifier), syntax
+      (define (maybe-identifier-maybe-with-docstring s)
+        (if (eq? s unset)
+            (values unset #false)
+            (syntax-case s ()
+              ((id docstring)
+               (and (identifier? #'id) (string? (syntax->datum #'docstring)))
+               (values #'id #'docstring))
+              (id
+               (identifier? #'id)
+               (values #'id #false)))))
+      (define-values (constructor** constructor-docstring)
+        (maybe-identifier-maybe-with-docstring constructor))
+      (define constructor*
+        (if (eq? constructor** unset)
+            ;; define-record-type always requires a constructor
+            (car (generate-temporaries '(stuff)))
+            constructor**))
+      (define-values (equality* equality-docstring)
+        (maybe-identifier-maybe-with-docstring equality))
+      (define-values (analyse* analyse-docstring)
+        (maybe-identifier-maybe-with-docstring analyse))
+      (define-values (copy* copy-docstring)
+        ;; The generated code for 'constructor/copy*' expects
+        ;; a 'copy' procedure to exist.
+        (if (and (eq? copy unset) (not (eq? constructor/copy unset)))
+            (car (generate-temporaries '(copy)))
+            (maybe-identifier-maybe-with-docstring copy)))
+      (define-values (constructor/copy* constructor/copy-docstring)
+        (maybe-identifier-maybe-with-docstring constructor/copy))
+      (define (field-name field) ; -> identifier
+        (car field))
+      (define (field-verify field)
+        (if (field-set field #:predicate)
+            #`(assert (#,(field-ref field #:predicate) #,(field-name field)))
+            #'#true)) ; exact value doesn't matter
+      (define (field-compare field this that)
+        (define g (field-ref field #:getter)) ; always defined
+        #`(#,(field-ref field #:equality) ; sometimes undefined
+           (#,g #,this)
+           (#,g #,that)))
+      (define (field->analyse-fragment field)
+        ;; TODO: #:network-structure-read, e.g. for when it's just a number?
+        #`(#,(field-ref field #:analyse) ; sometimes undefined
+           #,(field-ref field #:network-structure-select))) ; sometimes undefined
+      (define (field-clause field)
+        #`(immutable #,(field-name field)
+                     #,(field-ref field #:getter)))
+      ;; TODO bail out if unrecognised field settings
+      (define (field-preprocess field)
+        (if (field-set field #:preprocess)
+            #`(#,(field-ref field #:preprocess) #,(field-name field))
+            (field-name field)))
+      #`(begin
+          (define-record-type (#,<type> #,constructor* #,type?)
+            (fields #,@(map field-clause fields*))
+            (protocol
+             (lambda (%make)
+               (lambda #,(map field-name fields*)
+                 #,constructor-docstring
+                 #,@(map field-verify fields*)
+                 (%make #,@(map field-preprocess fields*)))))
+            (sealed #true)
+            (opaque #true))
+          #,@(if (eq? equality* unset)
+                 #'()
+                 #`((define (#,equality* this that)
+                      #,equality-docstring
+                      (and #,@(map (lambda (f) (field-compare f #'this #'that)) fields*)))))
+          #,@(if (eq? analyse* unset)
+                 #'()
+                 #`((define-analyser #,analyse* #,network-structure
+                      #,analyse-docstring
+                      (#,constructor*
+                       #,@(map field->analyse-fragment fields*)))))
+          #,@(if (eq? copy* unset)
+                 #'()
+                 ;; Note: support for read-only-slice-wrapper = unset can be
+                 ;; implemented if needed with some work.
+                 (begin
+                   (assert (eq? #true (syntax->datum read-only-slice-wrapper)))
+                   #`((define (#,copy* slice)
+                       (#,constructor*
+                        (slice-copy/read-only
+                         (#,(field-ref (car fields*) #:getter) slice)))))))
+          #,@(if (eq? constructor/copy* unset)
+                 #'()
+                 ;; Note: likewise.
+                 (begin
+                   (assert (eq? #true (syntax->datum read-only-slice-wrapper)))
+                   #`((define (#,constructor/copy* object)
+                        #,constructor/copy-docstring
+                        (#,copy* (#,constructor* object))))))))
+
+    (define (field-ref field keyword)
+      (match (assoc keyword (cdr field))
+        ((key . value) value)
+        (_ (pk 'field-ref field keyword)
+           (error "missing keyword in field"))))
+
+    (define (field-set field keyword)
+      (pair? (assoc keyword (cdr field))))
+
+    (define (decompose-field-syntax stuff)
+      (define (decompose-field-syntax-stuff* rest accumulated)
+        (syntax-case rest ()
+          ;; Assuming no duplicates, the order of the keyword arguments
+          ;; doesn't matter, so no reversal needed here.
+          (() accumulated)
+          ((keyword value . rest*)
+           (keyword? (syntax->datum #'keyword))
+           (decompose-field-syntax-stuff*
+            #'rest*
+            `((,(syntax->datum #'keyword) . ,#'value) ,@accumulated)))))
+      (syntax-case stuff ()
+        ((name . rest)
+         (cons #'name (decompose-field-syntax-stuff* #'rest '())))))
+
+    (define (decompose-syntax s accumulated-fields accumulated-arguments k . k*)
+      (syntax-case s ()
+        ;; order of keyword arguments doesn't matter, so no reversal there.
+        ;; (it is assumed there are no duplicates)
+        (() (apply k (reverse accumulated-fields)
+                   (append k* accumulated-arguments)))
+        ((#:field stuff . rest)
+         (apply decompose-syntax
+                #'rest
+                (cons (decompose-field-syntax #'stuff) accumulated-fields)
+                accumulated-arguments
+                k k*))
+        ((keyword value . rest) ; not #:field
+         (keyword? (syntax->datum #'keyword))
+         (apply decompose-syntax
+                #'rest
+                accumulated-fields
+                `(,(syntax->datum #'keyword) ,#'value ,@accumulated-arguments)
+                k k*))))
+
+    (define-syntax define-record-type*
+      (lambda (s)
+        (syntax-case s ()
+          ((_ (<type> type?) . stuff)
+           (decompose-syntax #'stuff '() '() process #'<type> #'type?)))))))