[no subject]

[Ludovic Courtès]

branch: master
commit 802068c04038dcefeba1a2202f0ea538e554fa37
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sat Jul 15 16:15:43 2023 +0200

    remote: Make 'send-log' interruptible.
    
    Previously, if the fiber was suspended while reading from LOG, it could
    not be resumed due to the way 'make-gzip-output-port' uses
    'dynamic-wind'.
    
    * src/cuirass/remote.scm (send-log): Use 'make-gzip-output-port' +
    'catch' instead of 'call-with-gzip-output-port' + 'swallow-zlib-error'.
    (swallow-zlib-error): Remove.
---
 src/cuirass/remote.scm | 24 +++++++++++++-----------
 1 file changed, 13 insertions(+), 11 deletions(-)

diff --git a/src/cuirass/remote.scm b/src/cuirass/remote.scm
index aa94927..6d5952f 100644
--- a/src/cuirass/remote.scm
+++ b/src/cuirass/remote.scm
@@ -328,13 +328,6 @@ PRIVATE-KEY to sign narinfos."
    (lambda ()
      (wait-for-client port))))
 
-(define-syntax-rule (swallow-zlib-error exp ...)
-  "Swallow 'zlib-error' exceptions raised by EXP..."
-  (catch 'zlib-error
-    (lambda ()
-      exp ...)
-    (const #f)))
-
 (define* (send-log address port derivation log)
   (let* ((sock (socket AF_INET
                        (logior SOCK_STREAM SOCK_CLOEXEC SOCK_NONBLOCK) 0))
@@ -348,10 +341,19 @@ PRIVATE-KEY to sign narinfos."
                        (version 0)
                        (derivation ,derivation))))
          (write header sock)
-         (swallow-zlib-error
-          (call-with-gzip-output-port sock
-            (lambda (sock-compressed)
-              (dump-port log sock-compressed))))
+
+         ;; Note: Don't use 'call-with-gzip-output-port' since it's
+         ;; implemented in terms of 'dynamic-wind' as of Guile-Zlib 0.1.0,
+         ;; making it unsuitable in a fiberized program.
+         (let ((compressed (make-gzip-output-port sock)))
+           (catch #t
+             (lambda ()
+               (dump-port log compressed)
+               (close-port compressed))
+             (lambda (key . args)
+               (close-port compressed)
+               (unless (eq? key 'zlib-error)
+                 (apply throw args)))))
          (close-port sock)))
       (x
        (log-error "invalid handshake ~s." x)