[gnunet-scheme] branch master updated: Simplify structure analysis.

[gnunet]

This is an automated email from the git hooks/post-receive script.

maxime-devos pushed a commit to branch master
in repository gnunet-scheme.

The following commit(s) were added to refs/heads/master by this push:
     new 908fa9d  Simplify structure analysis.
908fa9d is described below

commit 908fa9dfbf95c292b6322935daededec1d8ab8a7
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Tue Dec 20 14:22:15 2022 +0100

    Simplify structure analysis.
    
    * NEWS: Mention new changes.
    * doc/network-structures.tm: Document new macros.
    * gnu/gnunet/cadet/client.scm: Use new macros.
    * gnu/gnunet/dht/client.scm: Likewise.
    * gnu/gnunet/fs/network.scm: Likewise.
    * gnu/gnunet/netstruct/syntactic.scm (r%,s%,analyse,define-analyser):
    New macros.
---
 NEWS                               |   3 +
 doc/network-structures.tm          |  63 ++++++++++++++++++++
 gnu/gnunet/cadet/client.scm        |  42 ++++++--------
 gnu/gnunet/dht/client.scm          | 114 ++++++++++++++++---------------------
 gnu/gnunet/fs/network.scm          |  24 +++-----
 gnu/gnunet/netstruct/syntactic.scm |  38 +++++++++++--
 6 files changed, 174 insertions(+), 110 deletions(-)

diff --git a/NEWS b/NEWS
index d1faba9..4e2a667 100644
--- a/NEWS
+++ b/NEWS
@@ -12,6 +12,9 @@
      in the manual.  These tools have been used to reduce duplication between
      client code of different services, so tests targeting a single service
      automatically also test the other services a bit.
+   - New macro 'analyse' and 'define-analyser', to make using read% and select%
+     less tedious when the type and slice remains the same.  Also, by using the
+     new macros, the code base should now be a bit more readible.
 ** Bugfixes
    - A potential (but unverified) bug with automatic collection is fixed --
      previously, if DHT garbage was found multiple times within a single
diff --git a/doc/network-structures.tm b/doc/network-structures.tm
index d52b3b2..ebda27a 100644
--- a/doc/network-structures.tm
+++ b/doc/network-structures.tm
@@ -177,6 +177,8 @@
   The fields can also be read:
 
   <\scm-code>
