diff options
| -rw-r--r-- | guix/derivations.scm | 117 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 4 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 4 | ||||
| -rw-r--r-- | guix/ui.scm | 81 | ||||
| -rw-r--r-- | tests/derivations.scm | 46 |
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) |