[gnunet-scheme] branch master updated (671b95d -> 785d738)

[gnunet]

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 671b95d  dht/client: Fix typo: € -> e.
     new 2a263aa  records: Support keyword arguments in the constructor.
     new 785d738  dht/client: Rewrite <insertion> in terms of cisw.

The 2 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:
 doc/distributed-hash-table.tm    | 14 ++++-----
 examples/web.scm                 |  4 +--
 gnu/gnunet/dht/client.scm        | 52 +++++++++++++++++++---------------
 gnu/gnunet/utils/records.scm     | 61 ++++++++++++++++++++++++++++++++++------
 tests/distributed-hash-table.scm | 19 ++++---------
 5 files changed, 97 insertions(+), 53 deletions(-)

diff --git a/doc/distributed-hash-table.tm b/doc/distributed-hash-table.tm
index da57120..837c45e 100644
--- a/doc/distributed-hash-table.tm
+++ b/doc/distributed-hash-table.tm
@@ -59,18 +59,18 @@
   </explain>
 
   <\explain>
-    <scm|(datum-\<gtr\>insertion <var|datum>
-    #:desired-replication-level)><index|datum-\<gtr\>insertion>
+    <scm|(make-insertion <var|datum> 
#:desired-replication-level)><index|make-insertion>
   <|explain>
     Make an insertion object for inserting the datum <var|datum>, desiring a
     replication level <var|desired-replication-level> (see
     <reference|replication levels???>)<todo|various options>.
 
-    The datum and desired replication level can be recovered with the
-    accessors <scm|insertion-\<gtr\>datum><index|insertion-\<gtr\>datum> and
-    
<var|insertion-desired-replication-level><index|insertion-desired-replication-level>.
-    It can be tested if an object is an insertion object with the predicate
-    <scm|insertion?><index|insertion?>.
+    Insertions are <acronym|cisw> (<reference|cisw>) ojects and as such the
+    procedures <scm|insertion-\<gtr\>datum><index|insertion-\<gtr\>datum>,
+    
<scm|insertion-desired-replication-level><index|insertion-desired-replication-level>,
+    <scm|insertion?><index|insertion?>, <scm|make-insertion>,
+    <scm|make-insertion/share><index|make-insertion/share> and
+    <scm|insertion=?><index|insertion=?> have the usual semantics.
   </explain>
 
   <\explain>
diff --git a/examples/web.scm b/examples/web.scm
index 9f233aa..4c2d2ff 100644
--- a/examples/web.scm
+++ b/examples/web.scm
@@ -1,5 +1,5 @@
 ;; This file is part of scheme-GNUnet.
-;; Copyright © 2021, 2022 GNUnet e.V.
+;; Copyright © 2021--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
@@ -154,7 +154,7 @@ for success is used."
 (define (process-put-dht dht-server parameters)
   ;; TODO replication level, expiration ...
   (dht:put! dht-server
-           (dht:datum->insertion
+           (dht:make-insertion/share
             (dht:make-datum/share
              (string->number (assoc-ref parameters "type"))
              (decode/key (assoc-ref parameters "key-encoding")
diff --git a/gnu/gnunet/dht/client.scm b/gnu/gnunet/dht/client.scm
index 27530df..1b86d6d 100644
--- a/gnu/gnunet/dht/client.scm
+++ b/gnu/gnunet/dht/client.scm
@@ -42,7 +42,8 @@
 
          make-datum make-datum/share datum? datum-type datum-key datum-value
          datum-expiration datum=?
-         datum->insertion insertion? insertion->datum
+         make-insertion make-insertion/share insertion? insertion->datum
+         insertion=?
          insertion-desired-replication-level
          make-query query? query-type query-key query-desired-replication-level
          datum->search-result search-result? search-result->datum
@@ -266,29 +267,34 @@ the constructor."
       (%make-datum/share type key value expiration))
 
     ;; A request to insert something in the DHT.
-    (define-record-type (<insertion> datum->insertion insertion?)
-      (fields (immutable datum insertion->datum)
-             (immutable desired-replication-level
-                        insertion-desired-replication-level))
-      (protocol
-       (lambda (%make)
-        (lambda* (datum #:key (desired-replication-level 3)) ; TODO defaults
-          "Make an insertion object for inserting the datum @var{datum},
+    (define-record-type* (<insertion> insertion?)
+      #:copy (copy-insertion
+             "Make a copy of the insertion, such that modifications to the
+slices in the old insertion do not impact the new insertion.")
+      #:constructor/copy %make-insertion
+      #:constructor %make-insertion/share
+      #:equality insertion=?
+      #:field (datum #:copy copy-datum
+                    #:equality datum=?
+                    #:getter insertion->datum
+                    #:preprocess validate-datum)
+      #:field (desired-replication-leval
+              #:copy identity
+              #:equality =
+              #:getter insertion-desired-replication-level
+              #:preprocess bound-replication-level))
+
+    (define* (make-insertion datum #:key (desired-replication-level 3)) ; TODO 
defaults
+      "Make an insertion object for inserting the datum @var{datum},
 desiring a replication level @var{desired-replication-level} (see ??).
 
-The datum and desired replication level can be recovered with the accessors
-@var{insertion->datum} and @var{insertion-desired-replication-level}. It can
-be tested if an object is an insertion object with the predicate
-@code{insertion?}."
-          (%make (validate-datum datum)
-                 (bound-replication-level desired-replication-level))))))
-
-    (define (copy-insertion old)
-      "Make a copy of the insertion @var{old}, such that modifications to the
-slices in @var{old} do not impact the new insertion."
-      (datum->insertion (copy-datum (insertion->datum old))
-                       #:desired-replication-level
-                       (insertion-desired-replication-level old)))
+Insertions are cisw (?) ojects and as such the procedures
+@code{insertion->datum}, @code{insertion-desired-replication-level},
+@code{insertion?}, @code{make-insertion}, @code{make-insertion/share}
+and @code{insertion=?} have the usual semantics."
+      (%make-insertion datum desired-replication-level))
+    (define* (make-insertion/share datum #:key (desired-replication-level 3))
+      (%make-insertion/share datum desired-replication-level))
 
     (define-record-type (<query> make-query query?)
       (fields (immutable type query-type)
@@ -508,7 +514,7 @@ currently unsupported."
       (define value (slice-slice message (sizeof /:msg:dht:client:put '())))
       (analyse /:msg:dht:client:put header
               (values
-               (datum->insertion
+               (make-insertion/share
                 (make-datum/share
                  (r% type)
                  (make-hashcode:512/share (s% key))
diff --git a/gnu/gnunet/utils/records.scm b/gnu/gnunet/utils/records.scm
index a3839ff..0935efb 100644
--- a/gnu/gnunet/utils/records.scm
+++ b/gnu/gnunet/utils/records.scm
@@ -19,19 +19,20 @@
   (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 syntax-error)
+  (import (only (guile) define* lambda* keyword? error define-values pk 
syntax-error)
          (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?
-               => let*)
+               => let* length)
          (only (rnrs control) when unless)
          (only (rnrs syntax-case)
                syntax quasisyntax unsyntax unsyntax-splicing syntax-case
-               syntax->datum identifier? generate-temporaries datum->syntax)
+               syntax->datum identifier? generate-temporaries datum->syntax
+               free-identifier=?)
          (only (rnrs records syntactic) define-record-type)
-         (only (srfi srfi-1) assoc)
+         (only (srfi srfi-1) assoc partition)
          ;; in generated code
          (only (rnrs base) =)
          (only (gnu gnunet netstruct syntactic)
@@ -45,6 +46,7 @@
 
     (define* (process fields^ <type> type?
                      #:key
+                     (constructor-keyword-arguments unset)
                      (constructor unset)
                      (constructor/copy unset)
                      (read-only-slice-wrapper #false)
@@ -132,13 +134,56 @@
        #`(#,(field-ref field #:copy) (#,(field-ref field #:getter) #,object)))
 
       ;; The same symbols as in (map field-name fields*), but as different
-      ;; identifiers, to avoid field values from accidentbeing used before they
+      ;; identifiers, to avoid field values from accidentally being used 
before they
       ;; have been preprocessed.  They are equal as symbols, such that
       ;; 'procedure-arguments' and the like produce something legible.
       (define field-names/different
        (map (lambda (f template-id)
               (datum->syntax template-id (syntax->datum (field-name f))))
             fields* (generate-temporaries fields*)))
+      ;; Syntax.  The 'arguments' in the (define* (constructor . arguments) 
...).
+      ;; The idea is that default arguments can be passed with
+      ;;   arguments = (foo #:key (bar 0) ...).
+      (define constructor-keyword-arguments*
+       (if (eq? constructor-keyword-arguments unset)
+           (map field-name fields*)
+           constructor-keyword-arguments))
+      ;; TODO: check that constructor-keyword-arguments
+      ;; contains all the field names.
+      (define constructor-keyword-arguments*/different
+       (let* ((names->different-alist
+               (map cons (map field-name fields*) field-names/different))
+              (replacement
+               (lambda (i)
+                 (let ((matches
+                        (partition (lambda (p)
+                                     (free-identifier=? (car p) i))
+                                   names->different-alist)))
+                   (assert (= (length matches) 1))
+                   (cdr (car matches))))))
+         (let loop ((s constructor-keyword-arguments*)
+                    (bindings #'()))
+           (syntax-case s ()
+             ((keyword . rest)
+              (keyword? #'keyword)
+              #`(keyword . #,(loop #'rest bindings)))
+             ((i . rest)
+              (identifier? #'i)
+              (let ((j (replacement #'i)))
+                #`(#,j . #,(loop #'rest #`(#,@bindings (i #,j))))))
+             (i ; (... . var)
+              (identifier? #'i)
+              (replacement #'i))
+             (((i . value) . rest)
+              ;; 'value' can refer to previous arguments, so add some
+              ;; 'let' bindings to correct for the renaming.  (Untested;
+              ;; there are no users of this at time of writing.)
+              (let ((j (replacement #'i)))
+                #`((#,j (let #,@bindings value))
+                   . #,(loop #'rest #`(#,@bindings (i #,j))))))
+             (() s)
+             (_ (pk s)
+                (error "invalid keyword argument syntax in constructor"))))))
       (define (preprocess-arguments body)
        ;; First, use field-names/different as constructor arguments.
        ;; Otherwise, the preprocessors might accidentally use an
@@ -162,7 +207,7 @@
            (fields #,@(map field-clause fields*))
            (protocol
             (lambda (%make)
-              (lambda #,field-names/different
+              (lambda* #,constructor-keyword-arguments*/different
                 #,constructor-docstring
                 #,@(map field-verify field-names/different fields*)
                 #,(preprocess-arguments
@@ -198,9 +243,9 @@
                                  fields*)))))))
          #,@(if (eq? constructor/copy* unset)
                 #'()
-                #`((define (#,constructor/copy* #,@(map field-name fields*))
+                #`((define* (#,constructor/copy* 
#,@constructor-keyword-arguments*)
                      #,constructor/copy-docstring
-                     (#,copy* (#,constructor*
+                     (#,copy* (#,constructor* ; <--- FIX
                                #,@(map field-name fields*))))))))
 
     (define (field-ref field keyword)
diff --git a/tests/distributed-hash-table.scm b/tests/distributed-hash-table.scm
index 367d530..10e57ab 100644
--- a/tests/distributed-hash-table.scm
+++ b/tests/distributed-hash-table.scm
@@ -254,10 +254,6 @@
         (slice->bytevector (datum-value z))
         (datum-expiration z)))
 
-(define (insertion->sexp z)
-  (list (datum->sexp (insertion->datum z))
-       (insertion-desired-replication-level z)))
-
 (define (search-result->sexp z)
   (list (slice->bytevector (search-result-get-path z))
        (slice->bytevector (search-result-put-path z))
@@ -269,9 +265,6 @@
 (define (search-result=? x y)
   (equal? (search-result->sexp x) (search-result->sexp y)))
 
-(define (insertion=? x y)
-  (equal? (insertion->sexp x) (insertion->sexp y)))
-
 (define (hashcode-independent? x y)
   (slice-independent? (hashcode:512->slice x) (hashcode:512->slice y)))
 
@@ -333,7 +326,7 @@
   (let* ((old-value (make-slice/read-write* 71))
         (old-datum (make-a-datum #:value old-value))
         (old
-         (datum->insertion old-datum #:desired-replication-level (random 8)))
+         (make-insertion/share old-datum #:desired-replication-level (random 
8)))
         (new (copy-insertion old)))
     (and (insertion=? old new)
         (insertion-independent? old new))))
@@ -434,7 +427,7 @@
 ;;; Cancelling, closing the connection, parallelism and multiple
 ;;; in-progress requests are currently untested (TBD and implemented!).
 
-(define i (datum->insertion (make-a-datum) #:desired-replication-level 7))
+(define i (make-insertion/share (make-a-datum) #:desired-replication-level 7))
 
 (define (no-error-handler . e)
   (pk 'e e)
@@ -617,7 +610,7 @@ supported.  When @var{explode} is signalled, the connection 
is closed."
        (define key (round->key round))
        (define value (make-slice/read-write 8))
        (slice-u64-set! value 0 j (endianness little))
-       (datum->insertion (make-datum/share type key value)))
+       (make-insertion/share (make-datum/share type key value)))
      (define (make-a-query type round)
        (define key (round->key round))
        (make-query type key))
@@ -768,7 +761,7 @@ supported.  When @var{explode} is signalled, the connection 
is closed."
        (define value-s (make-slice/read-write (sizeof u64/big '())))
        (slice-u64-set! key-s 0 round (endianness big))
        (slice-u64-set! value-s 0 (value round) (endianness big))
-       (put! server (datum->insertion
+       (put! server (make-insertion/share
                     (make-datum/share type (make-hashcode:512/share key-s) 
value-s)))
        (when (< round (- ROUNDS 1))
         (loop (+ round 1))))
@@ -792,7 +785,7 @@ supported.  When @var{explode} is signalled, the connection 
is closed."
                   ;; The 'found' callback is responsible for cancellation.
                   #:linger? #true))
      (signal-condition! search-defined)
-     (put! server (datum->insertion datum))
+     (put! server (make-insertion/share datum))
      (wait done)
      #true)))
 
@@ -854,7 +847,7 @@ supported.  When @var{explode} is signalled, the connection 
is closed."
        (wait disconnected/condition)
        ;; Insert the datum, such that @var{search} can complete (assuming
        ;; that @var{server} remembered to start the search again!).
-       (put! server (datum->insertion datum))
+       (put! server (make-insertion/share datum))
        (wait found/condition)
        ;; Explicitely cancel 'search' such that it is not cancelled too
        ;; early due to GC.

-- 
To stop receiving notification emails like this one, please contact
gnunet@gnunet.org.