mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 07:26:13 -05:00
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.
This commit is contained in:
Ludovic Courtès
parent
52207b3938
commit
f4cde9ac4a
4 changed files with 50 additions and 41 deletions
|
|
@ -28,6 +28,7 @@ (define-module (guix build download)
|
|||
#: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 @@ (define* (ftp-fetch uri file #:key timeout print-build-trace?)
|
|||
'(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 @@ (define (log level str)
|
|||
(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)
|
||||
(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)))
|
||||
|
||||
;; 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)
|
||||
(setvbuf record 'block)
|
||||
|
||||
record)))
|
||||
;; 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 @@ (define https-proxy (let ((proxy (getenv "https_proxy")))
|
|||
#: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
|
||||
|
|
|
|||
|
|
@ -70,14 +70,13 @@ (define-condition-type &http-get-error &error
|
|||
|
||||
|
||||
(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 @@ (define* (http-fetch uri #:key port (text? #f) (buffered? #t)
|
|||
(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)))
|
||||
|
|
|
|||
|
|
@ -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 @@ (define-module (guix lint)
|
|||
#: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 @@ (define response
|
|||
(force-output port)
|
||||
(read-response port))
|
||||
(lambda ()
|
||||
(close-connection port))))
|
||||
(close-port port))))
|
||||
|
||||
(case (response-code response)
|
||||
((302 ; found (redirection)
|
||||
|
|
|
|||
|
|
@ -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 @@ (define-module (guix scripts substitute)
|
|||
#: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 @@ (define batch
|
|||
;; 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))
|
||||
|
|
|
|||
Loading…
Reference in a new issue