mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -05:00
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'.
This commit is contained in:
parent
a89dde1ed8
commit
55b2fc1877
2 changed files with 46 additions and 41 deletions
|
@ -72,6 +72,7 @@ (define-module (guix scripts substitute)
|
|||
assert-valid-narinfo
|
||||
|
||||
lookup-narinfos
|
||||
lookup-narinfos/diverse
|
||||
read-narinfo
|
||||
write-narinfo
|
||||
guix-substitute))
|
||||
|
@ -610,11 +611,32 @@ (define (lookup-narinfos cache paths)
|
|||
(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 @@ (define (display-narinfo-data narinfo)
|
|||
(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 @@ (define-syntax-rule (or* a b)
|
|||
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 @@ (define (guix-substitute . args)
|
|||
;; 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 @@ (define (guix-substitute . args)
|
|||
(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"))
|
||||
|
|
|
@ -167,8 +167,8 @@ (define-syntax-rule (with-narinfo narinfo body ...)
|
|||
(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
|
||||
|
|
Loading…
Reference in a new issue