[gnunet-scheme] 236/324: mq-impl/stream: Close the port when stopping the fibers.

[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 75867c24192f49e76fbe31ce0dd8e774a2eac929
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Mon Sep 6 21:00:22 2021 +0200

    mq-impl/stream: Close the port when stopping the fibers.
    
    * gnu/gnunet/mq-impl/stream.scm
      (prepare-port-message-queue)[closed-condition]: Document new uses.
      (prepare-port-message-queue)[start-reader!]: Close port if
      signal-condition! returns #false.
      (prepare-port-message-queue)[start-writer!]: Likewise.
    * tests/mq-stream.scm
      (%false-if-broken-pipe): New procedure.
      (false-if-broken-pipe): New macro.
      ("closed for writing --> handle-input! stops (port->message-queue)"):
      Adjust test to resource leak fix.
      (error-handler/regular): New procedure.
      ("port is closed at input eof")
      ("port is closed at output eof")
      ("port is closed at input/output eof"): New tests.
---
 gnu/gnunet/mq-impl/stream.scm | 19 +++++++++----
 tests/mq-stream.scm           | 65 +++++++++++++++++++++++++++++++++++++++++--
 2 files changed, 77 insertions(+), 7 deletions(-)

diff --git a/gnu/gnunet/mq-impl/stream.scm b/gnu/gnunet/mq-impl/stream.scm
index 53df0a5..05f6c5a 100644
--- a/gnu/gnunet/mq-impl/stream.scm
+++ b/gnu/gnunet/mq-impl/stream.scm
@@ -76,7 +76,7 @@
                EPROTOTYPE EPIPE
                PF_UNIX SOCK_STREAM F_GETFD F_SETFD F_GETFL F_SETFL FD_CLOEXEC
                O_NONBLOCK AF_UNIX
-               socket connect fcntl force-output
+               socket connect fcntl force-output close-port
                make-socket-address
                exception-args exception-kind)
          (only (rnrs io ports)
@@ -269,6 +269,11 @@ an appropriate @code{&undefined-key-error} is raised."
       ;; two fibers.  When one fiber detects an EOF condition (or half-duplex),
       ;; it informs the other fiber by signalling the condition and injects
       ;; an appropriate error, unless the other fiber will do it already.
+      ;;
+      ;; It is also used to determine which of the two fibers should close
+      ;; the port.  The port is closed by the fiber for which signal-condition!
+      ;; on closed-condition returns #f, as in that case, the other fiber has
+      ;; already done all its I/O and won't need the port anymore.
       (define closed-condition (make-condition))
       (define (start-reader! mq port)
        (define-values (key . rest)
@@ -287,8 +292,10 @@ an appropriate @code{&undefined-key-error} is raised."
            ;; happen: <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=50153>.
            (parameterize ((current-read-waiter new-waiter))
              (handle-input! mq port #:return values))))
-       (when (signal-condition! closed-condition)
-         (apply inject-error! mq key rest)))
+       (if (signal-condition! closed-condition)
+           (apply inject-error! mq key rest)
+           ;; TODO: close-port can block!
+           (close-port port)))
       (define (start-writer! mq port)
        (let/ec escape
          ;; operation for calling the escape continuation when
@@ -326,8 +333,10 @@ an appropriate @code{&undefined-key-error} is raised."
                (old-waiter p)))
          (parameterize ((current-write-waiter new-waiter))
            (handle-output! mq port wait!)))
-       (when (signal-condition! closed-condition)
-         (inject-error! mq 'input:regular-end-of-file)))
+       (if (signal-condition! closed-condition)
+           (inject-error! mq 'input:regular-end-of-file)
+           ;; TODO: close-port can block!
+           (close-port port)))
       (values (lambda (mq port)
                (spawn (lambda () (start-reader! mq port)))
                (spawn (lambda () (start-writer! mq port))))
diff --git a/tests/mq-stream.scm b/tests/mq-stream.scm
index d9cd667..e16aa1b 100644
--- a/tests/mq-stream.scm
+++ b/tests/mq-stream.scm
@@ -31,6 +31,7 @@
             ((rnrs io ports) #:select (open-bytevector-input-port))
             ((rnrs base) #:select (assert))
             (rnrs hashtables)
+            ((rnrs exceptions) #:select (guard))
             (srfi srfi-26)
             (srfi srfi-43)
             (rnrs io ports)
@@ -532,6 +533,20 @@
    ;; Should make 'yield-many' less fragile.
    #:parallelism 1))
 
+(define (%false-if-broken-pipe thunk)
+  "Call @var{thunk} in an environment where EPIPE system errors are caught.
+If an EPIPE system error is raised, return #f."
+  (guard (c ((and (eq? 'system-error (exception-kind c))
+                 (= EPIPE (car (list-ref (exception-args c) 3))))
+            #f))
+    (thunk)))
+
+(define-syntax-rule (false-if-broken-pipe exp exp* ...)
+  ;; See %false-if-broken-pipe
+  (%false-if-broken-pipe
+   (lambda ()
+     exp exp* ...)))
+
 (test-assert "closed for writing --> handle-input! stops (port->message-queue)"
   (call-with-spawner/wait
    (lambda (spawn)
@@ -569,8 +584,10 @@
      (pk 'waiting)
      (wait end-of-file)
      ;; Attempt to read a message (after buffering a message), even though
-     ;; the connection is half-closed.
-     (put-bytevector beta #vu8(0 4 0 0))
+     ;; the connection is half-closed.  Ignore broken pipe errors here:
+     ;; if a ‘broken pipe’ error happens here, that means ALPHA was closed,
+     ;; which is correct (tested in "port is closed at output").
+     (false-if-broken-pipe (put-bytevector beta #vu8(0 4 0 0)))
      ;; As the 'handle-input!' fiber should have exited already, 'receive!'
      ;; shouldn't be called.
      (yield-many)
@@ -668,4 +685,48 @@
                                        (old-read-waiter p)))))
                    (get-bytevector-some beta))))))
 
+(define (error-handler/regular . e)
+  (match e
+    ('(input:regular-end-of-file) (values))
+    (_ (error "what ~a" e))))
+
+(test-assert "port is closed at input eof"
+  (call-with-spawner/wait
+   (lambda (spawn)
+     (define-values (alpha beta) (two-sockets))
+     (define q (port->message-queue alpha no-handlers error-handler/regular
+                                   #:spawn spawn))
+     (shutdown alpha 0)
+     (yield-many)
+     (sleep 0.05) ;; XXX yield-many above is unsufficient
+     (port-closed? alpha))
+   #:parallelism 1)) ; to make the use of yield-many less fragile
+
+(test-assert "port is closed at output eof"
+  (call-with-spawner/wait
+   (lambda (spawn)
+     (define-values (alpha beta) (two-sockets))
+     (define mq (port->message-queue alpha no-handlers error-handler/regular
+                                    #:spawn spawn))
+     (shutdown alpha 1)
+     ;; XXX It's not possible for the output eof to be waited for currently,
+     ;; so attempt to send a message to wake up the writing fiber.
+     (send-message! mq (bv-slice/read-write #vu8(0 4 0 0)))
+     (yield-many)
+     (sleep 0.05) ;; XXX yield-many above is unsufficient
+     (port-closed? alpha))
+   #:parallelism 1)) ; to make the use of yield-many less fragile
+
+(test-assert "port is closed at input/output eof"
+  (call-with-spawner/wait
+   (lambda (spawn)
+     (define-values (alpha beta) (two-sockets))
+     (define q (port->message-queue alpha no-handlers error-handler/regular
+                                   #:spawn spawn))
+     (shutdown alpha 2)
+     (yield-many)
+     (sleep 0.05) ;; XXX yield-many above is unsufficient
+     (port-closed? alpha))
+   #:parallelism 1)) ; to make the use of yield-many less fragile
+
 (test-end "mq-stream")

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