aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2013-04-17 00:06:59 +0200
committerLudovic Courtès <ludo@gnu.org>2013-04-17 00:08:21 +0200
commitdd36b51bf7cffa389726ad997465b14f7072944a (patch)
tree7c80a1b36acd81841204444cf6d9fe0b016ff0cc
parentacb6ba256703da1db1d300541e15a4e7428f622b (diff)
downloadpatches-dd36b51bf7cffa389726ad997465b14f7072944a.tar
patches-dd36b51bf7cffa389726ad997465b14f7072944a.tar.gz
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.
-rw-r--r--guix/derivations.scm117
-rw-r--r--guix/scripts/build.scm4
-rw-r--r--guix/scripts/package.scm4
-rw-r--r--guix/ui.scm81
-rw-r--r--tests/derivations.scm46
5 files changed, 191 insertions, 61 deletions
diff --git a/guix/derivations.scm b/guix/derivations.scm
index 2243d2ba46..cf329819c4 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -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)))))
-
- (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))))))
+ (every built? (derivation-output-paths drv sub-drvs)))
+
+ (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.
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 339ad0d06f..f296f3031f 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -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)
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 5b340c6ab7..f83c0573e7 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -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)
diff --git a/guix/ui.scm b/guix/ui.scm
index dfb6418a10..db0711bb61 100644
--- a/guix/ui.scm
+++ b/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 ()
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 6012e73216..a50c1af878 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -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)