mirror/guix
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2025-02-02 08:07:29 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

substitute-binary: Gracefully handle HTTP GET errors.

Browse source 
* 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 2014-03-01 15:38:11 +01:00
parent 1f7fd80032
commit 706e9e575d
2 changed files with 61 additions and 32 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

35
guix/http-client.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; Copyright © 2012 Free Software Foundation, Inc.
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
@ -23,19 +23,36 @@ (define-module (guix http-client)
#:use-module (web client) #:use-module (web client)
#:use-module (web response) #:use-module (web response)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (rnrs io ports) #:use-module (rnrs io ports)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (guix ui) #:use-module (guix ui)
#:use-module (guix utils) #: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)) http-fetch))
;;; Commentary: ;;; Commentary:
;;; ;;;
;;; HTTP client portable among Guile versions. ;;; HTTP client portable among Guile versions, and with proper error condition
;;; reporting.
;;; ;;;
;;; Code: ;;; 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 (define-syntax when-guile<=2.0.5
(lambda (s) (lambda (s)
(syntax-case s () (syntax-case s ()
@ -154,7 +171,9 @@ (define* (http-fetch uri #:key port (text? #f) (buffered? #t))
"Return an input port containing the data at URI, and the expected number of "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 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 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 loop ((uri uri))
(let ((port (or port (let ((port (or port
(open-socket-for-uri uri (open-socket-for-uri uri
@ -202,7 +221,11 @@ (define* (http-fetch uri #:key port (text? #f) (buffered? #t))
(uri->string uri)) (uri->string uri))
(loop uri))) (loop uri)))
(else (else
(error "download failed" uri code (raise (condition (&http-get-error
(response-reason-phrase resp)))))))) (uri uri)
(code code)
(reason (response-reason-phrase resp)))
(&message
(message "download failed"))))))))))
;;; http-client.scm ends here ;;; http-client.scm ends here

58
guix/scripts/substitute-binary.scm
View file

@ -38,6 +38,7 @@ (define-module (guix scripts substitute-binary)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (srfi srfi-19) #:use-module (srfi srfi-19)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (web uri) #:use-module (web uri)
#:use-module (guix http-client) #:use-module (guix http-client)
#:export (guix-substitute-binary)) #:export (guix-substitute-binary))
@ -133,33 +134,38 @@ (define* (fetch uri #:key (buffered? #t) (timeout? #t))
(if buffered? "rb" "r0b")))) (if buffered? "rb" "r0b"))))
(values port (stat:size (stat port))))) (values port (stat:size (stat port)))))
((http) ((http)
;; On Guile 2.0.5, `http-fetch' fetches the whole thing at once. So (guard (c ((http-get-error? c)
;; honor TIMEOUT? to disable the timeout when fetching a nar. (leave (_ "download from '~a' failed: ~a, ~s~%")
;; (uri->string (http-get-error-uri c))
;; Test this with: (http-get-error-code c)
;; sudo tc qdisc add dev eth0 root netem delay 1500ms (http-get-error-reason c))))
;; and then cancel with: ;; On Guile 2.0.5, `http-fetch' fetches the whole thing at once. So
;; sudo tc qdisc del dev eth0 root ;; honor TIMEOUT? to disable the timeout when fetching a nar.
(let ((port #f)) ;;
(with-timeout (if (or timeout? (guile-version>? "2.0.5")) ;; Test this with:
%fetch-timeout ;; sudo tc qdisc add dev eth0 root netem delay 1500ms
0) ;; and then cancel with:
(begin ;; sudo tc qdisc del dev eth0 root
(warning (_ "while fetching ~a: server is unresponsive~%") (let ((port #f))
(uri->string uri)) (with-timeout (if (or timeout? (guile-version>? "2.0.5"))
(warning (_ "try `--no-substitutes' if the problem persists~%")) %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, ;; 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 ;; and thus PORT had to be closed and re-opened. This is not the
;; case afterward. ;; case afterward.
(unless (or (guile-version>? "2.0.9") (unless (or (guile-version>? "2.0.9")
(version>? (version) "2.0.9.39")) (version>? (version) "2.0.9.39"))
(when port (when port
(close-port port)))) (close-port port))))
(begin (begin
(when (or (not port) (port-closed? port)) (when (or (not port) (port-closed? port))
(set! port (open-socket-for-uri uri #:buffered? buffered?))) (set! port (open-socket-for-uri uri #:buffered? buffered?)))
(http-fetch uri #:text? #f #:port port))))))) (http-fetch uri #:text? #f #:port port))))))))
(define-record-type <cache> (define-record-type <cache>
(%make-cache url store-directory wants-mass-query?) (%make-cache url store-directory wants-mass-query?)