summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/scripts/build.scm12
-rw-r--r--guix/scripts/lint.scm2
-rwxr-xr-xguix/scripts/substitute.scm317
-rw-r--r--guix/store.scm1
-rw-r--r--guix/tests.scm11
5 files changed, 194 insertions, 149 deletions
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 7fd05da189..d593b5a8a7 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -118,6 +118,9 @@ options handled by 'set-build-options-from-command-line', and listed in
(display (_ "
--no-substitutes build instead of resorting to pre-built substitutes"))
(display (_ "
+ --substitute-urls=URLS
+ fetch substitute from URLS if they are authorized"))
+ (display (_ "
--no-build-hook do not attempt to offload builds via the build hook"))
(display (_ "
--max-silent-time=SECONDS
@@ -141,6 +144,8 @@ options handled by 'set-build-options-from-command-line', and listed in
#:max-build-jobs (or (assoc-ref opts 'max-jobs) 1)
#:fallback? (assoc-ref opts 'fallback?)
#:use-substitutes? (assoc-ref opts 'substitutes?)
+ #:substitute-urls (or (assoc-ref opts 'substitute-urls)
+ %default-substitute-urls)
#:use-build-hook? (assoc-ref opts 'build-hook?)
#:max-silent-time (assoc-ref opts 'max-silent-time)
#:timeout (assoc-ref opts 'timeout)
@@ -177,6 +182,13 @@ options handled by 'set-build-options-from-command-line', and listed in
(alist-cons 'substitutes? #f
(alist-delete 'substitutes? result))
rest)))
+ (option '("substitute-urls") #t #f
+ (lambda (opt name arg result . rest)
+ (apply values
+ (alist-cons 'substitute-urls
+ (string-tokenize arg)
+ (alist-delete 'substitute-urls result))
+ rest)))
(option '("no-build-hook") #f #f
(lambda (opt name arg result . rest)
(apply values
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 3740b71d5e..6dc5b68f95 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -34,8 +34,6 @@
#:use-module (ice-9 regex)
#:use-module (ice-9 format)
#:use-module (web uri)
- #:use-module (srfi srfi-34)
- #:use-module (srfi srfi-35)
#:use-module ((guix build download)
#:select (maybe-expand-mirrors
open-connection-for-uri))
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 0baba91981..95aae2a372 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -25,6 +25,7 @@
#:use-module (guix records)
#:use-module (guix serialization)
#:use-module (guix hash)
+ #:use-module (guix base32)
#:use-module (guix base64)
#:use-module (guix pk-crypto)
#:use-module (guix pki)
@@ -184,37 +185,29 @@ to the caller without emitting an error message."
(setvbuf port _IONBF)))
(http-fetch uri #:text? #f #:port port))))))))
-(define-record-type <cache>
- (%make-cache url store-directory wants-mass-query?)
- cache?
- (url cache-url)
- (store-directory cache-store-directory)
- (wants-mass-query? cache-wants-mass-query?))
-
-(define (open-cache url)
- "Open the binary cache at URL. Return a <cache> object on success, or #f on
-failure."
- (define (download-cache-info url)
+(define-record-type <cache-info>
+ (%make-cache-info url store-directory wants-mass-query?)
+ cache-info?
+ (url cache-info-url)
+ (store-directory cache-info-store-directory)
+ (wants-mass-query? cache-info-wants-mass-query?))
+
+(define (download-cache-info url)
+ "Download the information for the cache at URL. Return a <cache-info>
+object on success, or #f on failure."
+ (define (download url)
;; Download the `nix-cache-info' from URL, and return its contents as an
;; list of key/value pairs.
(and=> (false-if-exception (fetch (string->uri url)))
fields->alist))
- (and=> (download-cache-info (string-append url "/nix-cache-info"))
+ (and=> (download (string-append url "/nix-cache-info"))
(lambda (properties)
(alist->record properties
- (cut %make-cache url <...>)
+ (cut %make-cache-info url <...>)
'("StoreDir" "WantMassQuery")))))
-(define-syntax-rule (open-cache* url)
- "Delayed variant of 'open-cache' that also lets the user know that they're
-gonna have to wait."
- (delay (begin
- (format (current-error-port)
- (_ "updating list of substitutes from '~a'...\r")
- url)
- (open-cache url))))
-
+
(define-record-type <narinfo>
(%make-narinfo path uri uri-base compression file-hash file-size nar-hash nar-size
references deriver system signature contents)
@@ -379,20 +372,23 @@ the cache STR originates form."
(make-time time-monotonic 0 date)))
-(define (narinfo-cache-file path)
- "Return the name of the local file that contains an entry for PATH."
+(define (narinfo-cache-file cache-url path)
+ "Return the name of the local file that contains an entry for PATH. The
+entry is stored in a sub-directory specific to CACHE-URL."
(string-append %narinfo-cache-directory "/"
- (store-path-hash-part path)))
-
-(define (cached-narinfo path)
- "Check locally if we have valid info about PATH. Return two values: a
-Boolean indicating whether we have valid cached info, and that info, which may
-be either #f (when PATH is unavailable) or the narinfo for PATH."
+ (bytevector->base32-string (sha256 (string->utf8 cache-url)))
+ "/" (store-path-hash-part path)))
+
+(define (cached-narinfo cache-url path)
+ "Check locally if we have valid info about PATH coming from CACHE-URL.
+Return two values: a Boolean indicating whether we have valid cached info, and
+that info, which may be either #f (when PATH is unavailable) or the narinfo
+for PATH."
(define now
(current-time time-monotonic))
(define cache-file
- (narinfo-cache-file path))
+ (narinfo-cache-file cache-url path))
(catch 'system-error
(lambda ()
@@ -418,9 +414,9 @@ be either #f (when PATH is unavailable) or the narinfo for PATH."
(lambda _
(values #f #f))))
-(define (cache-narinfo! cache path narinfo)
- "Cache locally NARNIFO for PATH, which originates from CACHE. NARINFO may
-be #f, in which case it indicates that PATH is unavailable at CACHE."
+(define (cache-narinfo! cache-url path narinfo)
+ "Cache locally NARNIFO for PATH, which originates from CACHE-URL. NARINFO
+may be #f, in which case it indicates that PATH is unavailable at CACHE-URL."
(define now
(current-time time-monotonic))
@@ -430,9 +426,12 @@ be #f, in which case it indicates that PATH is unavailable at CACHE."
(date ,(time-second now))
(value ,(and=> narinfo narinfo->string))))
- (with-atomic-file-output (narinfo-cache-file path)
- (lambda (out)
- (write (cache-entry (cache-url cache) narinfo) out)))
+ (let ((file (narinfo-cache-file cache-url path)))
+ (mkdir-p (dirname file))
+ (with-atomic-file-output file
+ (lambda (out)
+ (write (cache-entry cache-url narinfo) out))))
+
narinfo)
(define (narinfo-request cache-url path)
@@ -491,11 +490,8 @@ if file doesn't exist, and the narinfo otherwise."
#f
(apply throw args)))))
-(define (fetch-narinfos cache paths)
- "Retrieve all the narinfos for PATHS from CACHE and return them."
- (define url
- (cache-url cache))
-
+(define (fetch-narinfos url paths)
+ "Retrieve all the narinfos for PATHS from the cache at URL and return them."
(define update-progress!
(let ((done 0))
(lambda ()
@@ -513,7 +509,7 @@ if file doesn't exist, and the narinfo otherwise."
(case (response-code response)
((200) ; hit
(let ((narinfo (read-narinfo port url #:size len)))
- (cache-narinfo! cache (narinfo-path narinfo) narinfo)
+ (cache-narinfo! url (narinfo-path narinfo) narinfo)
(update-progress!)
narinfo))
((404) ; failure
@@ -522,7 +518,7 @@ if file doesn't exist, and the narinfo otherwise."
(if len
(get-bytevector-n port len)
(read-to-eof port))
- (cache-narinfo! cache
+ (cache-narinfo! url
(find (cut string-contains <> hash-part) paths)
#f)
(update-progress!))
@@ -533,7 +529,12 @@ if file doesn't exist, and the narinfo otherwise."
(read-to-eof port))
#f))))
- (and (string=? (cache-store-directory cache) (%store-prefix))
+ (define cache-info
+ (download-cache-info url))
+
+ (and cache-info
+ (string=? (cache-info-store-directory cache-info)
+ (%store-prefix))
(let ((uri (string->uri url)))
(case (and=> uri uri-scheme)
((http)
@@ -559,7 +560,7 @@ information is available locally."
(let-values (((cached missing)
(fold2 (lambda (path cached missing)
(let-values (((valid? value)
- (cached-narinfo path)))
+ (cached-narinfo cache path)))
(if valid?
(values (cons value cached) missing)
(values cached (cons path missing)))))
@@ -568,11 +569,8 @@ information is available locally."
paths)))
(if (null? missing)
cached
- (let* ((cache (force cache))
- (missing (if cache
- (fetch-narinfos cache missing)
- '())))
- (append cached missing)))))
+ (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
@@ -580,8 +578,8 @@ found."
(match (lookup-narinfos cache (list path))
((answer) answer)))
-(define (remove-expired-cached-narinfos)
- "Remove expired narinfo entries from the cache. The sole purpose of this
+(define (remove-expired-cached-narinfos directory)
+ "Remove expired narinfo entries from DIRECTORY. The sole purpose of this
function is to make sure `%narinfo-cache-directory' doesn't grow
indefinitely."
(define now
@@ -605,16 +603,25 @@ indefinitely."
#t)))
(for-each (lambda (file)
- (let ((file (string-append %narinfo-cache-directory
- "/" file)))
+ (let ((file (string-append directory "/" file)))
(when (expired? file)
;; Wrap in `false-if-exception' because FILE might have been
;; deleted in the meantime (TOCTTOU).
(false-if-exception (delete-file file)))))
- (scandir %narinfo-cache-directory
+ (scandir directory
(lambda (file)
(= (string-length file) 32)))))
+(define (narinfo-cache-directories)
+ "Return the list of narinfo cache directories (one per cache URL.)"
+ (map (cut string-append %narinfo-cache-directory "/" <>)
+ (scandir %narinfo-cache-directory
+ (lambda (item)
+ (and (not (member item '("." "..")))
+ (file-is-directory?
+ (string-append %narinfo-cache-directory
+ "/" item)))))))
+
(define (maybe-remove-expired-cached-narinfo)
"Remove expired narinfo entries from the cache if deemed necessary."
(define now
@@ -628,8 +635,10 @@ indefinitely."
(call-with-input-file expiry-file read))
0))
- (when (obsolete? last-expiry-date now %narinfo-expired-cache-entry-removal-delay)
- (remove-expired-cached-narinfos)
+ (when (obsolete? last-expiry-date now
+ %narinfo-expired-cache-entry-removal-delay)
+ (for-each remove-expired-cached-narinfos
+ (narinfo-cache-directories))
(call-with-output-file expiry-file
(cute write (time-second now) <>))))
@@ -690,6 +699,95 @@ Internal tool to substitute a pre-built binary to a local build.\n"))
;;;
+;;; Daemon/substituter protocol.
+;;;
+
+(define (display-narinfo-data narinfo)
+ "Write to the current output port the contents of NARINFO is the format
+expected by the daemon."
+ (format #t "~a\n~a\n~a\n"
+ (narinfo-path narinfo)
+ (or (and=> (narinfo-deriver narinfo)
+ (cute string-append (%store-prefix) "/" <>))
+ "")
+ (length (narinfo-references narinfo)))
+ (for-each (cute format #t "~a/~a~%" (%store-prefix) <>)
+ (narinfo-references narinfo))
+ (format #t "~a\n~a\n"
+ (or (narinfo-file-size narinfo) 0)
+ (or (narinfo-size narinfo) 0)))
+
+(define* (process-query command
+ #:key cache-url 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)))
+
+ (match (string-tokenize command)
+ (("have" paths ..1)
+ ;; Return the subset of PATHS available in CACHE-URL.
+ (let ((substitutable (lookup-narinfos cache-url 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)))
+ (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
+DESTINATION as a nar file. Verify the substitute against ACL."
+ (let* ((narinfo (lookup-narinfo cache-url store-item))
+ (uri (narinfo-uri narinfo)))
+ ;; Make sure it is signed and everything.
+ (assert-valid-narinfo narinfo acl)
+
+ ;; Tell the daemon what the expected hash of the Nar itself is.
+ (format #t "~a~%" (narinfo-hash narinfo))
+
+ (format (current-error-port) "downloading `~a'~:[~*~; (~,1f MiB installed)~]...~%"
+ store-item
+
+ ;; Use the Nar size as an estimate of the installed size.
+ (narinfo-size narinfo)
+ (and=> (narinfo-size narinfo)
+ (cute / <> (expt 2. 20))))
+ (let*-values (((raw download-size)
+ ;; 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 (and=> (narinfo-compression narinfo)
+ string->symbol)
+ progress)))
+ ;; Unpack the Nar at INPUT into DESTINATION.
+ (restore-file input destination)
+
+ ;; Skip a line after what 'progress-proc' printed.
+ (newline (current-error-port))
+
+ (every (compose zero? cdr waitpid) pids))))
+
+
+;;;
;;; Entry point.
;;;
@@ -737,12 +835,15 @@ substitutes may be unavailable\n")))))
found."
(assoc-ref (daemon-options) option))
+(define-syntax-rule (or* a b)
+ (let ((first a))
+ (if (or (not first) (string-null? first))
+ b
+ first)))
+
(define %cache-url
- (match (and=> ;; TODO: Uncomment the following lines when multiple
- ;; substitute sources are supported.
- ;; (find-daemon-option "untrusted-substitute-urls") ;client
- ;; " "
- (find-daemon-option "substitute-urls") ;admin
+ (match (and=> (or* (find-daemon-option "untrusted-substitute-urls") ;client
+ (find-daemon-option "substitute-urls")) ;admin
string-tokenize)
((url)
url)
@@ -788,94 +889,19 @@ substituter disabled~%")
(with-error-handling ; for signature errors
(match args
(("--query")
- (let ((cache (open-cache* %cache-url))
- (acl (current-acl)))
- (define (valid? obj)
- (and (narinfo? obj) (valid-narinfo? obj acl)))
-
+ (let ((acl (current-acl)))
(let loop ((command (read-line)))
(or (eof-object? command)
(begin
- (match (string-tokenize command)
- (("have" paths ..1)
- ;; Return the subset of PATHS available in CACHE.
- (let ((substitutable
- (if cache
- (lookup-narinfos cache 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.
- (let ((substitutable
- (if cache
- (lookup-narinfos cache paths)
- '())))
- (for-each (lambda (narinfo)
- (format #t "~a\n~a\n~a\n"
- (narinfo-path narinfo)
- (or (and=> (narinfo-deriver narinfo)
- (cute string-append
- (%store-prefix) "/"
- <>))
- "")
- (length (narinfo-references narinfo)))
- (for-each (cute format #t "~a/~a~%"
- (%store-prefix) <>)
- (narinfo-references narinfo))
- (format #t "~a\n~a\n"
- (or (narinfo-file-size narinfo) 0)
- (or (narinfo-size narinfo) 0)))
- (filter valid? substitutable))
- (newline)))
- (wtf
- (error "unknown `--query' command" wtf)))
+ (process-query command
+ #:cache-url %cache-url
+ #:acl acl)
(loop (read-line)))))))
(("--substitute" store-path destination)
;; Download STORE-PATH and add store it as a Nar in file DESTINATION.
- (let* ((cache (open-cache* %cache-url))
- (narinfo (lookup-narinfo cache store-path))
- (uri (narinfo-uri narinfo)))
- ;; Make sure it is signed and everything.
- (assert-valid-narinfo narinfo)
-
- ;; Tell the daemon what the expected hash of the Nar itself is.
- (format #t "~a~%" (narinfo-hash narinfo))
-
- (format (current-error-port) "downloading `~a'~:[~*~; (~,1f MiB installed)~]...~%"
- store-path
-
- ;; Use the Nar size as an estimate of the installed size.
- (narinfo-size narinfo)
- (and=> (narinfo-size narinfo)
- (cute / <> (expt 2. 20))))
- (let*-values (((raw download-size)
- ;; 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 (and=> (narinfo-compression narinfo)
- string->symbol)
- progress)))
- ;; Unpack the Nar at INPUT into DESTINATION.
- (restore-file input destination)
-
- ;; Skip a line after what 'progress-proc' printed.
- (newline (current-error-port))
-
- (every (compose zero? cdr waitpid) pids))))
+ (process-substitution store-path destination
+ #:cache-url %cache-url
+ #:acl (current-acl)))
(("--version")
(show-version-and-exit "guix substitute"))
(("--help")
@@ -883,7 +909,6 @@ substituter disabled~%")
(opts
(leave (_ "~a: unrecognized options~%") opts))))))
-
;;; Local Variables:
;;; eval: (put 'with-timeout 'scheme-indent-function 1)
;;; End:
diff --git a/guix/store.scm b/guix/store.scm
index 39e5faf6c8..132b8a3ac4 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -37,6 +37,7 @@
#:use-module (ice-9 popen)
#:export (%daemon-socket-file
%gc-roots-directory
+ %default-substitute-urls
nix-server?
nix-server-major-version
diff --git a/guix/tests.scm b/guix/tests.scm
index 16b8cc7f8a..cd8eda2f60 100644
--- a/guix/tests.scm
+++ b/guix/tests.scm
@@ -36,6 +36,7 @@
network-reachable?
shebang-too-long?
mock
+ %test-substitute-urls
%substitute-directory
with-derivation-narinfo
with-derivation-substitute
@@ -49,6 +50,12 @@
;;;
;;; Code:
+(define %test-substitute-urls
+ ;; URLs where to look for substitutes during tests.
+ (make-parameter
+ (or (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL") list)
+ '())))
+
(define (open-connection-for-tests)
"Open a connection to the build daemon for tests purposes and return it."
(guard (c ((nix-error? c)
@@ -57,7 +64,9 @@
#f))
(let ((store (open-connection)))
;; Make sure we build everything by ourselves.
- (set-build-options store #:use-substitutes? #f)
+ (set-build-options store
+ #:use-substitutes? #f
+ #:substitute-urls (%test-substitute-urls))
;; Use the bootstrap Guile when running tests, so we don't end up
;; building everything in the temporary test store.