From b879b3e848d9cf4f4cc39ba8164f8b6be346313c Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Thu, 17 Mar 2016 21:57:15 +0100
Subject: substitute: Do not leak file descriptors for TLS connections.

Partially fixes <http://bugs.gnu.org/20145>.

* guix/scripts/substitute.scm (fetch, download-cache-info):
(http-multiple-get, fetch-narinfos, progress-report-port): Use
'close-connection' instead of 'close-port'.
---
 guix/scripts/substitute.scm | 16 ++++++++--------
 1 file changed, 8 insertions(+), 8 deletions(-)

(limited to 'guix/scripts')

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index c9e2ca3b83..4563f3df0f 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -19,7 +19,7 @@
 
 (define-module (guix scripts substitute)
   #:use-module (guix ui)
-  #:use-module (guix store)
+  #:use-module ((guix store) #:hide (close-connection))
   #:use-module (guix utils)
   #:use-module (guix config)
   #:use-module (guix records)
@@ -33,6 +33,7 @@ (define-module (guix scripts substitute)
   #:use-module ((guix build download)
                 #:select (progress-proc uri-abbreviation
                           open-connection-for-uri
+                          close-connection
                           store-path-abbreviation byte-count->string))
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 regex)
@@ -200,7 +201,7 @@ (define* (fetch uri #:key (buffered? #t) (timeout? #t))
              (unless (or (guile-version>? "2.0.9")
                          (version>? (version) "2.0.9.39"))
                (when port
-                 (close-port port))))
+                 (close-connection port))))
            (begin
              (when (or (not port) (port-closed? port))
                (set! port (open-connection-for-uri uri))
@@ -245,7 +246,7 @@ (define (read-cache-info port)
                                (uri->string (http-get-error-uri c))
                                (http-get-error-code c)
                                (http-get-error-reason c))
-                      (close-port port)
+                      (close-connection port)
                       (warning (_ "ignoring substitute server at '~s'~%") url)
                       (values #f #f)))
              (values (read-cache-info (http-fetch uri
@@ -555,7 +556,7 @@ (define* (http-multiple-get base-uri proc seed requests
              ;; Note that even upon "Connection: close", we can read from BODY.
              (match (assq 'connection (response-headers resp))
                (('connection 'close)
-                (close-port p)
+                (close-connection p)
                 (connect #f tail result))         ;try again
                (_
                 (loop tail result))))))))))       ;keep going
@@ -623,8 +624,7 @@ (define (do-fetch uri port)
                                           handle-narinfo-response '()
                                           requests
                                           #:port port)))
-           (unless (port-closed? port)
-             (close-port port))
+           (close-connection port)
            (newline (current-error-port))
            result)))
       ((file #f)
@@ -646,7 +646,7 @@ (define (do-fetch uri port)
              (begin
                (warning (_ "'~a' uses different store '~a'; ignoring it~%")
                         url (cache-info-store-directory cache-info))
-               (close-port port)
+               (close-connection port)
                #f)))))
 
 (define (lookup-narinfos cache paths)
@@ -776,7 +776,7 @@ (define (read! bv start count)
 
   (make-custom-binary-input-port "progress-port-proc"
                                  read! #f #f
-                                 (cut close-port port)))
+                                 (cut close-connection port)))
 
 (define-syntax with-networking
   (syntax-rules ()
-- 
cgit v1.2.3