[gnunet-scheme] 08/09: Extract test-roundtrip from tests/cadet.

[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 7b3097fd795bcbe454d278f1c105a523a25c240a
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Sat Dec 3 14:01:41 2022 +0100

    Extract test-roundtrip from tests/cadet.
    
    Useful for the file sharing tests.
    
    * tests/cadet.scm (test-roundtrip): Extract to ...
    * tests/utils.scm: ... here.
---
 tests/cadet.scm | 17 ++++-------------
 tests/utils.scm | 41 ++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 44 insertions(+), 14 deletions(-)

diff --git a/tests/cadet.scm b/tests/cadet.scm
index fe0a1dd..162a666 100644
--- a/tests/cadet.scm
+++ b/tests/cadet.scm
@@ -151,34 +151,25 @@
         (foo foo))
        list))
 
-(define-syntax-rule
-  (test-roundtrip testcase analyse construct (name $arbitrary) ...)
-  (test-assert testcase
-    (quickcheck
-     (property ((name $arbitrary) ...)
-              (let^ ((! expected (list name ...))
-                     (! constructed (construct name ...))
-                     (<-- analysed (analyse constructed))
-                     (! analysed (normalise analysed)))
-                    (and (slice-readable? constructed)
-                         (slice-writable? constructed)
-                         (equal? expected analysed)))))))
-
 (test-roundtrip "analyse + construct round-trips (local-channel-create)"
                analyse-local-channel-create construct-local-channel-create
+               normalise
                (cadet-address $cadet-address)
                (channel-number $channel-number)
                (options $options))
 (test-roundtrip "analyse + construct round-trips (local-channel-destroy)"
                analyse-local-channel-destroy construct-local-channel-destroy
+               normalise
                (channel-number $channel-number))
 (test-roundtrip "analyse + construct round-trips (local-data)"
                analyse-local-data construct-local-data
+               normalise
                (channel-number $channel-number)
                (priority-preference $priority-preference)
                (data $cadet-data))
 (test-roundtrip "analyse + construct round-tripes (local-acknowledgement)"
                analyse-local-acknowledgement construct-local-acknowledgement
+               normalise
                (channel-number $channel-number))
 
 ;; header information will be tested elsewhere (TODO)
diff --git a/tests/utils.scm b/tests/utils.scm
index 40329c9..09524af 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -16,7 +16,12 @@
 ;;
 ;; SPDX-License-Identifier: AGPL-3.0-or-later
 (define-module (tests utils)
+  #:use-module (quickcheck)
+  #:use-module (quickcheck property)
+  #:use-module (quickcheck generator)
+  #:use-module (quickcheck arbitrary)
   #:use-module (srfi srfi-8)
+  #:use-module (srfi srfi-64)
   #:use-module (ice-9 match)
   #:use-module (ice-9 weak-vector)
   #:use-module ((rnrs hashtables) #:prefix |rnrs:|)
@@ -24,11 +29,14 @@
                #:select (bitwise-ior))
   #:use-module ((rnrs base) #:select (assert))
   #:use-module ((fibers) #:prefix |fibers:|)
+  #:use-module (gnu gnunet utils hat-let)
   #:autoload (fibers conditions) (make-condition signal-condition! wait)
   #:autoload (fibers timers) (sleep)
   #:autoload (gnu gnunet config db)
   (hash->configuration hash-key key=? set-value!)
   #:autoload (gnu gnunet mq error-reporting) (error-reporter)
+  #:autoload (gnu gnunet utils bv-slice)
+  (slice-readable? slice-writable?)
   #:export (conservative-gc? calls-in-tail-position?
                             call-with-services
                             call-with-services/fibers
@@ -44,7 +52,8 @@
                             garbage-collectable
                             disconnect-after-eof-after-connected
                             reconnects
-                            determine-reported-errors))
+                            determine-reported-errors
+                            test-roundtrip))
 
 (define (make-nonblocking! sock)
   (fcntl sock F_SETFL
@@ -421,3 +430,33 @@ connection port as seen by the server and can e.g. write 
to the port or close it
        (and (not currently-connected?)
            (= times-connected n-connections) errors)))
    `((,service . ,proc))))
+
+;; TODO export
+(define make-property (@@ (quickcheck property) make-property))
+
+(define (round-trip-property analyse construct normalise names gen/arbs)
+  (make-property
+   names gen/arbs
+   (lambda expected
+     (let^ ((! constructed (apply construct expected))
+           (<-- analysed (analyse constructed))
+           (! analysed (normalise analysed)))
+          (and (slice-readable? constructed)
+               (slice-writable? constructed)
+               (equal? expected analysed))))))
+
+;; This test construct network messages by generating @var{name} ...
+;; with the quickcheck arbitraries @var{$arbitrary} ...
+;; and passing them to the construction procedure
+;; @var{construct}.  @var{testcase} is the name of this test.
+;;
+;; TODO: don't assume @code{equal?} / normalisation
+;; and explain why.  TODO document construct/analyse
+;; pattern.
+(define-syntax-rule
+  (test-roundtrip testcase analyse construct normalise
+                 (name $arbitrary) ...)
+  (test-assert testcase
+    (quickcheck (round-trip-property analyse construct normalise
+                                    '(name ...)
+                                    (list $arbitrary ...)))))

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