[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
09/10: substitute: Honor all the specified server URLs.
From: |
Ludovic Courtès |
Subject: |
09/10: substitute: Honor all the specified server URLs. |
Date: |
Wed, 28 Oct 2015 11:04:48 +0000 |
civodul pushed a commit to branch master
in repository guix.
commit 55b2fc18772a512a2227757423e55dc6c7523113
Author: Ludovic Courtès <address@hidden>
Date: Wed Oct 28 10:11:43 2015 +0100
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'.
---
guix/scripts/substitute.scm | 83 +++++++++++++++++++++++--------------------
tests/substitute.scm | 4 +-
2 files changed, 46 insertions(+), 41 deletions(-)
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 34fee58..964df94 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 8569812..9d907e7 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
- branch master updated (b1b9e5c -> 5c7bdc9), Ludovic Courtès, 2015/10/28
- 03/10: gnu: linux-libre: On MIPS, the linux image name is vmlinuz, not bzImage., Ludovic Courtès, 2015/10/28
- 05/10: gnu: grub: Use modify-phases and other minor cleanups., Ludovic Courtès, 2015/10/28
- 02/10: gnu: linux-libre: Add case for ARCH=mips., Ludovic Courtès, 2015/10/28
- 01/10: gnu: linux-libre: Add 'supported-systems' field: Intel only for now., Ludovic Courtès, 2015/10/28
- 06/10: gnu: grub: Install documentation., Ludovic Courtès, 2015/10/28
- 04/10: doc: Add texinfo to the requirements when building from git., Ludovic Courtès, 2015/10/28
- 08/10: substitute: 'lookup-narinfos' returns exactly a list of narinfos., Ludovic Courtès, 2015/10/28
- 10/10: gnu: python-debian: Avoid @itemize in description., Ludovic Courtès, 2015/10/28
- 09/10: substitute: Honor all the specified server URLs.,
Ludovic Courtès <=
- 07/10: substitute: 'http-multiple-get' follows 'fold' style., Ludovic Courtès, 2015/10/28