summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2015-10-28 10:11:43 +0100
committerLudovic Courtès <ludo@gnu.org>2015-10-28 12:04:03 +0100
commit55b2fc18772a512a2227757423e55dc6c7523113 (patch)
treec7b6919e49385a60b470203196a7cb9cca8075e5
parenta89dde1ed89a53f33556ab12ec73bafe495a796c (diff)
downloadpatches-55b2fc18772a512a2227757423e55dc6c7523113.tar
patches-55b2fc18772a512a2227757423e55dc6c7523113.tar.gz
substitute: Honor all the specified server URLs.
* guix/scripts/substitute.scm (lookup-narinfos/diverse): New procedure. (lookup-narinfo): Use it. (process-query): Change #:cache-url to #:cache-urls. [valid?]: Remove 'narinfo?' check, which is no longer necessary. Use 'lookup-narinfos/diverse' instead of 'lookup-narinfos'. (process-substitution): Change #:cache-url to #:cache-urls. (%cache-url): Rename to... (%cache-urls): ... this. Turn into a list. (guix-substitute): Remove 'getaddrinfo' test with early exit. Adjust calls to 'process-query' and 'process-substitution'. * tests/substitute.scm: Change '%cache-url' to '%cache-urls'.
-rwxr-xr-xguix/scripts/substitute.scm83
-rw-r--r--tests/substitute.scm4
2 files changed, 46 insertions, 41 deletions
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 34fee5863f..964df9422c 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -72,6 +72,7 @@
assert-valid-narinfo
lookup-narinfos
+ lookup-narinfos/diverse
read-narinfo
write-narinfo
guix-substitute))
@@ -610,11 +611,32 @@ information is available locally."
(let ((missing (fetch-narinfos cache missing)))
(append cached (or missing '()))))))
-(define (lookup-narinfo cache path)
- "Return the narinfo for PATH in CACHE, or #f when no substitute for PATH was
-found."
- (match (lookup-narinfos cache (list path))
- ((answer) answer)))
+(define (lookup-narinfos/diverse caches paths)
+ "Look up narinfos for PATHS on all of CACHES, a list of URLS, in that order.
+That is, when a cache lacks a narinfo, look it up in the next cache, and so
+on. Return a list of narinfos for PATHS or a subset thereof."
+ (let loop ((caches caches)
+ (paths paths)
+ (result '()))
+ (match paths
+ (() ;we're done
+ result)
+ (_
+ (match caches
+ ((cache rest ...)
+ (let* ((narinfos (lookup-narinfos cache paths))
+ (hits (map narinfo-path narinfos))
+ (missing (lset-difference string=? paths hits))) ;XXX: perf
+ (loop rest missing (append narinfos result))))
+ (() ;that's it
+ result))))))
+
+(define (lookup-narinfo caches path)
+ "Return the narinfo for PATH in CACHES, or #f when no substitute for PATH
+was found."
+ (match (lookup-narinfos/diverse caches (list path))
+ ((answer) answer)
+ (_ #f)))
(define (remove-expired-cached-narinfos directory)
"Remove expired narinfo entries from DIRECTORY. The sole purpose of this
@@ -756,34 +778,34 @@ expected by the daemon."
(or (narinfo-size narinfo) 0)))
(define* (process-query command
- #:key cache-url acl)
+ #:key cache-urls acl)
"Reply to COMMAND, a query as written by the daemon to this process's
standard input. Use ACL as the access-control list against which to check
authorized substitutes."
(define (valid? obj)
- (and (narinfo? obj) (valid-narinfo? obj acl)))
+ (valid-narinfo? obj acl))
(match (string-tokenize command)
(("have" paths ..1)
- ;; Return the subset of PATHS available in CACHE-URL.
- (let ((substitutable (lookup-narinfos cache-url paths)))
+ ;; Return the subset of PATHS available in CACHE-URLS.
+ (let ((substitutable (lookup-narinfos/diverse cache-urls paths)))
(for-each (lambda (narinfo)
(format #t "~a~%" (narinfo-path narinfo)))
(filter valid? substitutable))
(newline)))
(("info" paths ..1)
- ;; Reply info about PATHS if it's in CACHE-URL.
- (let ((substitutable (lookup-narinfos cache-url paths)))
+ ;; Reply info about PATHS if it's in CACHE-URLS.
+ (let ((substitutable (lookup-narinfos/diverse cache-urls paths)))
(for-each display-narinfo-data (filter valid? substitutable))
(newline)))
(wtf
(error "unknown `--query' command" wtf))))
(define* (process-substitution store-item destination
- #:key cache-url acl)
- "Substitute STORE-ITEM (a store file name) from CACHE-URL, and write it to
+ #:key cache-urls acl)
+ "Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to
DESTINATION as a nar file. Verify the substitute against ACL."
- (let* ((narinfo (lookup-narinfo cache-url store-item))
+ (let* ((narinfo (lookup-narinfo cache-urls store-item))
(uri (narinfo-uri narinfo)))
;; Make sure it is signed and everything.
(assert-valid-narinfo narinfo acl)
@@ -880,21 +902,16 @@ found."
b
first)))
-(define %cache-url
+(define %cache-urls
(match (and=> (or* (find-daemon-option "untrusted-substitute-urls") ;client
(find-daemon-option "substitute-urls")) ;admin
string-tokenize)
- ((url)
- url)
- ((head tail ..1)
- ;; Currently we don't handle multiple substitute URLs.
- (warning (_ "these substitute URLs will not be used:~{ ~a~}~%")
- tail)
- head)
+ ((urls ...)
+ urls)
(#f
;; This can only happen when this script is not invoked by the
;; daemon.
- "http://hydra.gnu.org")))
+ '("http://hydra.gnu.org"))))
(define (guix-substitute . args)
"Implement the build daemon's substituter protocol."
@@ -905,20 +922,8 @@ found."
;; Starting from commit 22144afa in Nix, we are allowed to bail out directly
;; when we know we cannot substitute, but we must emit a newline on stdout
;; when everything is alright.
- (let ((uri (string->uri %cache-url)))
- (case (uri-scheme uri)
- ((http)
- ;; Exit gracefully if there's no network access.
- (let ((host (uri-host uri)))
- (catch 'getaddrinfo-error
- (lambda ()
- (getaddrinfo host))
- (lambda (key error)
- (warning (_ "failed to look up host '~a' (~a), \
-substituter disabled~%")
- host (gai-strerror error))
- (exit 0)))))
- (else #t)))
+ (when (null? %cache-urls)
+ (exit 0))
;; Say hello (see above.)
(newline)
@@ -933,13 +938,13 @@ substituter disabled~%")
(or (eof-object? command)
(begin
(process-query command
- #:cache-url %cache-url
+ #:cache-urls %cache-urls
#:acl acl)
(loop (read-line)))))))
(("--substitute" store-path destination)
;; Download STORE-PATH and add store it as a Nar in file DESTINATION.
(process-substitution store-path destination
- #:cache-url %cache-url
+ #:cache-urls %cache-urls
#:acl (current-acl)))
(("--version")
(show-version-and-exit "guix substitute"))
diff --git a/tests/substitute.scm b/tests/substitute.scm
index 85698127fa..9d907e7abf 100644
--- a/tests/substitute.scm
+++ b/tests/substitute.scm
@@ -167,8 +167,8 @@ a file for NARINFO."
(call-with-narinfo narinfo (lambda () body ...)))
;; Transmit these options to 'guix substitute'.
-(set! (@@ (guix scripts substitute) %cache-url)
- (getenv "GUIX_BINARY_SUBSTITUTE_URL"))
+(set! (@@ (guix scripts substitute) %cache-urls)
+ (list (getenv "GUIX_BINARY_SUBSTITUTE_URL")))
(test-equal "query narinfo without signature"
"" ; not substitutable