[gnunet-scheme] 02/02: cadet: Define procedures for messages for opening/closing channels.

[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.

commit 56c7d9a56a6672a7301253397c7cf9d0f56319f9
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Fri Feb 25 15:03:18 2022 +0000

    cadet: Define procedures for messages for opening/closing channels.
    
    * gnu/gnunet/cadet/client.scm
      (analyse-local-channel-create,construct-local-channel-create)
      (analyse-local-channel-destroy,construct-local-channel-destroy): New
      procedures.
    * gnu/gnunet/cadet/network.scm
      (analyse-local-channel-create,construct-local-channel-create)
      (analyse-local-channel-destroy,construct-local-channel-destroy):
      Export new procedures.
    * tests/cadet.scm
      ("analyse + construct round-trips (local-channel-create)")
      ("analyse + construct round-trips (local-channel-destroy)"): Test
      new procedures.
      ($integer-in-range,$sized-bytevector,$arbitrary-lift)
      ($sized-bytevector-slice/read-write,$sized-bytevector-slice/read-only):
      New procedures for tests.
      ($channel-number,$peer,$port,$options,$cadet-address): New
      quickcheck arbitraries.
    * Makefile.am (modules): Register new module.
---
 Makefile.am                 |  1 +
 gnu/gnunet/cadet/client.scm | 87 ++++++++++++++++++++++++++++++++++++++++++---
 tests/cadet.scm             | 53 ++++++++++++++++++++++++++-
 3 files changed, 135 insertions(+), 6 deletions(-)

diff --git a/Makefile.am b/Makefile.am
index 3f19001..2346ed3 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -68,6 +68,7 @@ modules = \
   gnu/gnunet/block.scm \
   \
   gnu/gnunet/cadet/client.scm \
+  gnu/gnunet/cadet/network.scm \
   gnu/gnunet/cadet/struct.scm \
   \
   gnu/gnunet/config/parser.scm \
diff --git a/gnu/gnunet/cadet/client.scm b/gnu/gnunet/cadet/client.scm
index f863d49..d3f267c 100644
--- a/gnu/gnunet/cadet/client.scm
+++ b/gnu/gnunet/cadet/client.scm
@@ -19,8 +19,24 @@
   (export connect disconnect!
          make-cadet-address cadet-address? cadet-address-peer 
cadet-address-port
          channel? open-channel! close-channel!
-         port? open-port! close-port!)
-  (import (only (gnu gnunet crypto struct)
+         port? open-port! close-port!
+
+         ;; Network manipulation procedures
+         ;; (these belong to (gnu gnunet cadet network)).
+         (rename (analyse-local-channel-create
+                  #{ analyse-local-channel-create}#)
+                 (construct-local-channel-create
+                  #{ construct-local-channel-create}#)
+                 (analyse-local-channel-destroy
+                  #{ analyse-local-channel-destroy}#)
+                 (construct-local-channel-destroy
+                  #{ construct-local-channel-destroy}#)))
+  (import (only (gnu extractor enum)
+               value->index symbol-value)
+         (only (gnu gnunet cadet struct)
+               /:msg:cadet:local:channel:create
+               /:msg:cadet:local:channel:destroy)
+         (only (gnu gnunet crypto struct)
                /peer-identity)
          (only (gnu gnunet concurrency lost-and-found)
                make-lost-and-found collect-lost-and-found-operation)
@@ -30,14 +46,20 @@
                maybe-send-control-message!* make-error-handler)
          (only (gnu gnunet hashcode struct)
                /hashcode:512)
+         (only (gnu gnunet message protocols) message-type)
          (only (gnu gnunet mq-impl stream) connect/fibers)
          (only (gnu gnunet netstruct syntactic)
-               sizeof)
+               sizeof select read% set%!)
          (only (gnu gnunet utils bv-slice)
-               slice-copy/read-only slice-length)
+               make-slice/read-write slice-copy/read-only slice-length
+               slice-copy!)
+         (only (gnu gnunet utils cut-syntax)
+               cut-syntax)
+         (only (gnu gnunet utils hat-let)
+               let^)
          (only (rnrs base)
                begin define lambda assert quote cons apply values
-               case else =)
+               case else = define-syntax)
          (only (rnrs records syntactic) define-record-type)
          (only (ice-9 match) match)
          (only (guile) define*)
@@ -134,6 +156,61 @@ do not have any impact on the cadet address."
                    (%make (slice-copy/read-only peer)
                           (slice-copy/read-only port))))))
 
+    (define* (construct-local-channel-create cadet-address channel-number
+                                            #:optional (options 0))
+      "Create a new @code{/:msg:cadet:channel:create} message for contacting
+the CADET addresss @var{cadet-address}, using the channel number
+@var{channel-number} and options @var{options}."
+      (define s
+       (make-slice/read-write (sizeof /:msg:cadet:local:channel:create '())))
+      (define-syntax set*
+       (cut-syntax set%! /:msg:cadet:local:channel:create <> s <>))
+      (define-syntax select*
+       (cut-syntax select /:msg:cadet:local:channel:create <> s))
+      (set* '(header size) (slice-length s))
+      (set* '(header type)
+           (value->index
+            (symbol-value message-type msg:cadet:local:channel:create)))
+      (set* '(channel-number) channel-number)
+      (slice-copy! (cadet-address-peer cadet-address) (select* '(peer)))
+      (slice-copy! (cadet-address-port cadet-address) (select* '(port)))
+      (set* '(options) options)
+      s)
+
+    (define (analyse-local-channel-create message)
+      "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)))
+
+    (define (construct-local-channel-destroy channel-number)
+      "Create a @code{/:msg:cadet:channel:destroy} message for closing the
+CADET channel with channel number @var{channel-number}."
+      (define s
+       (make-slice/read-write (sizeof /:msg:cadet:local:channel:destroy '())))
+      (define-syntax set*
+       (cut-syntax set%! /:msg:cadet:local:channel:destroy <> s <>))
+      (set* '(header size) (slice-length s))
+      (set* '(header type)
+           (value->index
+            (symbol-value message-type msg:cadet:local:channel:destroy)))
+      (set* '(channel-number) channel-number)
+      s)
+
+    (define (analyse-local-channel-destroy message)
+      "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))
+
     (define (stub . foo)
       (error "todo"))
     (define channel? stub)
diff --git a/tests/cadet.scm b/tests/cadet.scm
index 5a395cc..e9dbc37 100644
--- a/tests/cadet.scm
+++ b/tests/cadet.scm
@@ -17,13 +17,19 @@
 ;; SPDX-License-Identifier: AGPL-3.0-or-later
 (define-module (test-distributed-hash-table))
 (import (gnu gnunet cadet client)
+       (gnu gnunet cadet network)
        (gnu gnunet utils bv-slice)
        (gnu gnunet netstruct syntactic)
        (gnu gnunet crypto struct)
        (gnu gnunet hashcode struct)
        (rnrs bytevectors)
+       (srfi srfi-8)
        (srfi srfi-64)
-       (tests utils))
+       (tests utils)
+       (quickcheck)
+       (quickcheck property)
+       (quickcheck generator)
+       (quickcheck arbitrary))
 
 (test-begin "CADET")
 (test-assert "(CADET) close, not connected --> all fibers stop, no callbacks 
called"
@@ -86,4 +92,49 @@
   (make-cadet-address (slice-copy/read-only %peer-identity)
                      (slice-copy/read-only %port)))
 
+;; TODO: integrate in guile-quickcheck, (tests utils)
+(define ($integer-in-range lower upper)
+  (arbitrary
+   (gen (choose-integer lower upper))
+   (xform #false)))
+(define ($sized-bytevector size)
+  (arbitrary
+   (gen (choose-bytevector size))
+   (xform #false)))
+(define ($arbitrary-lift f . a)
+  (arbitrary
+   (gen (apply generator-lift f (map arbitrary-gen a)))
+   (xform #false))) ; TODO
+(define ($sized-bytevector-slice/read-write size)
+  ($arbitrary-lift bv-slice/read-write ($sized-bytevector size)))
+(define ($sized-bytevector-slice/read-only size)
+  ($arbitrary-lift slice/read-only ($sized-bytevector-slice/read-write size)))
+
+(define $channel-number ($integer-in-range 0 (- (expt 2 32) 1)))
+(define $peer ($sized-bytevector-slice/read-only (sizeof /peer-identity '())))
+(define $port ($sized-bytevector-slice/read-only (sizeof /hashcode:512 '())))
+(define $options ($integer-in-range 0 (- (expt 2 32) 1)))
+(define $cadet-address ($arbitrary-lift make-cadet-address $peer $port))
+
+(test-assert "analyse + construct round-trips (local-channel-create)"
+  (quickcheck
+   (property ((channel-number $channel-number)
+             (cadet-address $cadet-address)
+             (options $options))
+            (receive (cadet-address* channel-number* options*)
+                (analyse-local-channel-create
+                 (construct-local-channel-create
+                  cadet-address channel-number  options))
+              (and (equal? channel-number channel-number*)
+                   (equal? cadet-address cadet-address*)
+                   (equal? options options*))))))
+
+(test-assert "analyse + construct round-trips (local-channel-destroy)"
+  (quickcheck
+   (property ((channel-number $channel-number))
+            (equal? channel-number
+                    (analyse-local-channel-destroy
+                     (construct-local-channel-destroy channel-number))))))
+;; header information will be tested elsewhere (TODO)
+
 (test-end "CADET")

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