scripts: Report what will be substituted.
* guix/derivations.scm (derivation-input-output-paths): New procedure.
(derivation-prerequisites-to-build): New `use-substitutes?' keyword
argument. Change two return the list of substitutable paths as a
second argument.
* guix/ui.scm (show-what-to-build): Turn `dry-run?' into a keyword
argument. New `use-substitutes?' keyword argument. Use `fold2' and
adjust to use both return values of
`derivation-prerequisites-to-build'. Display what will/would be
downloaded.
* guix/scripts/build.scm (guix-build): Adjust accordingly.
* guix/scripts/package.scm (guix-package): Likewise.
* tests/derivations.scm ("derivation-prerequisites-to-build and
substitutes"): New test.
This commit is contained in:
Ludovic Courtès
parent
acb6ba2567
commit
dd36b51bf7
|
|
@ -48,6 +48,7 @@
|
|||
derivation-input?
|
||||
derivation-input-path
|
||||
derivation-input-sub-derivations
|
||||
derivation-input-output-paths
|
||||
|
||||
fixed-output-derivation?
|
||||
derivation-hash
|
||||
|
|
@ -99,6 +100,14 @@ download with a fixed hash (aka. `fetchurl')."
|
|||
#t)
|
||||
(_ #f)))
|
||||
|
||||
(define (derivation-input-output-paths input)
|
||||
"Return the list of output paths corresponding to INPUT, a
|
||||
<derivation-input>."
|
||||
(match input
|
||||
(($ <derivation-input> path sub-drvs)
|
||||
(map (cut derivation-path->output-path path <>)
|
||||
sub-drvs))))
|
||||
|
||||
(define (derivation-prerequisites drv)
|
||||
"Return the list of derivation-inputs required to build DRV, recursively."
|
||||
(let loop ((drv drv)
|
||||
|
|
@ -113,47 +122,85 @@ download with a fixed hash (aka. `fetchurl')."
|
|||
inputs)))))
|
||||
|
||||
(define* (derivation-prerequisites-to-build store drv
|
||||
#:key (outputs
|
||||
(map
|
||||
car
|
||||
(derivation-outputs drv))))
|
||||
"Return the list of derivation-inputs required to build the OUTPUTS of
|
||||
DRV and not already available in STORE, recursively."
|
||||
#:key
|
||||
(outputs
|
||||
(map
|
||||
car
|
||||
(derivation-outputs drv)))
|
||||
(use-substitutes? #t))
|
||||
"Return two values: the list of derivation-inputs required to build the
|
||||
OUTPUTS of DRV and not already available in STORE, recursively, and the list
|
||||
of required store paths that can be substituted. When USE-SUBSTITUTES? is #f,
|
||||
that second value is the empty list."
|
||||
(define (derivation-output-paths drv sub-drvs)
|
||||
(match drv
|
||||
(($ <derivation> outputs)
|
||||
(map (lambda (sub-drv)
|
||||
(derivation-output-path (assoc-ref outputs sub-drv)))
|
||||
sub-drvs))))
|
||||
|
||||
(define built?
|
||||
(cut valid-path? store <>))
|
||||
|
||||
(define substitutable?
|
||||
;; Return true if the given path is substitutable. Call
|
||||
;; `substitutable-paths' upfront, to benefit from parallelism in the
|
||||
;; substituter.
|
||||
(if use-substitutes?
|
||||
(let ((s (substitutable-paths store
|
||||
(append
|
||||
(derivation-output-paths drv outputs)
|
||||
(append-map
|
||||
derivation-input-output-paths
|
||||
(derivation-prerequisites drv))))))
|
||||
(cut member <> s))
|
||||
(const #f)))
|
||||
|
||||
(define input-built?
|
||||
(match-lambda
|
||||
(($ <derivation-input> path sub-drvs)
|
||||
(let ((out (map (cut derivation-path->output-path path <>)
|
||||
sub-drvs)))
|
||||
(any built? out)))))
|
||||
(compose (cut any built? <>) derivation-input-output-paths))
|
||||
|
||||
(define input-substitutable?
|
||||
;; Return true if and only if all of SUB-DRVS are subsitutable. If at
|
||||
;; least one is missing, then everything must be rebuilt.
|
||||
(compose (cut every substitutable? <>) derivation-input-output-paths))
|
||||
|
||||
(define (derivation-built? drv sub-drvs)
|
||||
(match drv
|
||||
(($ <derivation> outputs)
|
||||
(let ((paths (map (lambda (sub-drv)
|
||||
(derivation-output-path
|
||||
(assoc-ref outputs sub-drv)))
|
||||
sub-drvs)))
|
||||
(every built? paths)))))
|
||||
(every built? (derivation-output-paths drv sub-drvs)))
|
||||
|
||||
(let loop ((drv drv)
|
||||
(sub-drvs outputs)
|
||||
(result '()))
|
||||
(if (derivation-built? drv sub-drvs)
|
||||
result
|
||||
(let ((inputs (remove (lambda (i)
|
||||
(or (member i result) ; XXX: quadratic
|
||||
(input-built? i)))
|
||||
(derivation-inputs drv))))
|
||||
(fold loop
|
||||
(append inputs result)
|
||||
(map (lambda (i)
|
||||
(call-with-input-file (derivation-input-path i)
|
||||
read-derivation))
|
||||
inputs)
|
||||
(map derivation-input-sub-derivations inputs))))))
|
||||
(define (derivation-substitutable? drv sub-drvs)
|
||||
(every substitutable? (derivation-output-paths drv sub-drvs)))
|
||||
|
||||
(let loop ((drv drv)
|
||||
(sub-drvs outputs)
|
||||
(build '())
|
||||
(substitute '()))
|
||||
(cond ((derivation-built? drv sub-drvs)
|
||||
(values build substitute))
|
||||
((derivation-substitutable? drv sub-drvs)
|
||||
(values build
|
||||
(append (derivation-output-paths drv sub-drvs)
|
||||
substitute)))
|
||||
(else
|
||||
(let ((inputs (remove (lambda (i)
|
||||
(or (member i build) ; XXX: quadratic
|
||||
(input-built? i)
|
||||
(input-substitutable? i)))
|
||||
(derivation-inputs drv))))
|
||||
(fold2 loop
|
||||
(append inputs build)
|
||||
(append (append-map (lambda (input)
|
||||
(if (and (not (input-built? input))
|
||||
(input-substitutable? input))
|
||||
(derivation-input-output-paths
|
||||
input)
|
||||
'()))
|
||||
(derivation-inputs drv))
|
||||
substitute)
|
||||
(map (lambda (i)
|
||||
(call-with-input-file (derivation-input-path i)
|
||||
read-derivation))
|
||||
inputs)
|
||||
(map derivation-input-sub-derivations inputs)))))))
|
||||
|
||||
(define (%read-derivation drv-port)
|
||||
;; Actually read derivation from DRV-PORT.
|
||||
|
|
|
|||
|
|
@ -237,7 +237,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
|
|||
(_ #f))
|
||||
opts)))
|
||||
|
||||
(show-what-to-build (%store) drv (assoc-ref opts 'dry-run?))
|
||||
(show-what-to-build (%store) drv
|
||||
#:use-substitutes? (assoc-ref opts 'substitutes?)
|
||||
#:dry-run? (assoc-ref opts 'dry-run?))
|
||||
|
||||
;; TODO: Add more options.
|
||||
(set-build-options (%store)
|
||||
|
|
|
|||
|
|
@ -674,7 +674,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
|
|||
(ensure-default-profile))
|
||||
|
||||
(show-what-to-remove/install remove* install* dry-run?)
|
||||
(show-what-to-build (%store) drv dry-run?)
|
||||
(show-what-to-build (%store) drv
|
||||
#:use-substitutes? (assoc-ref opts 'substitutes?)
|
||||
#:dry-run? dry-run?)
|
||||
|
||||
(or dry-run?
|
||||
(and (build-derivations (%store) drv)
|
||||
|
|
|
|||
81
guix/ui.scm
81
guix/ui.scm
|
|
@ -144,33 +144,66 @@ error."
|
|||
(leave (_ "expression `~s' does not evaluate to a package~%")
|
||||
exp)))))
|
||||
|
||||
(define* (show-what-to-build store drv #:optional dry-run?)
|
||||
(define* (show-what-to-build store drv
|
||||
#:key dry-run? (use-substitutes? #t))
|
||||
"Show what will or would (depending on DRY-RUN?) be built in realizing the
|
||||
derivations listed in DRV. Return #t if there's something to build, #f
|
||||
otherwise."
|
||||
(let* ((req (append-map (lambda (drv-path)
|
||||
(let ((d (call-with-input-file drv-path
|
||||
read-derivation)))
|
||||
(derivation-prerequisites-to-build
|
||||
store d)))
|
||||
drv))
|
||||
(req* (delete-duplicates
|
||||
(append (remove (compose (cute valid-path? store <>)
|
||||
derivation-path->output-path)
|
||||
drv)
|
||||
(map derivation-input-path req)))))
|
||||
otherwise. When USE-SUBSTITUTES?, check and report what is prerequisites are
|
||||
available for download."
|
||||
(let*-values (((build download)
|
||||
(fold2 (lambda (drv-path build download)
|
||||
(let ((drv (call-with-input-file drv-path
|
||||
read-derivation)))
|
||||
(let-values (((b d)
|
||||
(derivation-prerequisites-to-build
|
||||
store drv
|
||||
#:use-substitutes?
|
||||
use-substitutes?)))
|
||||
(values (append b build)
|
||||
(append d download)))))
|
||||
'() '()
|
||||
drv))
|
||||
((build) ; add the DRV themselves
|
||||
(delete-duplicates
|
||||
(append (remove (compose (lambda (out)
|
||||
(or (valid-path? store out)
|
||||
(and use-substitutes?
|
||||
(has-substitutes? store
|
||||
out))))
|
||||
derivation-path->output-path)
|
||||
drv)
|
||||
(map derivation-input-path build))))
|
||||
((download) ; add the references of DOWNLOAD
|
||||
(delete-duplicates
|
||||
(append download
|
||||
(remove (cut valid-path? store <>)
|
||||
(append-map
|
||||
substitutable-references
|
||||
(substitutable-path-info store download)))))))
|
||||
(if dry-run?
|
||||
(format (current-error-port)
|
||||
(N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]"
|
||||
"~:[the following derivations would be built:~%~{ ~a~%~}~;~]"
|
||||
(length req*))
|
||||
(null? req*) req*)
|
||||
(format (current-error-port)
|
||||
(N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]"
|
||||
"~:[the following derivations will be built:~%~{ ~a~%~}~;~]"
|
||||
(length req*))
|
||||
(null? req*) req*))
|
||||
(pair? req*)))
|
||||
(begin
|
||||
(format (current-error-port)
|
||||
(N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]"
|
||||
"~:[the following derivations would be built:~%~{ ~a~%~}~;~]"
|
||||
(length build))
|
||||
(null? build) build)
|
||||
(format (current-error-port)
|
||||
(N_ "~:[the following file would be downloaded:~%~{ ~a~%~}~;~]"
|
||||
"~:[the following files would be downloaded:~%~{ ~a~%~}~;~]"
|
||||
(length download))
|
||||
(null? download) download))
|
||||
(begin
|
||||
(format (current-error-port)
|
||||
(N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]"
|
||||
"~:[the following derivations will be built:~%~{ ~a~%~}~;~]"
|
||||
(length build))
|
||||
(null? build) build)
|
||||
(format (current-error-port)
|
||||
(N_ "~:[the following file will be downloaded:~%~{ ~a~%~}~;~]"
|
||||
"~:[the following files will be downloaded:~%~{ ~a~%~}~;~]"
|
||||
(length download))
|
||||
(null? download) download)))
|
||||
(pair? build)))
|
||||
|
||||
(define-syntax with-error-handling
|
||||
(syntax-rules ()
|
||||
|
|
|
|||
|
|
@ -32,6 +32,7 @@
|
|||
#:use-module (srfi srfi-64)
|
||||
#:use-module (rnrs io ports)
|
||||
#:use-module (rnrs bytevectors)
|
||||
#:use-module (web uri)
|
||||
#:use-module (ice-9 rdelim)
|
||||
#:use-module (ice-9 regex)
|
||||
#:use-module (ice-9 ftw)
|
||||
|
|
@ -398,6 +399,51 @@
|
|||
;; prerequisite to build because DRV itself is already built.
|
||||
(null? (derivation-prerequisites-to-build %store drv)))))
|
||||
|
||||
(test-skip (if (getenv "GUIX_BINARY_SUBSTITUTE_URL") 0 1))
|
||||
(test-assert "derivation-prerequisites-to-build and substitutes"
|
||||
(let*-values (((store)
|
||||
(open-connection))
|
||||
((drv-path drv)
|
||||
(build-expression->derivation store "prereq-subst"
|
||||
(%current-system)
|
||||
(random 1000) '()))
|
||||
((output)
|
||||
(derivation-output-path
|
||||
(assoc-ref (derivation-outputs drv) "out")))
|
||||
((dir)
|
||||
(and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
|
||||
(compose uri-path string->uri))))
|
||||
;; Create fake substituter data, to be read by `substitute-binary'.
|
||||
(call-with-output-file (string-append dir "/nix-cache-info")
|
||||
(lambda (p)
|
||||
(format p "StoreDir: ~a\nWantMassQuery: 0\n"
|
||||
(%store-prefix))))
|
||||
(call-with-output-file (string-append dir "/" (store-path-hash-part output)
|
||||
".narinfo")
|
||||
(lambda (p)
|
||||
(format p "StorePath: ~a
|
||||
URL: ~a
|
||||
Compression: none
|
||||
NarSize: 1234
|
||||
References:
|
||||
System: ~a
|
||||
Deriver: ~a~%"
|
||||
output ; StorePath
|
||||
(string-append dir "/example.nar") ; URL
|
||||
(%current-system) ; System
|
||||
(basename drv-path)))) ; Deriver
|
||||
|
||||
(let-values (((build download)
|
||||
(derivation-prerequisites-to-build store drv))
|
||||
((build* download*)
|
||||
(derivation-prerequisites-to-build store drv
|
||||
#:use-substitutes? #f)))
|
||||
(pk build download build* download*)
|
||||
(and (null? build)
|
||||
(equal? download (list output))
|
||||
(null? download*)
|
||||
(null? build*)))))
|
||||
|
||||
(test-assert "build-expression->derivation with expression returning #f"
|
||||
(let* ((builder '(begin
|
||||
(mkdir %output)
|
||||
|
|
|
|||
Loading…
Reference in New Issue