[gnunet-scheme] 06/08: dht/client: Handle ill-formed messages correctly.

[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 68f32506138fcb5a441f36693b11d165bea55dc2
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Thu Feb 3 14:38:58 2022 +0000

    dht/client: Handle ill-formed messages correctly.
    
    * gnu/gnunet/dht/client.scm (reconnect)[error-handler]<else>: Send a
      control message to the main event loop instead of reporting the
      error and closing the queue directly ...
      (reconnect)[control]<'oops!'>: ... and handle it here, signalling
      the terminal-condition.
    * tests/distributed-hash-table.scm
      ("(DHT) bogus message from service --> all fibers stop, 'connected' and 
'disconnected' called"):
      New test.
    * test/utils.scm (call-with-spawner*, call-with-spawner/wait*): New
      test procedures, extracted from ...
      (call-with-spawner,call-with-spawner/wait): ... here.
    
    Partially fixes: <https://notabug.org/maximed/scheme-gnunet/issues/16>
---
 gnu/gnunet/dht/client.scm        | 24 ++++++++++++++++++------
 tests/distributed-hash-table.scm | 40 ++++++++++++++++++++++++++++++++++++++++
 tests/utils.scm                  | 23 +++++++++++++++--------
 3 files changed, 73 insertions(+), 14 deletions(-)

diff --git a/gnu/gnunet/dht/client.scm b/gnu/gnunet/dht/client.scm
index 54d19b8..95aedc8 100644
--- a/gnu/gnunet/dht/client.scm
+++ b/gnu/gnunet/dht/client.scm
@@ -770,8 +770,8 @@ code automatically tries to reconnect, so @var{connected} 
can be called after
                 TODO-error-reporting/2)))))
       ;; TODO: abstract duplication in (gnu gnunet nse client)
       (define mq-defined (make-condition))
