diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build/download.scm | 66 | ||||
| -rw-r--r-- | guix/http-client.scm | 13 | ||||
| -rw-r--r-- | guix/lint.scm | 9 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 7 |
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)) |