;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
#: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)
;; be bound if we need them, because (guix download) adds GnuTLS as an
;; input in that case.
-;; XXX: Use this hack instead of #:autoload to avoid compilation errors.
-;; See <http://bugs.gnu.org/12202>.
-(module-autoload! (current-module)
- '(gnutls)
- '(gnutls-version 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 (load-gnutls)
+ ;; XXX: Use this hack instead of #:autoload to avoid compilation errors.
+ ;; See <http://bugs.gnu.org/12202>.
+ (module-use! (resolve-module '(guix build download))
+ (resolve-interface '(gnutls)))
+ (set! load-gnutls (const #t)))
(define %x509-certificate-directory
;; The directory where X.509 authority PEM certificates are stored.
(make-parameter (or (getenv "GUIX_TLS_CERTIFICATE_DIRECTORY")
- (getenv "SSL_CERT_DIR")))) ;like OpenSSL
+ (getenv "SSL_CERT_DIR") ;like OpenSSL
+ "/etc/ssl/certs")))
(define (set-certificate-credentials-x509-trust-file!* cred file format)
"Like 'set-certificate-credentials-x509-trust-file!', but without the file
DIRECTORY. Those authority certificates are checked when
'peer-certificate-status' is later called."
(let ((cred (make-certificate-credentials))
- (files (or (scandir directory
- (lambda (file)
- (string-suffix? ".pem" file)))
- '())))
+ (files (match (scandir directory (cut string-suffix? ".pem" <>))
+ ((or #f ())
+ ;; Some distros provide nothing but bundles (*.crt) under
+ ;; /etc/ssl/certs, so look for them.
+ (or (scandir directory (cut string-suffix? ".crt" <>))
+ '()))
+ (pem pem))))
(for-each (lambda (file)
(let ((file (string-append directory "/" file)))
;; Protect against dangling symlinks.
(set-certificate-credentials-x509-trust-file!*
cred file
x509-certificate-format/pem))))
- (or files '()))
+ files)
cred))
(define (peer-certificate session)
(format (current-error-port)
"gnutls: [~a|~a] ~a" (getpid) level str))
+ (load-gnutls)
(let ((session (make-session connection-end/client))
(ca-certs (%x509-certificate-directory)))
;; "(gnutls) Priority Strings"); see <http://bugs.gnu.org/23311>.
;; Explicitly disable SSLv3, which is insecure:
;; <https://tools.ietf.org/html/rfc7568>.
- ;;
- ;; FIXME: Since we currently fail to handle TLS 1.3 (with GnuTLS 3.6.5),
- ;; remove it; see <https://bugs.gnu.org/34102>.
- (set-session-priorities! session
- (string-append
- "NORMAL:%COMPAT:-VERS-SSL3.0"
-
- ;; The "VERS-TLS1.3" priority string is not
- ;; supported by GnuTLS 3.5.
- (if (string-prefix? "3.5." (gnutls-version))
- ""
- ":-VERS-TLS1.3")))
+ (set-session-priorities! session "NORMAL:%COMPAT:-VERS-SSL3.0")
(set-session-credentials! session
(if (and verify-certificate? ca-certs)
(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
(apply throw args)
(loop (cdr addresses))))))))
+(define (setup-http-tunnel port uri)
+ "Establish over PORT an HTTP tunnel to the destination server of URI."
+ (define target
+ (string-append (uri-host uri) ":"
+ (number->string
+ (or (uri-port uri)
+ (match (uri-scheme uri)
+ ('http 80)
+ ('https 443))))))
+ (format port "CONNECT ~a HTTP/1.1\r\n" target)
+ (format port "Host: ~a\r\n\r\n" target)
+ (force-output port)
+ (read-response port))
+
(define* (open-connection-for-uri uri
#:key
timeout
(define https?
(eq? 'https (uri-scheme uri)))
+ (define https-proxy (let ((proxy (getenv "https_proxy")))
+ (and (not (equal? proxy ""))
+ proxy)))
+
(let-syntax ((with-https-proxy
(syntax-rules ()
((_ exp)
;; For HTTPS URIs, honor 'https_proxy', not 'http_proxy'.
- ;; FIXME: Proxying is not supported for https.
(let ((thunk (lambda () exp)))
(if (and https?
(module-variable
(resolve-interface '(web client))
'current-http-proxy))
- (parameterize ((current-http-proxy #f))
- (when (and=> (getenv "https_proxy")
- (negate string-null?))
- (format (current-error-port)
- "warning: 'https_proxy' is ignored~%"))
+ (parameterize ((current-http-proxy https-proxy))
(thunk))
(thunk)))))))
(with-https-proxy
;; Buffer input and output on this port.
(setvbuf s 'block %http-receive-buffer-size)
+ (when (and https? https-proxy)
+ (setup-http-tunnel s uri))
+
(if https?
(tls-wrap s (uri-host uri)
#: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
'set-port-encoding!
(lambda (p e) #f))
-;; XXX: Work around <http://bugs.gnu.org/23421>, fixed in Guile commit
-;; 16050431f29d56f80c4a8253506fc851b8441840. Guile's date validation
-;; procedure rejects dates in which the hour is not padded with a zero but
-;; with whitespace.
-(begin
- (define-syntax string-match?
- (lambda (x)
- (syntax-case x ()
- ((_ str pat) (string? (syntax->datum #'pat))
- (let ((p (syntax->datum #'pat)))
- #`(let ((s str))
- (and
- (= (string-length s) #,(string-length p))
- #,@(let lp ((i 0) (tests '()))
- (if (< i (string-length p))
- (let ((c (string-ref p i)))
- (lp (1+ i)
- (case c
- ((#\.) ; Whatever.
- tests)
- ((#\d) ; Digit.
- (cons #`(char-numeric? (string-ref s #,i))
- tests))
- ((#\a) ; Alphabetic.
- (cons #`(char-alphabetic? (string-ref s #,i))
- tests))
- (else ; Literal.
- (cons #`(eqv? (string-ref s #,i) #,c)
- tests)))))
- tests)))))))))
-
- (define (parse-rfc-822-date str space zone-offset)
- (let ((parse-non-negative-integer (@@ (web http) parse-non-negative-integer))
- (parse-month (@@ (web http) parse-month))
- (bad-header (@@ (web http) bad-header)))
- ;; We could verify the day of the week but we don't.
- (cond ((string-match? (substring str 0 space) "aaa, dd aaa dddd dd:dd:dd")
- (let ((date (parse-non-negative-integer str 5 7))
- (month (parse-month str 8 11))
- (year (parse-non-negative-integer str 12 16))
- (hour (parse-non-negative-integer str 17 19))
- (minute (parse-non-negative-integer str 20 22))
- (second (parse-non-negative-integer str 23 25)))
- (make-date 0 second minute hour date month year zone-offset)))
- ((string-match? (substring str 0 space) "aaa, d aaa dddd dd:dd:dd")
- (let ((date (parse-non-negative-integer str 5 6))
- (month (parse-month str 7 10))
- (year (parse-non-negative-integer str 11 15))
- (hour (parse-non-negative-integer str 16 18))
- (minute (parse-non-negative-integer str 19 21))
- (second (parse-non-negative-integer str 22 24)))
- (make-date 0 second minute hour date month year zone-offset)))
-
- ;; The next two clauses match dates that have a space instead of
- ;; a leading zero for hours, like " 8:49:37".
- ((string-match? (substring str 0 space) "aaa, dd aaa dddd d:dd:dd")
- (let ((date (parse-non-negative-integer str 5 7))
- (month (parse-month str 8 11))
- (year (parse-non-negative-integer str 12 16))
- (hour (parse-non-negative-integer str 18 19))
- (minute (parse-non-negative-integer str 20 22))
- (second (parse-non-negative-integer str 23 25)))
- (make-date 0 second minute hour date month year zone-offset)))
- ((string-match? (substring str 0 space) "aaa, d aaa dddd d:dd:dd")
- (let ((date (parse-non-negative-integer str 5 6))
- (month (parse-month str 7 10))
- (year (parse-non-negative-integer str 11 15))
- (hour (parse-non-negative-integer str 17 18))
- (minute (parse-non-negative-integer str 19 21))
- (second (parse-non-negative-integer str 22 24)))
- (make-date 0 second minute hour date month year zone-offset)))
-
- (else
- (bad-header 'date str) ; prevent tail call
- #f))))
- (module-set! (resolve-module '(web http))
- 'parse-rfc-822-date parse-rfc-822-date))
-
-;; XXX: Work around broken proxy handling on Guile 2.2 <= 2.2.2, fixed in
-;; Guile commits 7d0d9e2c25c1e872cfc7d14ab5139915f1813d56 and
-;; 6ad28ae3bc6a6d9e95ab7d70510d12c97673a143. See bug report at
-;; <https://lists.gnu.org/archive/html/guix-devel/2017-11/msg00070.html>.
-(cond-expand
- (guile-2.2
- (when (<= (string->number (micro-version)) 2)
- (let ()
- (define put-symbol (@@ (web http) put-symbol))
- (define put-non-negative-integer
- (@@ (web http) put-non-negative-integer))
- (define write-http-version
- (@@ (web http) write-http-version))
-
- (define (write-request-line method uri version port)
- "Write the first line of an HTTP request to PORT."
- (put-symbol port method)
- (put-char port #\space)
- (when (http-proxy-port? port)
- (let ((scheme (uri-scheme uri))
- (host (uri-host uri))
- (host-port (uri-port uri)))
- (when (and scheme host)
- (put-symbol port scheme)
- (put-string port "://")
- (cond
- ((string-index host #\:) ;<---- The fix is here!
- (put-char port #\[) ;<---- And here!
- (put-string port host)
- (put-char port #\]))
- (else
- (put-string port host)))
- (unless ((@@ (web uri) default-port?) scheme host-port)
- (put-char port #\:)
- (put-non-negative-integer port host-port)))))
- (let ((path (uri-path uri))
- (query (uri-query uri)))
- (if (string-null? path)
- (put-string port "/")
- (put-string port path))
- (when query
- (put-string port "?")
- (put-string port query)))
- (put-char port #\space)
- (write-http-version version port)
- (put-string port "\r\n"))
-
- (module-set! (resolve-module '(web http)) 'write-request-line
- write-request-line))))
- (else #t))
-
(define (resolve-uri-reference ref base)
"Resolve the URI reference REF, interpreted relative to the BASE URI, into a
target URI, according to the algorithm specified in RFC 3986 section 5.2.2.
(()
(format (current-error-port) "failed to download ~s from ~s~%"
file url)
+
+ ;; Remove FILE in case we made an incomplete download, for example due
+ ;; to ENOSPC.
+ (catch 'system-error
+ (lambda ()
+ (delete-file file))
+ (const #f))
#f))))
;;; download.scm ends here
HCoop / jackhill / guix / guix.git / blobdiff