-      (define (error-handler error . arguments)
-       (case error
+      (define (error-handler key . arguments)
+       (case key
          ((connection:connected)
           (connected)
           (wait mq-defined)
@@ -798,16 +798,28 @@ code automatically tries to reconnect, so @var{connected} 
can be called after
          ((connection:interrupted)
           (values))
          (else
-          ;; TODO: does 'disconnected' need to be called here,
-          ;; does 'disconnect!' need to be sent to the control channel?
-          (apply report-error error arguments)
-          (close-queue! mq))))
+          ;; Some unknown problem, let 'control' report the error,
+          ;; disconnect and stop reconnecting.  The first two happen
+          ;; in no particular order.
+          (apply maybe-send-control-message!* terminal-condition
+                 control-channel 'oops! key arguments)
+          (values))))
       (define mq (connect/fibers config "dht" handlers error-handler
                                 #:spawn spawn))
       (signal-condition! mq-defined)
       (define (control)
        "The main event loop."
        (match (perform-operation (get-operation control-channel))
+         (('oops! key . arguments)
+          ;; Some unknown error, report it (report-error) and close
+          ;; the queue (close-queue!).  'connected' will be called
+          ;; from the 'input:regular-end-of-file' case in 'error-handler'.
+          ;;
+          ;; The error reporting and closing happen in no particular order.
+          (signal-condition! terminal-condition)
+          (apply report-error key arguments)
+          (close-queue! mq)
+          (values))
          (('disconnect!)
           ;; Ignore future requests instead of blocking.
           (signal-condition! terminal-condition)
diff --git a/tests/distributed-hash-table.scm b/tests/distributed-hash-table.scm
index 193b295..f823d9e 100644
--- a/tests/distributed-hash-table.scm
+++ b/tests/distributed-hash-table.scm
@@ -17,6 +17,7 @@
 ;; SPDX-License-Identifier: AGPL-3.0-or-later
 (define-module (test-distributed-hash-table))
 (import (ice-9 match)
+       (ice-9 binary-ports)
        (quickcheck)
        (quickcheck arbitrary)
        (quickcheck generator)
@@ -26,11 +27,13 @@
        (gnu gnunet dht struct)
        (gnu gnunet utils bv-slice)
        (gnu gnunet utils hat-let)
+       (gnu gnunet util struct)
        (gnu gnunet netstruct syntactic)
        (gnu gnunet hashcode struct)
        (gnu gnunet block)
        (gnu gnunet message protocols)
        (gnu gnunet mq)
+       (gnu gnunet mq error-reporting)
        (gnu gnunet mq handler)
        (gnu gnunet mq-impl stream)
        (gnu extractor enum)
@@ -42,6 +45,7 @@
        (srfi srfi-64)
        (fibers conditions)
        (fibers channels)
+       (fibers timers) ; sleep
        (tests utils))
 
 ;; Copied from tests/bv-slice.scm.
@@ -641,4 +645,40 @@ supported."
 (test-assert "(DHT) close, not connected --> all fibers stop, no callbacks 
called"
   (close-not-connected-no-fallbacks "dht" connect disconnect!))
 
+(test-equal "(DHT) bogus message from service --> all fibers stop, 'connected' 
and 'disconnected' called"
+  `((logic:ill-formed
+     ,(value->index (symbol-value message-type msg:dht:client:result))))
+  (call-with-spawner/wait*
+   (lambda (config spawn)
+     (define errors '())
+     (define connected? #false)
+     (define disconnected? #false)
+     (define disconnected-c (make-condition))
+     (parameterize ((error-reporter (lambda foo
+                                     (pk 'foo foo)
+                                     (assert connected?)
+                                     (set! errors (cons foo errors)))))
+       (define (connected)
+        (assert (not connected?))
+        (set! connected? #true))
+       (define (disconnected)
+        (assert connected?)
+        (assert (not disconnected?))
+        (set! disconnected? #true)
+        (signal-condition! disconnected-c))
+       (define server
+        (connect config #:connected connected #:disconnected disconnected
+                 #:spawn spawn))
+       ;; Give 'error-reporter' a chance to be called too often
+       (sleep 0.001)
+       (wait disconnected-c)
+       (and connected? disconnected? errors)))
+   `(("dht" . ,(lambda (port spawn-fiber)
+                (define b (make-bytevector (sizeof /:message-header '())))
+                (define s (slice/write-only (bv-slice/read-write b)))
+                (set%! /:message-header '(type) s
+                       (value->index (symbol-value message-type 
msg:dht:client:result)))
+                (set%! /:message-header '(size) s (slice-length s))
+                (put-bytevector port b)
+                (close-port port))))))
 (test-end)
diff --git a/tests/utils.scm b/tests/utils.scm
index a117eca..962ea07 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -32,6 +32,7 @@
                             call-with-services/fibers
                             call-with-spawner
                             call-with-spawner/wait
+                            call-with-spawner/wait*
                             call-with-temporary-directory
                             make-nonblocking!
                             call-with-absent-service
@@ -148,21 +149,23 @@ the services and each tails is a list of a procedure 
accepting ports
 (define (call-with-services/fibers service-alist proc)
   (fibers:run-fibers (lambda () (call-with-services service-alist proc))))
 
-(define* (call-with-spawner proc . args)
+(define* (call-with-spawner* proc service-alist . args)
   (apply fibers:run-fibers
         (lambda ()
           (call-with-services
-           '()
-           (lambda (config spawn)
-             (proc spawn))))
+           service-alist
+           proc))
         args))
 
+(define (call-with-spawner proc . args)
+  (apply call-with-spawner* (lambda (config spawn) (proc spawn)) '() args))
+
 ;; When done, wait for every fiber to complete.
 ;; Somewhat racy, don't use outside tests.
-(define* (call-with-spawner/wait proc . args)
+(define* (call-with-spawner/wait* proc service-alist . args)
   (define h (make-weak-key-hash-table)) ; condition -> nothing in particular
-  (apply call-with-spawner
-        (lambda (spawn/not-waiting)
+  (apply call-with-spawner*
+        (lambda (config spawn/not-waiting)
           (define (spawn thunk)
             (define done-condition (make-condition))
             (hashq-set! h done-condition #f)
@@ -171,13 +174,17 @@ the services and each tails is a list of a procedure 
accepting ports
                (thunk)
                (signal-condition! done-condition))))
           (define-values return-values
-            (proc spawn))
+            (proc config spawn))
           ;; Make sure every fiber completes before returning.
           ;; XXX hash-for-each imposes a continuation barrier
           (for-each wait (hash-map->list (lambda (x y) x) h))
           (apply values return-values))
+        service-alist
         args))
 
+(define (call-with-spawner/wait proc . args)
+  (apply call-with-spawner/wait* (lambda (config spawn) (proc spawn)) '() 
args))
+
 (define (trivial-service-config what where)
   "Make a configuration where the socket location of the @var{what} service
 is @var{where}."

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