download: Do not leak file descriptors on TLS ports.

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

* guix/build/download.scm (%tls-ports, register-tls-record-port): Remove.
(tls-wrap): Remove call to 'register-tls-record-port'.  Return a custom
binary input/output port instead.  This is a backport of what Guile
2.2's (web client) module has been doing.
(close-connection): Define as an alias for 'close-port'.
* guix/http-client.scm (http-fetch): Remove #:keep-alive? parameter,
which was ignored and unused.
Pass #:keep-alive? #f to 'http-get'.
* guix/lint.scm (probe-uri): Use 'close-port' instead of 'close-connection'.
* guix/scripts/substitute.scm (http-multiple-get): Likewise.

4 files changed, 52 insertions, 43 deletions

diff --git a/guix/build/download.scm b/guix/build/download.scm
index 53a144f126..a7bb3b0d6e 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -28,6 +28,7 @@
   #:use-module (guix build utils)
   #:use-module (guix progress)
   #:use-module (rnrs io ports)
+  #:use-module ((ice-9 binary-ports) #:select (unget-bytevector))
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
@@ -160,15 +161,6 @@ out if the connection could not be established in less than TIMEOUT seconds."
                   '(gnutls)
                   '(make-session connection-end/client))
 
-(define %tls-ports
-  ;; Mapping of session record ports to the underlying file port.
-  (make-weak-key-hash-table))
-
-(define (register-tls-record-port record-port port)
-  "Hold a weak reference from RECORD-PORT to PORT, where RECORD-PORT is a TLS
-session record port using PORT as its underlying communication port."
-  (hashq-set! %tls-ports record-port port))
-
 (define %x509-certificate-directory
   ;; The directory where X.509 authority PEM certificates are stored.
   (make-parameter (or (getenv "GUIX_TLS_CERTIFICATE_DIRECTORY")
@@ -311,17 +303,40 @@ host name without trailing dot."
           (apply throw args))))
 
     (let ((record (session-record-port session)))
-      ;; Since we use `fileno' above, the file descriptor behind PORT would be
-      ;; closed when PORT is GC'd.  If we used `port->fdes', it would instead
-      ;; never be closed.  So we use `fileno', but keep a weak reference to
-      ;; PORT, so the file descriptor gets closed when RECORD is GC'd.
-      (register-tls-record-port record port)
-
-      ;; Write HTTP requests line by line rather than byte by byte:
-      ;; <https://bugs.gnu.org/22966>.  This is possible with Guile >= 2.2.
-      (setvbuf record 'line)
-
-      record)))
+      (define (read! bv start count)
+        (define read-bv (get-bytevector-some record))
+        (if (eof-object? read-bv)
+            0  ; read! returns 0 on eof-object
+            (let ((read-bv-len (bytevector-length read-bv)))
+              (bytevector-copy! read-bv 0 bv start (min read-bv-len count))
+              (when (< count read-bv-len)
+                (unget-bytevector record bv count (- read-bv-len count)))
+              read-bv-len)))
+      (define (write! bv start count)
+        (put-bytevector record bv start count)
+        (force-output record)
+        count)
+      (define (get-position)
+        (port-position record))
+      (define (set-position! new-position)
+        (set-port-position! record new-position))
+      (define (close)
+        (unless (port-closed? port)
+          (close-port port))
+        (unless (port-closed? record)
+          (close-port record)))
+
+      (setvbuf record 'block)
+
+      ;; Return a port that wraps RECORD to ensure that closing it also
+      ;; closes PORT, the actual socket port, and its file descriptor.
+      ;; XXX: This wrapper would be unnecessary if GnuTLS could
+      ;; automatically close SESSION's file descriptor when RECORD is
+      ;; closed, but that doesn't seem to be possible currently (as of
+      ;; 3.6.9).
+      (make-custom-binary-input/output-port "gnutls wrapped port" read! write!
+                                            get-position set-position!
+                                            close))))
 
 (define (ensure-uri uri-or-string)                ;XXX: copied from (web http)
   (cond
@@ -429,16 +444,9 @@ VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
                      #:verify-certificate? verify-certificate?)
            s)))))
 
-(define (close-connection port)
-  "Like 'close-port', but (1) idempotent, and (2) also closes the underlying
-port if PORT is a TLS session record port."
-  ;; FIXME: This is a partial workaround for <http://bugs.gnu.org/20145>,
-  ;; because 'http-fetch' & co. may return a chunked input port whose 'close'
-  ;; method calls 'close-port', not 'close-connection'.
+(define (close-connection port)                   ;deprecated
   (unless (port-closed? port)
-    (close-port port))
-  (and=> (hashq-ref %tls-ports port)
-         close-connection))
+    (close-port port)))
 
 ;; XXX: This is an awful hack to make sure the (set-port-encoding! p
 ;; "ISO-8859-1") call in `read-response' passes, even during bootstrap
diff --git a/guix/http-client.scm b/guix/http-client.scm
index 067002a79a..5a5a33b4c0 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.scm
@@ -70,14 +70,13 @@
 
 
 (define* (http-fetch uri #:key port (text? #f) (buffered? #t)
-                     keep-alive? (verify-certificate? #t)
+                     (verify-certificate? #t)
                      (headers '((user-agent . "GNU Guile"))))
   "Return an input port containing the data at URI, and the expected number of
 bytes available or #f.  If TEXT? is true, the data at URI is considered to be
 textual.  Follow any HTTP redirection.  When BUFFERED? is #f, return an
-unbuffered port, suitable for use in `filtered-port'.  When KEEP-ALIVE? is
-true, send a 'Connection: keep-alive' HTTP header, in which case PORT may be
-reused for future HTTP requests.  HEADERS is an alist of extra HTTP headers.
+unbuffered port, suitable for use in `filtered-port'.  HEADERS is an alist of
+extra HTTP headers.
 
 When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates.
 
@@ -100,7 +99,11 @@ Raise an '&http-get-error' condition if downloading fails."
         (setvbuf port 'none))
       (let*-values (((resp data)
                      (http-get uri #:streaming? #t #:port port
-                               #:keep-alive? #t
+                               ;; XXX: When #:keep-alive? is true, if DATA is
+                               ;; a chunked-encoding port, closing DATA won't
+                               ;; close PORT, leading to a file descriptor
+                               ;; leak.
+                               #:keep-alive? #f
                                #:headers headers))
                     ((code)
                      (response-code resp)))
diff --git a/guix/lint.scm b/guix/lint.scm
index cd2ea571ed..41ddff584d 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
 ;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org>
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
 ;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org>
 ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
@@ -26,7 +26,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix lint)
-  #:use-module ((guix store) #:hide (close-connection))
+  #:use-module (guix store)
   #:use-module (guix base32)
   #:use-module (guix diagnostics)
   #:use-module (guix download)
@@ -54,8 +54,7 @@
   #:use-module ((guix build download)
                 #:select (maybe-expand-mirrors
                           (open-connection-for-uri
-                           . guix:open-connection-for-uri)
-                          close-connection))
+                           . guix:open-connection-for-uri)))
   #:use-module (web request)
   #:use-module (web response)
   #:use-module (srfi srfi-1)
@@ -453,7 +452,7 @@ for connections to complete; when TIMEOUT is #f, wait as long as needed."
                    (force-output port)
                    (read-response port))
                  (lambda ()
-                   (close-connection port))))
+                   (close-port port))))
 
              (case (response-code response)
                ((302                    ; found (redirection)
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 7eca2c6874..3bf9b8735f 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
 ;;;
@@ -20,7 +20,7 @@
 
 (define-module (guix scripts substitute)
   #:use-module (guix ui)
-  #:use-module ((guix store) #:hide (close-connection))
+  #:use-module (guix store)
   #:use-module (guix utils)
   #:use-module (guix combinators)
   #:use-module (guix config)
@@ -37,7 +37,6 @@
                 #:select (uri-abbreviation nar-uri-abbreviation
                           (open-connection-for-uri
                            . guix:open-connection-for-uri)
-                          close-connection
                           store-path-abbreviation byte-count->string))
   #:use-module (guix progress)
   #:use-module ((guix build syscalls)
@@ -556,7 +555,7 @@ initial connection on which HTTP requests are sent."
              ;; Note that even upon "Connection: close", we can read from BODY.
              (match (assq 'connection (response-headers resp))
                (('connection 'close)
-                (close-connection p)
+                (close-port p)
                 (connect #f                       ;try again
                          (append tail (drop requests processed))
                          result))