substitute-binary: Gracefully handle HTTP GET errors.
* guix/http-client.scm (&http-get-error): New condition type. (http-fetch): Raise it instead of using 'error'. * guix/scripts/substitute-binary.scm (fetch) <http>: Wrap body into 'guard' form; gracefully handle 'http-get-error?' conditions.
This commit is contained in:
Ludovic Courtès
parent
1f7fd80032
commit
706e9e575d
2 changed files with 61 additions and 32 deletions
|
|
@ -1,5 +1,5 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2012 Free Software Foundation, Inc.
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
|
|
@ -23,19 +23,36 @@
|
|||
#:use-module (web client)
|
||||
#:use-module (web response)
|
||||
#:use-module (srfi srfi-11)
|
||||
#:use-module (srfi srfi-34)
|
||||
#:use-module (srfi srfi-35)
|
||||
#:use-module (rnrs io ports)
|
||||
#:use-module (rnrs bytevectors)
|
||||
#:use-module (guix ui)
|
||||
#:use-module (guix utils)
|
||||
#:export (open-socket-for-uri
|
||||
#:export (&http-get-error
|
||||
http-get-error?
|
||||
http-get-error-uri
|
||||
http-get-error-code
|
||||
http-get-error-reason
|
||||
|
||||
open-socket-for-uri
|
||||
http-fetch))
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
;;; HTTP client portable among Guile versions.
|
||||
;;; HTTP client portable among Guile versions, and with proper error condition
|
||||
;;; reporting.
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
;; HTTP GET error.
|
||||
(define-condition-type &http-get-error &error
|
||||
http-get-error?
|
||||
(uri http-get-error-uri) ; URI
|
||||
(code http-get-error-code) ; integer
|
||||
(reason http-get-error-reason)) ; string
|
||||
|
||||
|
||||
(define-syntax when-guile<=2.0.5
|
||||
(lambda (s)
|
||||
(syntax-case s ()
|
||||
|
|
@ -154,7 +171,9 @@ unbuffered."
|
|||
"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'."
|
||||
unbuffered port, suitable for use in `filtered-port'.
|
||||
|
||||
Raise an '&http-get-error' condition if downloading fails."
|
||||
(let loop ((uri uri))
|
||||
(let ((port (or port
|
||||
(open-socket-for-uri uri
|
||||
|
|
@ -202,7 +221,11 @@ unbuffered port, suitable for use in `filtered-port'."
|
|||
(uri->string uri))
|
||||
(loop uri)))
|
||||
(else
|
||||
(error "download failed" uri code
|
||||
(response-reason-phrase resp))))))))
|
||||
(raise (condition (&http-get-error
|
||||
(uri uri)
|
||||
(code code)
|
||||
(reason (response-reason-phrase resp)))
|
||||
(&message
|
||||
(message "download failed"))))))))))
|
||||
|
||||
;;; http-client.scm ends here
|
||||
|
|
|
|||
|
|
@ -38,6 +38,7 @@
|
|||
#:use-module (srfi srfi-11)
|
||||
#:use-module (srfi srfi-19)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (srfi srfi-34)
|
||||
#:use-module (web uri)
|
||||
#:use-module (guix http-client)
|
||||
#:export (guix-substitute-binary))
|
||||
|
|
@ -133,33 +134,38 @@ provide."
|
|||
(if buffered? "rb" "r0b"))))
|
||||
(values port (stat:size (stat port)))))
|
||||
((http)
|
||||
;; On Guile 2.0.5, `http-fetch' fetches the whole thing at once. So
|
||||
;; honor TIMEOUT? to disable the timeout when fetching a nar.
|
||||
;;
|
||||
;; Test this with:
|
||||
;; sudo tc qdisc add dev eth0 root netem delay 1500ms
|
||||
;; and then cancel with:
|
||||
;; sudo tc qdisc del dev eth0 root
|
||||
(let ((port #f))
|
||||
(with-timeout (if (or timeout? (guile-version>? "2.0.5"))
|
||||
%fetch-timeout
|
||||
0)
|
||||
(begin
|
||||
(warning (_ "while fetching ~a: server is unresponsive~%")
|
||||
(uri->string uri))
|
||||
(warning (_ "try `--no-substitutes' if the problem persists~%"))
|
||||
(guard (c ((http-get-error? c)
|
||||
(leave (_ "download from '~a' failed: ~a, ~s~%")
|
||||
(uri->string (http-get-error-uri c))
|
||||
(http-get-error-code c)
|
||||
(http-get-error-reason c))))
|
||||
;; On Guile 2.0.5, `http-fetch' fetches the whole thing at once. So
|
||||
;; honor TIMEOUT? to disable the timeout when fetching a nar.
|
||||
;;
|
||||
;; Test this with:
|
||||
;; sudo tc qdisc add dev eth0 root netem delay 1500ms
|
||||
;; and then cancel with:
|
||||
;; sudo tc qdisc del dev eth0 root
|
||||
(let ((port #f))
|
||||
(with-timeout (if (or timeout? (guile-version>? "2.0.5"))
|
||||
%fetch-timeout
|
||||
0)
|
||||
(begin
|
||||
(warning (_ "while fetching ~a: server is unresponsive~%")
|
||||
(uri->string uri))
|
||||
(warning (_ "try `--no-substitutes' if the problem persists~%"))
|
||||
|
||||
;; Before Guile v2.0.9-39-gfe51c7b, EINTR was reported to the user,
|
||||
;; and thus PORT had to be closed and re-opened. This is not the
|
||||
;; case afterward.
|
||||
(unless (or (guile-version>? "2.0.9")
|
||||
(version>? (version) "2.0.9.39"))
|
||||
(when port
|
||||
(close-port port))))
|
||||
(begin
|
||||
(when (or (not port) (port-closed? port))
|
||||
(set! port (open-socket-for-uri uri #:buffered? buffered?)))
|
||||
(http-fetch uri #:text? #f #:port port)))))))
|
||||
;; Before Guile v2.0.9-39-gfe51c7b, EINTR was reported to the user,
|
||||
;; and thus PORT had to be closed and re-opened. This is not the
|
||||
;; case afterward.
|
||||
(unless (or (guile-version>? "2.0.9")
|
||||
(version>? (version) "2.0.9.39"))
|
||||
(when port
|
||||
(close-port port))))
|
||||
(begin
|
||||
(when (or (not port) (port-closed? port))
|
||||
(set! port (open-socket-for-uri uri #:buffered? buffered?)))
|
||||
(http-fetch uri #:text? #f #:port port))))))))
|
||||
|
||||
(define-record-type <cache>
|
||||
(%make-cache url store-directory wants-mass-query?)
|
||||
|
|
|
|||
Reference in a new issue