;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2012, 2015 Free Software Foundation, Inc.
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
#:use-module (guix utils)
#:use-module (guix base64)
#:autoload (gcrypt hash) (sha256)
+ #:autoload (gnutls) (error/invalid-session error/again error/interrupted)
#:use-module ((guix build utils)
#:select (mkdir-p dump-port))
#:use-module ((guix build download)
(define* (http-fetch uri #:key port (text? #f) (buffered? #t)
+ (open-connection guix:open-connection-for-uri)
(keep-alive? #f)
(verify-certificate? #t)
(headers '((user-agent . "GNU Guile")))
+ (log-port (current-error-port))
timeout)
"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
TIMEOUT specifies the timeout in seconds for connection establishment; when
TIMEOUT is #f, connection establishment never times out.
+Write information about redirects to LOG-PORT.
+
Raise an '&http-get-error' condition if downloading fails."
(let loop ((uri (if (string? uri)
(string->uri uri)
uri)))
- (let ((port (or port (guix:open-connection-for-uri uri
- #:verify-certificate?
- verify-certificate?
- #:timeout timeout)))
+ (let ((port (or port (open-connection uri
+ #:verify-certificate?
+ verify-certificate?
+ #:timeout timeout)))
(headers (match (uri-userinfo uri)
((? string? str)
(cons (cons 'Authorization
308) ; permanent redirection
(let ((uri (resolve-uri-reference (response-location resp) uri)))
(close-port port)
- (format (current-error-port) (G_ "following redirection to `~a'...~%")
+ (format log-port (G_ "following redirection to `~a'...~%")
(uri->string uri))
(loop uri)))
(else
(uri->string uri) code
(response-reason-phrase resp))))))))))))
+(define-syntax-rule (false-if-networking-error exp)
+ "Return #f if EXP triggers a network related exception as can occur when
+reusing stale cached connections."
+ ;; FIXME: Duplicated from 'with-cached-connection'.
+ (catch #t
+ (lambda ()
+ exp)
+ (lambda (key . args)
+ ;; If PORT was cached and the server closed the connection in the
+ ;; meantime, we get EPIPE. In that case, open a fresh connection and
+ ;; retry. We might also get 'bad-response or a similar exception from
+ ;; (web response) later on, once we've sent the request, or a
+ ;; ERROR/INVALID-SESSION from GnuTLS.
+ (if (or (and (eq? key 'system-error)
+ (= EPIPE (system-error-errno `(,key ,@args))))
+ (and (eq? key 'gnutls-error)
+ (memq (first args)
+ (list error/invalid-session
+
+ ;; XXX: These two are not properly handled in
+ ;; GnuTLS < 3.7.2, in
+ ;; 'write_to_session_record_port'; see
+ ;; <https://bugs.gnu.org/47867>.
+ error/again error/interrupted)))
+ (memq key
+ '(bad-response bad-header bad-header-component)))
+ #f
+ (apply throw key args)))))
+
(define* (http-multiple-get base-uri proc seed requests
#:key port (verify-certificate? #t)
(open-connection guix:open-connection-for-uri)
;; Inherit the HTTP proxying property from P.
(set-http-proxy-port?! buffer (http-proxy-port? p))
- (for-each (cut write-request <> buffer)
- batch)
- (put-bytevector p (get))
- (force-output p))
+ ;; Swallow networking errors that could occur due to connection reuse
+ ;; and the like; they will be handled down the road when trying to
+ ;; read responses.
+ (false-if-networking-error
+ (begin
+ (for-each (cut write-request <> buffer) batch)
+ (put-bytevector p (get))
+ (force-output p))))
;; Now start processing responses.
(let loop ((sent batch)
(remainder
(connect p remainder result))))
((head tail ...)
- (let* ((resp (read-response p))
- (body (response-body-port resp))
- (result (proc head resp body result)))
- ;; The server can choose to stop responding at any time, in which
- ;; case we have to try again. Check whether that is the case.
- ;; Note that even upon "Connection: close", we can read from BODY.
- (match (assq 'connection (response-headers resp))
- (('connection 'close)
- (close-port p)
- (connect #f ;try again
- (drop requests (+ 1 processed))
- result))
- (_
- (loop tail (+ 1 processed) result)))))))))) ;keep going
+ (match (false-if-networking-error (read-response p))
+ ((? response? resp)
+ (let* ((body (response-body-port resp))
+ (result (proc head resp body result)))
+ ;; The server can choose to stop responding at any time,
+ ;; in which case we have to try again. Check whether
+ ;; that is the case. Note that even upon "Connection:
+ ;; close", we can read from BODY.
+ (match (assq 'connection (response-headers resp))
+ (('connection 'close)
+ (close-port p)
+ (connect #f ;try again
+ (drop requests (+ 1 processed))
+ result))
+ (_
+ (loop tail (+ 1 processed) result)))))
+ (#f
+ (close-port p)
+ (connect #f ; try again
+ (drop requests processed)
+ result)))))))))
\f
;;;
(define* (http-fetch/cached uri #:key (ttl (%http-cache-ttl)) text?
(write-cache dump-port)
(cache-miss (const #t))
+ (log-port (current-error-port))
(timeout 10))
"Like 'http-fetch', return an input port, but cache its contents in
~/.cache/guix. The cache remains valid for TTL seconds.
the data to cache. Call CACHE-MISS with URI just before fetching data from
URI.
-TIMEOUT specifies the timeout in seconds for connection establishment."
+TIMEOUT specifies the timeout in seconds for connection establishment.
+
+Write information about redirects to LOG-PORT."
(let ((file (cache-file-for-uri uri)))
(define (update-cache cache-port)
(define cache-time
cache-port)
(raise c))))
(let ((port (http-fetch uri #:text? text?
+ #:log-port log-port
#:headers headers #:timeout timeout)))
(cache-miss uri)
(mkdir-p (dirname file))
HCoop / jackhill / guix / guix.git / blobdiff