[gnunet-scheme] 05/06: dht/client: Write a basic test for insertion.

[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 84a346870f470af9c9a67ec9caebedfc54bcd985
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Sat Jan 29 19:49:32 2022 +0000

    dht/client: Write a basic test for insertion.
    
    * gnu/gnunet/dht/client.scm
      (connect): Add 'connected' argument, and pass it to ...
      (reconnect): ... this procedure now accepting it.
      (reconnect)[error-handler]{connection:connected}.
      (reconnect)[error-handler]: Express doubt about reconnecting and
      closing working properly.
    * tests/distributed-hash-table.scm
      (i): New variable.
      (no-error-handler, client-put->insertion): New procedure.
      ("put! sends one message to service, after connecting"): New test.
---
 gnu/gnunet/dht/client.scm        | 10 ++++-
 tests/distributed-hash-table.scm | 85 +++++++++++++++++++++++++++++++++++++++-
 2 files changed, 93 insertions(+), 2 deletions(-)

diff --git a/gnu/gnunet/dht/client.scm b/gnu/gnunet/dht/client.scm
index d3d6f57..49c4340 100644
--- a/gnu/gnunet/dht/client.scm
+++ b/gnu/gnunet/dht/client.scm
@@ -537,7 +537,8 @@ even if not connected.  This is an idempotent operation."
       (atomic-box-set! (server-request-close?/box server) #t)
       (signal-condition! (server-request-close-condition server)))
 
-    (define* (connect config #:key (spawn spawn-fiber))
+    (define* (connect config #:key (connected values)
+                     (spawn spawn-fiber))
       "Connect to the DHT service in the background."
       (define request-close?/box (make-atomic-box #f))
       (define request-close-condition (make-condition))
@@ -550,6 +551,7 @@ even if not connected.  This is an idempotent operation."
                 new-put-operations new-put-operation-trigger
                 request-close?/box request-close-condition config
                 id->operation-map
+                #:connected connected
                 #:spawn spawn)
       (%make-server request-close?/box request-close-condition
                    new-get-operations new-get-operation-trigger
@@ -563,6 +565,7 @@ even if not connected.  This is an idempotent operation."
                        request-close?/box request-close-condition config
                        id->operation-map
                        #:key (spawn spawn-fiber)
+                       connected
                        #:rest rest)
       (define (process-client-result handle slice)
        "Process a reply @var{slice} (a @code{/:msg:dht:client:result}
@@ -650,8 +653,11 @@ structure) to the get request @var{handle}."
       (define (error-handler error . arguments)
        (case error
          ((connection:connected)
+          (connected)
+          ;; TODO: resume old requests
           (pk 'todo-connected)
           'todo)
+         ;; TODO: signal (and wait for) current fibers to stop?
          ((input:regular-end-of-file input:premature-end-of-file)
           (signal-condition! mq-closed)
           (unless (atomic-box-ref request-close?/box)
@@ -660,6 +666,8 @@ structure) to the get request @var{handle}."
                    new-put-operations new-put-operation-trigger
                    request-close?/box request-close-condition
                    config id->operation-map rest)))
+         ;; TODO: is this cargo-copying from (gnu gnunet nse client)
+         ;; correct?
          ((connection:interrupted)
           (values))
          (else
diff --git a/tests/distributed-hash-table.scm b/tests/distributed-hash-table.scm
index 997da84..0e45e66 100644
--- a/tests/distributed-hash-table.scm
+++ b/tests/distributed-hash-table.scm
@@ -28,13 +28,17 @@
        (gnu gnunet hashcode struct)
        (gnu gnunet block)
        (gnu gnunet message protocols)
+       (gnu gnunet mq handler)
+       (gnu gnunet mq-impl stream)
        (gnu extractor enum)
        (rnrs exceptions)
        (rnrs conditions)
        (rnrs base)
        (rnrs bytevectors)
        (srfi srfi-26)
-       (srfi srfi-64))
+       (srfi srfi-64)
+       (fibers conditions)
+       (tests utils))
 
 ;; Copied from tests/bv-slice.scm.
 (define-syntax-rule (test-missing-caps test-case what permitted required code)
@@ -350,4 +354,83 @@
  "put-path size must be a multiple of the size of a path element"
  'put-path #:put-path)
 
+
+;;;
+;;; Test client<->service communication.
+;;;
+;;; Currently, the following operations are tested:
+;;;
+;;;  * [x] insertion (@code{put!})
+;;;  * [ ] retrieval (@code{start-get!})
+;;;  * [ ] monitoring
+;;;
+;;; In the following contexts:
+;;;
+;;;  * [x] nothing special
+;;;  * [ ] after a reconnection
+;;;  * [ ] requested before a reconnection, without being processed
+;;;        before the reconnection.
+;;;  * [ ] requested (and started) before a reconnection and continued
+;;;        after the reconnection
+;;;
+;;; 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 (no-error-handler . e)
+  (pk 'e e)
+  (error "no error handler"))
+
+;; TODO: options
+(define (client-put->insertion slice)
+  (let^ ((! header (slice-slice slice 0 (sizeof /:msg:dht:client:put '())))
+        (! type (read% /:msg:dht:client:put '(type) header))
+        (! key (select /:msg:dht:client:put '(key) header))
+        (! value (slice-slice slice (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))
+        (! datum (make-datum type key value #:expiration expiration))
+        (! datum (copy-datum datum))
+        (! insertion
+           (datum->insertion datum #:desired-replication-level
+                             desired-replication-level)))
+       insertion))
+
+(test-equal "put! sends one message to service, after connecting"
+  i
+  (let^ ((! connected? #false)
+        (! (connected)
+           (assert (not connected?))
+           (set! connected? #true))
+        (! message #false)
+        (! message-received (make-condition))
+        (! (handle slice)
+           (when message
+             (error "already received"))
+           (set! message slice)
+           (signal-condition! message-received))
+        (! h (message-handlers
+              (message-handler
+               (type (symbol-value message-type msg:dht:client:put))
+               ((interpose foo) foo)
+               ((well-formed? s) #true)
+               ((handle! slice) (handle slice))))))
+       (call-with-services/fibers
+        `(("dht" . ,(lambda (port spawn-fiber)
+                      (define mq
+                        (port->message-queue port h no-error-handler
+                                             #:spawn spawn-fiber))
+                      (values))))
+        (lambda (config spawn-fiber)
+          (define server
+            (connect config #:connected connected #:spawn spawn-fiber))
+          (put! server i)
+          (wait message-received)
+          (assert connected?)
+          (assert message)
+          (client-put->insertion message)))))
+
 (test-end)

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