nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

substitute-binary: Gracefully exit upon networking errors. 

Suggested by Andreas Enge <andreas@enge.fr>.

* guix/scripts/substitute-binary.scm (with-networking): New macro.
  (guix-substitute-binary): Wrap the body in `with-networking'.
This commit is contained in:
Ludovic Courtès 2013-05-29 23:21:54 +02:00
parent 56b1f4b780
commit cf5d2ca329
1 changed files with 84 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

154
guix/scripts/substitute-binary.scm
View File

@ -361,6 +361,19 @@ indefinitely."
(or (getenv "GUIX_BINARY_SUBSTITUTE_URL") (or (getenv "GUIX_BINARY_SUBSTITUTE_URL")
"http://hydra.gnu.org")) "http://hydra.gnu.org"))
(define-syntax with-networking
(syntax-rules ()
"Catch DNS lookup errors and gracefully exit."
;; Note: no attempt is made to catch other networking errors, because DNS
;; lookup errors are typically the first one, and because other errors are
;; a subset of `system-error', which is harder to filter.
((_ exp ...)
(catch 'getaddrinfo-error
(lambda () exp ...)
(lambda (key error)
(leave (_ "host name lookup error: ~a~%")
(gai-strerror error)))))))
;;; ;;;
;;; Entry point. ;;; Entry point.
@ -370,77 +383,78 @@ indefinitely."
"Implement the build daemon's substituter protocol." "Implement the build daemon's substituter protocol."
(mkdir-p %narinfo-cache-directory) (mkdir-p %narinfo-cache-directory)
(maybe-remove-expired-cached-narinfo) (maybe-remove-expired-cached-narinfo)
(match args (with-networking
(("--query") (match args
(let ((cache (delay (open-cache %cache-url)))) (("--query")
(let loop ((command (read-line))) (let ((cache (delay (open-cache %cache-url))))
(or (eof-object? command) (let loop ((command (read-line)))
(begin (or (eof-object? command)
(match (string-tokenize command) (begin
(("have" paths ..1) (match (string-tokenize command)
;; Return the subset of PATHS available in CACHE. (("have" paths ..1)
(let ((substitutable ;; Return the subset of PATHS available in CACHE.
(if cache (let ((substitutable
(par-map (cut lookup-narinfo cache <>) (if cache
paths) (par-map (cut lookup-narinfo cache <>)
'()))) paths)
(for-each (lambda (narinfo) '())))
(when narinfo (for-each (lambda (narinfo)
(format #t "~a~%" (narinfo-path narinfo)))) (when narinfo
(filter narinfo? substitutable)) (format #t "~a~%" (narinfo-path narinfo))))
(newline))) (filter narinfo? substitutable))
(("info" paths ..1) (newline)))
;; Reply info about PATHS if it's in CACHE. (("info" paths ..1)
(let ((substitutable ;; Reply info about PATHS if it's in CACHE.
(if cache (let ((substitutable
(par-map (cut lookup-narinfo cache <>) (if cache
paths) (par-map (cut lookup-narinfo cache <>)
'()))) paths)
(for-each (lambda (narinfo) '())))
(format #t "~a\n~a\n~a\n" (for-each (lambda (narinfo)
(narinfo-path narinfo) (format #t "~a\n~a\n~a\n"
(or (and=> (narinfo-deriver narinfo) (narinfo-path narinfo)
(cute string-append (or (and=> (narinfo-deriver narinfo)
(%store-prefix) "/" (cute string-append
<>)) (%store-prefix) "/"
"") <>))
(length (narinfo-references narinfo))) "")
(for-each (cute format #t "~a/~a~%" (length (narinfo-references narinfo)))
(%store-prefix) <>) (for-each (cute format #t "~a/~a~%"
(narinfo-references narinfo)) (%store-prefix) <>)
(format #t "~a\n~a\n" (narinfo-references narinfo))
(or (narinfo-file-size narinfo) 0) (format #t "~a\n~a\n"
(or (narinfo-size narinfo) 0))) (or (narinfo-file-size narinfo) 0)
(filter narinfo? substitutable)) (or (narinfo-size narinfo) 0)))
(newline))) (filter narinfo? substitutable))
(wtf (newline)))
(error "unknown `--query' command" wtf))) (wtf
(loop (read-line))))))) (error "unknown `--query' command" wtf)))
(("--substitute" store-path destination) (loop (read-line)))))))
;; Download STORE-PATH and add store it as a Nar in file DESTINATION. (("--substitute" store-path destination)
(let* ((cache (delay (open-cache %cache-url))) ;; Download STORE-PATH and add store it as a Nar in file DESTINATION.
(narinfo (lookup-narinfo cache store-path)) (let* ((cache (delay (open-cache %cache-url)))
(uri (narinfo-uri narinfo))) (narinfo (lookup-narinfo cache store-path))
;; Tell the daemon what the expected hash of the Nar itself is. (uri (narinfo-uri narinfo)))
(format #t "~a~%" (narinfo-hash narinfo)) ;; Tell the daemon what the expected hash of the Nar itself is.
(format #t "~a~%" (narinfo-hash narinfo))
(let*-values (((raw download-size) (let*-values (((raw download-size)
(fetch uri #:buffered? #f)) (fetch uri #:buffered? #f))
((input pids) ((input pids)
(decompressed-port (narinfo-compression narinfo) (decompressed-port (narinfo-compression narinfo)
raw))) raw)))
;; Note that Hydra currently generates Nars on the fly and doesn't ;; Note that Hydra currently generates Nars on the fly and doesn't
;; specify a Content-Length, so DOWNLOAD-SIZE is #f in practice. ;; specify a Content-Length, so DOWNLOAD-SIZE is #f in practice.
(format (current-error-port) (format (current-error-port)
(_ "downloading `~a' from `~a'~:[~*~; (~,1f KiB)~]...~%") (_ "downloading `~a' from `~a'~:[~*~; (~,1f KiB)~]...~%")
store-path (uri->string uri) store-path (uri->string uri)
download-size download-size
(and=> download-size (cut / <> 1024.0))) (and=> download-size (cut / <> 1024.0)))
;; Unpack the Nar at INPUT into DESTINATION. ;; Unpack the Nar at INPUT into DESTINATION.
(restore-file input destination) (restore-file input destination)
(every (compose zero? cdr waitpid) pids)))) (every (compose zero? cdr waitpid) pids))))
(("--version") (("--version")
(show-version-and-exit "guix substitute-binary")))) (show-version-and-exit "guix substitute-binary")))))
;;; substitute-binary.scm ends here ;;; substitute-binary.scm ends here