+    ;; This example is simplified later!
+
     (read% /:msg:nse:estimate/example '(header size) message) ; 12
 
     (read% /:msg:nse:estimate/example '(header type) message) ; 165
@@ -184,6 +186,67 @@
     (read% /:msg:nse:estimate/example '(size-estimate) message) ; 19.2
   </scm-code>
 
+  Repeating the message type and the slice can be repetitive, so <scm|(gnu
+  gnunet netstruct syntactic)> has a macro to avoid that:
+
+  <\explain>
+    <scm|(analyse <var|type> <var|message> <var|body>
+    <text-dots>)><index|analyse>
+  <|explain>
+    Expand to <scm|<var|body ...>> \ in a context where the syntax parameters
+    <scm|r%> and <scm|s%> (from <scm|(gnu gnunet netstruct syntactic)>) are
+    bound to macros with the following interface:
+
+    <\description>
+      <item*|<scm|(r% <var|field> ...)><index|r%>>Read the field
+      <scm|(<var|field> ...)> of <var|message>. This is to be understood as a
+      literal list, not as a procedure invocation \U neither the list nor
+      <var|field> <text-dots> is evaluated.
+
+      <item*|<scm|(s% <var|field> ...)><index|s%>>Select the field
+      <scm|(field ...)> of <var|message>, where <scm|(field ...)> is
+      interpreted the same way as for <scm|r%>.
+    </description>
+
+    <var|type> and <var|message> can currently be evaluated multiple times.
+    These macros <scm|r%> and <scm|s%> can only be used inside a
+    <scm|analyse> or <scm|define-analyser> construct; in other contexts an
+    exception is raised.
+  </explain>
+
+  Using this macro, the previous example can be simplified to: '
+
+  <\scm-code>
+    ;; 'pk' is for printing the value
+
+    (analyse /:msg:nse:estimate/example message
+
+    \ \ \ \ \ \ \ \ \ (pk (r% header size)) ; 12
+
+    \ \ \ \ \ \ \ \ \ (pk (r% header type)) ; 165
+
+    \ \ \ \ \ \ \ \ \ (pk (r% size-estimate))) ; 19.2
+  </scm-code>
+
+  For very simple 'analysis' procedures, the macro
+  <scm|define-analyser><index|define-analyser> can be useful:
+
+  <\scm-code>
+    ;; 'pk' is for printing the value
+
+    (define-analyser analyse-example /:msg:nse:estimate/example
+
+    \ \ "Put a docstring here"
+
+    \ \ (pk (r% header size)) ; 12
+
+    \ \ (pk (r% header type)) ; 165
+
+    \ \ (pk (r% size-estimate)))
+
+    (analyse-example [...])
+  </scm-code>
+
   <section|Primitive types>
 
   There are a number of pre-defined types.<space|1em>First, there is
diff --git a/gnu/gnunet/cadet/client.scm b/gnu/gnunet/cadet/client.scm
index c37b908..50118fe 100644
--- a/gnu/gnunet/cadet/client.scm
+++ b/gnu/gnunet/cadet/client.scm
@@ -77,7 +77,7 @@
          (only (gnu gnunet mq)
                make-message-queue inject-message!)
          (only (gnu gnunet netstruct syntactic)
-               sizeof select read% set%!)
+               sizeof select read% set%! r% s% define-analyser analyse)
          (only (gnu gnunet utils bv-slice)
                make-slice/read-write slice-copy/read-only slice-length
                slice-copy! slice-slice)
@@ -412,20 +412,13 @@ the CADET addresss @var{cadet-address}, using the channel 
number
        mq (construct-local-channel-create
           (channel-address channel) (channel-channel-number channel))))
 
