diff options
Diffstat (limited to 'guix/scripts/substitute-binary.scm')
| -rwxr-xr-x | guix/scripts/substitute-binary.scm | 100 |
1 files changed, 87 insertions, 13 deletions
diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 13c382877b..271a22541a 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -24,12 +24,15 @@ #:use-module (guix records) #:use-module (guix nar) #:use-module ((guix build utils) #:select (mkdir-p)) + #:use-module ((guix build download) + #:select (progress-proc uri-abbreviation)) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (ice-9 match) #:use-module (ice-9 threads) #:use-module (ice-9 format) #:use-module (ice-9 ftw) + #:use-module (ice-9 binary-ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) @@ -117,7 +120,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 +161,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?) @@ -353,7 +401,8 @@ indefinitely." (cute write (time-second now) <>)))) (define (decompressed-port compression input) - "Return an input port where INPUT is decompressed according to COMPRESSION." + "Return an input port where INPUT is decompressed according to COMPRESSION, +along with a list of PIDs to wait for." (match compression ("none" (values input '())) ("bzip2" (filtered-port `(,%bzip2 "-dc") input)) @@ -361,6 +410,24 @@ indefinitely." ("gzip" (filtered-port `(,%gzip "-dc") input)) (else (error "unsupported compression scheme" compression)))) +(define (progress-report-port report-progress port) + "Return a port that calls REPORT-PROGRESS every time something is read from +PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by +`progress-proc'." + (define total 0) + (define (read! bv start count) + (let ((n (match (get-bytevector-n! port bv start count) + ((? eof-object?) 0) + (x x)))) + (set! total (+ total n)) + (report-progress total (const n)) + ;; XXX: We're not in control, so we always return anyway. + n)) + + (make-custom-binary-input-port "progress-port-proc" + read! #f #f + (cut close-port port))) + (define %cache-url (or (getenv "GUIX_BINARY_SUBSTITUTE_URL") "http://hydra.gnu.org")) @@ -442,19 +509,25 @@ indefinitely." ;; Tell the daemon what the expected hash of the Nar itself is. (format #t "~a~%" (narinfo-hash narinfo)) + (format (current-error-port) "downloading `~a' from `~a'...~%" + store-path (uri->string uri)) (let*-values (((raw download-size) - (fetch uri #:buffered? #f)) + ;; Note that Hydra currently generates Nars on the fly + ;; and doesn't specify a Content-Length, so + ;; DOWNLOAD-SIZE is #f in practice. + (fetch uri #:buffered? #f #:timeout? #f)) + ((progress) + (let* ((comp (narinfo-compression narinfo)) + (dl-size (or download-size + (and (equal? comp "none") + (narinfo-size narinfo)))) + (progress (progress-proc (uri-abbreviation uri) + dl-size + (current-error-port)))) + (progress-report-port progress raw))) ((input pids) (decompressed-port (narinfo-compression narinfo) - raw))) - ;; Note that Hydra currently generates Nars on the fly and doesn't - ;; specify a Content-Length, so DOWNLOAD-SIZE is #f in practice. - (format (current-error-port) - (_ "downloading `~a' from `~a'~:[~*~; (~,1f KiB)~]...~%") - store-path (uri->string uri) - download-size - (and=> download-size (cut / <> 1024.0))) - + progress))) ;; Unpack the Nar at INPUT into DESTINATION. (restore-file input destination) (every (compose zero? cdr waitpid) pids)))) @@ -464,6 +537,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 |