zlib: Fix memory leak due to revealed ports not being GC'd.

Fixes <https://bugs.gnu.org/28784>.

This mostly reverts 81a0f1cdf12e7bcc34c1203f034a323fa8f52cf5, which
introduced a regression: revealed ports are *never* GC'd (contrary to
what Guile's manual suggests).

In addition to the revert, 'close-procedure' now explicitly swallows
EBADF errors when 'close-port' is called.

* guix/zlib.scm (close-procedure): New procedure.
(make-gzip-input-port)[gzfile]: Use 'fileno' instead of 'port->fdes'.
Use 'close-procedure' instead of 'gzclose'.
(make-gzip-output-port): Likewise.
* tests/zlib.scm ("compression/decompression pipe"): Use 'port-closed?'
to determine whether PARENT has been closed.

1 files changed, 29 insertions, 10 deletions

diff --git a/guix/zlib.scm b/guix/zlib.scm
index 3d830ef84e..955589ab48 100644
--- a/guix/zlib.scm
+++ b/guix/zlib.scm
@@ -149,6 +149,31 @@ the number of uncompressed bytes written, a strictly positive integer."
   ;; Z_DEFAULT_COMPRESSION.
   -1)
 
+(define (close-procedure gzfile port)
+  "Return a procedure that closes GZFILE, ensuring its underlying PORT is
+closed even if closing GZFILE triggers an exception."
+  (let-syntax ((ignore-EBADF
+                (syntax-rules ()
+                  ((_ exp)
+                   (catch 'system-error
+                     (lambda ()
+                       exp)
+                     (lambda args
+                       (unless (= EBADF (system-error-errno args))
+                         (apply throw args))))))))
+
+    (lambda ()
+      (catch 'zlib-error
+        (lambda ()
+          ;; 'gzclose' closes the underlying file descriptor.  'close-port'
+          ;; calls close(2) and gets EBADF, which we swallow.
+          (gzclose gzfile)
+          (ignore-EBADF (close-port port)))
+        (lambda args
+          ;; Make sure PORT is closed despite the zlib error.
+          (ignore-EBADF (close-port port))
+          (apply throw args))))))
+
 (define* (make-gzip-input-port port #:key (buffer-size %default-buffer-size))
   "Return an input port that decompresses data read from PORT, a file port.
 PORT is automatically closed when the resulting port is closed.  BUFFER-SIZE
@@ -158,11 +183,7 @@ buffered input, which would be lost (and is lost anyway)."
   (define gzfile
     (match (drain-input port)
       (""                                         ;PORT's buffer is empty
-       ;; Since 'gzclose' will eventually close the file descriptor beneath
-       ;; PORT, we increase PORT's revealed count and never call 'close-port'
-       ;; on PORT since we would get EBADF if 'gzclose' already closed it (on
-       ;; 2.0 EBADF is swallowed by 'fport_close' but on 2.2 it is raised).
-       (gzdopen (port->fdes port) "r"))
+       (gzdopen (fileno port) "r"))
       (_
        ;; This is unrecoverable but it's better than having the buffered input
        ;; be lost, leading to unclear end-of-file or corrupt-data errors down
@@ -177,8 +198,7 @@ buffered input, which would be lost (and is lost anyway)."
     (gzbuffer! gzfile buffer-size))
 
   (make-custom-binary-input-port "gzip-input" read! #f #f
-                                 (lambda ()
-                                   (gzclose gzfile))))
+                                 (close-procedure gzfile port)))
 
 (define* (make-gzip-output-port port
                                 #:key
@@ -190,7 +210,7 @@ port is closed."
   (define gzfile
     (begin
       (force-output port)                         ;empty PORT's buffer
-      (gzdopen (port->fdes port)
+      (gzdopen (fileno port)
                (string-append "w" (number->string level)))))
 
   (define (write! bv start count)
@@ -200,8 +220,7 @@ port is closed."
     (gzbuffer! gzfile buffer-size))
 
   (make-custom-binary-output-port "gzip-output" write! #f #f
-                                  (lambda ()
-                                    (gzclose gzfile))))
+                                  (close-procedure gzfile port)))
 
 (define* (call-with-gzip-input-port port proc
                                     #:key (buffer-size %default-buffer-size))