-    (define (analyse-local-channel-create message)
+    (define-analyser analyse-local-channel-create
+      /:msg:cadet:local:channel:create
       "Return the CADET address, channel number and options corresponding to
 the @code{/:msg:cadet:channel:create} message @var{message}."
-      (define-syntax read*
-       (cut-syntax read% /:msg:cadet:local:channel:create <> message))
-      (define-syntax select*
-       (cut-syntax select /:msg:cadet:local:channel:create <> message))
-      (let^ ((! channel-number (read* '(channel-number)))
-            (! peer (select* '(peer)))
-            (! port (select* '(port)))
-            (! channel-number (read* '(channel-number)))
-            (! options (read* '(options)))
-            (! address (make-cadet-address peer port)))
-           (values address channel-number options)))
+      (values (make-cadet-address (s% peer) (s% port))
+             (r% channel-number)
+             (r% options)))
 
     (define (construct-local-channel-destroy channel-number)
       "Create a @code{/:msg:cadet:channel:destroy} message for closing the
@@ -441,10 +434,11 @@ CADET channel with channel number @var{channel-number}."
       (set* '(channel-number) channel-number)
       s)
 
-    (define (analyse-local-channel-destroy message)
+    (define-analyser analyse-local-channel-destroy
+      /:msg:cadet:local:channel:destroy
       "Return the channel number corresponding to the
 @code{/:msg:cadet:local:channel:destroy} message @var{message}."
-      (read% /:msg:cadet:local:channel:destroy '(channel-number) message))
+      (r% channel-number))
 
     ;; TODO: determine maximum length
     (define %max-cadet-message-size
@@ -474,14 +468,11 @@ CADET channel with channel number @var{channel-number}."
 in the @code{/:msg:cadet:local:data} message @var{message}."
       (define header
        (slice-slice message 0 (sizeof /:msg:cadet:local:data '())))
-      (define-syntax read*
-       (cut-syntax read% /:msg:cadet:local:data <> header))
-      (define-syntax select*
-       (cut-syntax select /:msg:cadet:local:data <> header))
-      (values (read* '(channel-number))
-             (read* '(priority-preference))
-             (slice-slice message
-                          (sizeof /:msg:cadet:local:data '()))))
+      (analyse /:msg:cadet:local:data header
+              (values (r% channel-number)
+                      (r% priority-preference)
+                      (slice-slice message
+                                   (sizeof /:msg:cadet:local:data '())))))
 
     (define (construct-local-acknowledgement channel-number)
       "Create a @code{/:msg:cadet:local:acknowledgement} message,
@@ -498,10 +489,11 @@ identified by @var{channel-number}."
       (set* '(client-channel-number) channel-number)
       s)
 
-    (define (analyse-local-acknowledgement message)
+    (define-analyser analyse-local-acknowledgement
+      /:msg:cadet:local:acknowledgement
       "Return the channel number in the @code{/:msg:cadet:local:data}
 message @var{message}."
-      (read% /:msg:cadet:local:acknowledgement '(client-channel-number) 
message))
+      (r% client-channel-number))
 
     (define (stub . foo)
       (error "todo"))
diff --git a/gnu/gnunet/dht/client.scm b/gnu/gnunet/dht/client.scm
index bfc4bcc..047ca6d 100644
--- a/gnu/gnunet/dht/client.scm
+++ b/gnu/gnunet/dht/client.scm
@@ -88,7 +88,8 @@
                run-loop spawn-server-loop)
          (only (guile)
                pk define-syntax-rule define* lambda* error
-               ->bool and=>)
+               ->bool and=> define-syntax-parameter syntax
+               syntax-parameterize)
          (only (ice-9 atomic)
                make-atomic-box)
          (only (ice-9 match)
@@ -106,7 +107,7 @@
          (only (gnu gnunet message protocols)
                message-type)
          (only (gnu gnunet netstruct syntactic)
-               read% sizeof set%! select)
+               read% sizeof set%! select r% s% analyse define-analyser)
          (only (gnu gnunet utils bv-slice)
                slice-length slice/read-only make-slice/read-write slice-copy!
                slice-slice verify-slice-readable slice-copy/read-write
@@ -501,83 +502,66 @@ result object @var{search-result}, with @var{unique-id} 
as ‘unique id’"
            (slice-copy! value rest)
            message))
 
-    (define (analyse-client-get message)
+    (define-analyser analyse-client-get /:msg:dht:client:get
       "Return the query object, the unique id and the options corresponding to
 the @code{/:msg:dht:client:result} message @var{message}.  Xqueries are
 currently unsupported."
-      (let^ ((! type (read% /:msg:dht:client:get '(type) message))
-            (! key (make-hashcode:512/share
-                    (select /:msg:dht:client:get '(key) message)))
-            (! desired-replication-level
-               (read% /:msg:dht:client:get '(desired-replication-level) 
message))
-            (! unique-id (read% /:msg:dht:client:get '(unique-id) message))
-            (! options (read% /:msg:dht:client:get '(options) message))
-            (! query
-               (make-query type key #:desired-replication-level
-                           desired-replication-level)))
-           (values query unique-id options)))
-
-    (define (analyse-client-get-stop message)
+      (values (make-query (r% type) (make-hashcode:512/share (s% key))
+                         #:desired-replication-level
+                         (r% desired-replication-level))
+             (r% unique-id)
+             (r% options)))
+
+    (define-analyser analyse-client-get-stop /:msg:dht:client:get:stop
       "Return the unique id and the key corresponding to the
 @code{/:msg:dht:client:stop} message @var{message}."
-      (values (read% /:msg:dht:client:get:stop '(unique-id) message)
-             (select /:msg:dht:client:get:stop '(key) message)))
+      (values (r% unique-id) (s% key)))
 
     (define (analyse-client-put message)
       "Return the insertion object and options corresponding to the
 @code{/:msg:dht:client:put} message @var{message}."
-      (let^ ((! header (slice-slice message 0 (sizeof /:msg:dht:client:put 
'())))
-            (! type (read% /:msg:dht:client:put '(type) header))
-            (! key
-               (make-hashcode:512/share
-                (select /:msg:dht:client:put '(key) header)))
-            (! value (slice-slice message (sizeof /:msg:dht:client:put '())))
-            (! desired-replication-level
-               (read% /:msg:dht:client:put '(desired-replication-level) 
header))
-            (! expiration
-               (read% /:msg:dht:client:put '(expiration) header))
-            (! options
-               (read% /:msg:dht:client:put '(option) header))
-            (! datum (make-datum type key value #:expiration expiration))
-            (! insertion
-               (datum->insertion datum #:desired-replication-level
-                                 desired-replication-level)))
-           (values insertion options)))
+      (define header (slice-slice message 0 (sizeof /:msg:dht:client:put '())))
+      (define value (slice-slice message (sizeof /:msg:dht:client:put '())))
+      (analyse /:msg:dht:client:put header
+              (values
+               (datum->insertion
+                (make-datum
+                 (r% type)
+                 (make-hashcode:512/share (s% key))
+                 value
+                 #:expiration (r% expiration))
+                #:desired-replication-level (r% desired-replication-level))
+               (r% option))))
 
     (define (analyse-client-result message)
       "Return search result object and unique id for the
 @code{/:msg:dht:client:result} message @var{message}."
-      (let^ ((! message (slice/read-only message))
-            (! size/header (sizeof /:msg:dht:client:result '()))
-            (! header (slice-slice message 0 size/header))
-            (! rest (slice/read-only message size/header))
-            (! put-path-length
-               (read% /:msg:dht:client:result '(put-path-length) header))
-            (! get-path-length
-               (read% /:msg:dht:client:result '(get-path-length) header))
-            (! size/path-element (sizeof /dht:path-element '()))
-            (! put-path
-               (slice-slice rest 0 (* size/path-element put-path-length)))
-            (! get-path
-               (slice-slice rest (* size/path-element put-path-length)
-                            (* size/path-element get-path-length)))
-            (! value
-               (slice-slice rest (* (sizeof /dht:path-element '())
-                                    (+ put-path-length get-path-length))))
-            (! datum
+      (define message* (slice/read-only message))
+      (define size/header (sizeof /:msg:dht:client:result '()))
+      (define header (slice-slice message* 0 size/header))
+      (define rest (slice-slice message* size/header))
+      (define size/path-element (sizeof /dht:path-element '()))
+      (analyse
+       /:msg:dht:client:result
+       header
+       (values (datum->search-result
                (make-datum
-                (read% /:msg:dht:client:result '(type) header)
-                (make-hashcode:512/share
-                 (select /:msg:dht:client:result '(key) header))
-                value
-                #:expiration
-                (read% /:msg:dht:client:result '(expiration) header)))
-            (! search-result
-               (datum->search-result
-                datum #:get-path get-path #:put-path put-path))
-            (! unique-id (read% /:msg:dht:client:result '(unique-id) header)))
-           (values search-result unique-id)))
-
+                (r% type)
+                (make-hashcode:512/share (s% key))
+                ;; 'value'
+                (slice-slice rest
+                             (* size/path-element
+                                (+ (r% put-path-length)
+                                   (r% get-path-length))))
+                #:expiration (r% expiration))
+               #:get-path
+               (slice-slice rest
+                            (* size/path-element (r% put-path-length))
+                            (* size/path-element (r% get-path-length)))
+               #:put-path
+               (slice-slice rest 0
+                            (* size/path-element (r% put-path-length))))
+              (r% unique-id))))
     
 
     ;; New operations are communicated to the main event loop
diff --git a/gnu/gnunet/fs/network.scm b/gnu/gnunet/fs/network.scm
index 4b3b01c..65648a8 100644
--- a/gnu/gnunet/fs/network.scm
+++ b/gnu/gnunet/fs/network.scm
@@ -24,7 +24,6 @@
          (only (guile) begin define*)
          (only (gnu gnunet utils bv-slice)
                make-slice/read-write slice-copy! slice-length )
-         (only (gnu gnunet utils hat-let) let^)
          (only (gnu extractor enum) value->index symbol-value)
          (only (gnu gnunet message protocols) message-type)
          (only (gnu gnunet fs struct)
@@ -37,7 +36,7 @@
                hashcode:512->slice)
          (only (gnu gnunet utils cut-syntax) cut-syntax)
          (only (gnu gnunet netstruct syntactic)
-               set%! sizeof select read%))
+               set%! sizeof select r% s% define-analyser))
   (begin
     ;; GNUNET_SIGNATURE_PURPOSE_PEER_PLACEMENT,
     ;; (see gnunet-signatures/gnunet_signatures.rst)
@@ -72,19 +71,12 @@ expiring at @var{expiration-time} (TODO type), for 
@var{purpose}
       (set%!* '(file-length) file-length)
       s)
 
-   (define (analyse-request-loc-signature message)
-     "Return the file length, content hash key, expiration time (TODO type)
+    (define-analyser analyse-request-loc-signature
+      /:msg:fs:request-loc-signature
+      "Return the file length, content hash key, expiration time (TODO type)
 and signature purpose corresponding to the 
@code{/:msg:fs:request-loc-signature}
 message @var{message}."
-     (let^ ((! file-length
-              (read% /:msg:fs:request-loc-signature '(file-length) message))
-           (! content-hash-key
-              (make-content-hash-key/share
-               (select /:msg:fs:request-loc-signature
-                       '(content-hash-key) message)))
-           (! expiration-time
-              (read% /:msg:fs:request-loc-signature
-                     '(expiration-time) message))
-           (! purpose
-              (read% /:msg:fs:request-loc-signature '(purpose) message)))
-          (values file-length content-hash-key expiration-time purpose)))))
+      (values (r% file-length)
+             (make-content-hash-key/share (s% content-hash-key))
+             (r% expiration-time)
+             (r% purpose)))))
diff --git a/gnu/gnunet/netstruct/syntactic.scm 
b/gnu/gnunet/netstruct/syntactic.scm
index ff388af..fe54165 100644
--- a/gnu/gnunet/netstruct/syntactic.scm
+++ b/gnu/gnunet/netstruct/syntactic.scm
@@ -1,6 +1,6 @@
 ;#!r6rs
 ;;   This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
-;;   Copyright (C) 2020, 2021 GNUnet e.V.
+;;   Copyright © 2020--2022 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
@@ -21,7 +21,8 @@
 ;; some checks and inlining during expansion.
 (define-library (gnu gnunet netstruct syntactic)
   (export sizeof offsetof select read% set%!
-         structure/packed define-type)
+         structure/packed define-type
+         r% s% analyse define-analyser)
   (import (rnrs base)
          (rnrs control)
          (only (rnrs exceptions)
@@ -33,7 +34,8 @@
                newline
                compose
                call-with-prompt abort-to-prompt make-prompt-tag
-               resolve-module module-ref)
+               resolve-module module-ref
+               define-syntax-parameter syntax-parameterize)
          (only (system syntax) syntax-local-binding)
          (gnu gnunet utils bv-slice)
          (only (srfi srfi-1) span assq filter-map concatenate)
@@ -428,4 +430,32 @@ with some inlining where possible."
                      #`(#,(or (writer-syntax ns)
                               (not-inlinable
                                #'(p@set%! type fields slice value)))
-                        #,sl)))))))))))
+                        #,sl)))))))))
+
+    
+    ;; Documentation is in the manual.
+    (define-syntax-parameter r% ; read field
+      (lambda (stx)
+       (syntax-violation 'r%
+                         "r% used outside of a 'analyzer' construct"
+                         stx)))
+    (define-syntax-parameter s% ; select field
+      (lambda (stx)
+       (syntax-violation 's%
+                         "s% used outside of a 'analyzer' construct"
+                         stx)))
+    (define-syntax analyse
+      (syntax-rules ()
+       ((_ type message body ...)
+        (syntax-parameterize
+         ((r% (syntax-rules ()
+                ((_ . fields) (read% type 'fields message))))
+          (s% (syntax-rules ()
+                ((_ . fields) (select type 'fields message)))))
+         body ...))))
+    (define-syntax define-analyser
+      (syntax-rules ()
+       ((_ name type docstring body ...)
+        (define (name message)
+          docstring
+          (analyse type message body ...)))))))

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