aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2013-06-18 00:11:40 +0200
committerLudovic Courtès <ludo@gnu.org>2013-06-18 00:12:22 +0200
commit2207f73156e144a9349e4d395d5049119b67a896 (patch)
tree0591adc884afb84ad665a37692a55e9130d289d0
parent8cf13c1f70ac2f3d1886f2d521b16915fc3f9d29 (diff)
downloadguix-2207f73156e144a9349e4d395d5049119b67a896.tar
guix-2207f73156e144a9349e4d395d5049119b67a896.tar.gz
substitute-binary: Provide feedback when the server is unresponsive.
* guix/scripts/substitute-binary.scm (%fetch-timeout): New variable. (with-timeout): New macro. (fetch): Add `timeout?' keyword parameter. Enclose `http-fetch' call in `with-timeout'. (guix-substitute-binary): Call `fetch' with #:timeout? #f.
-rwxr-xr-xguix/scripts/substitute-binary.scm52
1 files changed, 49 insertions, 3 deletions
diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 13c382877b..ef3db77ee1 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -117,7 +117,38 @@ pairs."
(else
(error "unmatched line" line)))))
-(define* (fetch uri #:key (buffered? #t))
+(define %fetch-timeout
+ ;; Number of seconds after which networking is considered "slow".
+ 3)
+
+(define-syntax-rule (with-timeout duration handler body ...)
+ "Run BODY; when DURATION seconds have expired, call HANDLER, and run BODY
+again."
+ (begin
+ (sigaction SIGALRM
+ (lambda (signum)
+ (sigaction SIGALRM SIG_DFL)
+ handler))
+ (alarm duration)
+ (call-with-values
+ (lambda ()
+ (let try ()
+ (catch 'system-error
+ (lambda ()
+ body ...)
+ (lambda args
+ ;; The SIGALRM triggers EINTR. When that happens, try again.
+ ;; Note: SA_RESTART cannot be used because of
+ ;; <http://bugs.gnu.org/14640>.
+ (if (= EINTR (system-error-errno args))
+ (try)
+ (apply throw args))))))
+ (lambda result
+ (alarm 0)
+ (sigaction SIGALRM SIG_DFL)
+ (apply values result)))))
+
+(define* (fetch uri #:key (buffered? #t) (timeout? #t))
"Return a binary input port to URI and the number of bytes it's expected to
provide."
(case (uri-scheme uri)
@@ -127,7 +158,21 @@ provide."
(setvbuf port _IONBF))
(values port (stat:size (stat port)))))
((http)
- (http-fetch uri #:text? #f #:buffered? buffered?))))
+ ;; 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
+ (with-timeout (if (or timeout? (version>? (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~%")))
+ (http-fetch uri #:text? #f #:buffered? buffered?)))))
(define-record-type <cache>
(%make-cache url store-directory wants-mass-query?)
@@ -443,7 +488,7 @@ indefinitely."
(format #t "~a~%" (narinfo-hash narinfo))
(let*-values (((raw download-size)
- (fetch uri #:buffered? #f))
+ (fetch uri #:buffered? #f #:timeout? #f))
((input pids)
(decompressed-port (narinfo-compression narinfo)
raw)))
@@ -464,6 +509,7 @@ indefinitely."
;;; Local Variable:
;;; eval: (put 'with-atomic-file-output 'scheme-indent-function 1)
+;;; eval: (put 'with-timeout 'scheme-indent-function 1)
;;; End:
;;; substitute-binary.scm ends here