TakeV
/
guix
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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 2013-04-17 00:06:59 +02:00
parent acb6ba2567
commit dd36b51bf7
5 changed files with 190 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

115
guix/derivations.scm
View File

@ -48,6 +48,7 @@
derivation-input? derivation-input?
derivation-input-path derivation-input-path
derivation-input-sub-derivations derivation-input-sub-derivations
derivation-input-output-paths
fixed-output-derivation? fixed-output-derivation?
derivation-hash derivation-hash
@ -99,6 +100,14 @@ download with a fixed hash (aka. `fetchurl')."
#t) #t)
(_ #f))) (_ #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) (define (derivation-prerequisites drv)
"Return the list of derivation-inputs required to build DRV, recursively." "Return the list of derivation-inputs required to build DRV, recursively."
(let loop ((drv drv) (let loop ((drv drv)
@ -113,47 +122,85 @@ download with a fixed hash (aka. `fetchurl')."
inputs))))) inputs)))))
(define* (derivation-prerequisites-to-build store drv (define* (derivation-prerequisites-to-build store drv
#:key (outputs #:key
(map (outputs
car (map
(derivation-outputs drv)))) car
"Return the list of derivation-inputs required to build the OUTPUTS of (derivation-outputs drv)))
DRV and not already available in STORE, recursively." (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? (define built?
(cut valid-path? store <>)) (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? (define input-built?
(match-lambda (compose (cut any built? <>) derivation-input-output-paths))
(($ <derivation-input> path sub-drvs)
(let ((out (map (cut derivation-path->output-path path <>) (define input-substitutable?
sub-drvs))) ;; Return true if and only if all of SUB-DRVS are subsitutable. If at
(any built? out))))) ;; least one is missing, then everything must be rebuilt.
(compose (cut every substitutable? <>) derivation-input-output-paths))
(define (derivation-built? drv sub-drvs) (define (derivation-built? drv sub-drvs)
(match drv (every built? (derivation-output-paths drv sub-drvs)))
(($ <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) (define (derivation-substitutable? drv sub-drvs)
(sub-drvs outputs) (every substitutable? (derivation-output-paths drv sub-drvs)))
(result '()))
(if (derivation-built? drv sub-drvs) (let loop ((drv drv)
result (sub-drvs outputs)
(let ((inputs (remove (lambda (i) (build '())
(or (member i result) ; XXX: quadratic (substitute '()))
(input-built? i))) (cond ((derivation-built? drv sub-drvs)
(derivation-inputs drv)))) (values build substitute))
(fold loop ((derivation-substitutable? drv sub-drvs)
(append inputs result) (values build
(map (lambda (i) (append (derivation-output-paths drv sub-drvs)
(call-with-input-file (derivation-input-path i) substitute)))
read-derivation)) (else
inputs) (let ((inputs (remove (lambda (i)
(map derivation-input-sub-derivations inputs)))))) (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) (define (%read-derivation drv-port)
;; Actually read derivation from DRV-PORT. ;; Actually read derivation from DRV-PORT.

4
guix/scripts/build.scm
View File

@ -237,7 +237,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(_ #f)) (_ #f))
opts))) 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. ;; TODO: Add more options.
(set-build-options (%store) (set-build-options (%store)

4
guix/scripts/package.scm
View File

@ -674,7 +674,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(ensure-default-profile)) (ensure-default-profile))
(show-what-to-remove/install remove* install* dry-run?) (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? (or dry-run?
(and (build-derivations (%store) drv) (and (build-derivations (%store) drv)

81
guix/ui.scm
View File

@ -144,33 +144,66 @@ error."
(leave (_ "expression `~s' does not evaluate to a package~%") (leave (_ "expression `~s' does not evaluate to a package~%")
exp))))) 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 "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 derivations listed in DRV. Return #t if there's something to build, #f
otherwise." otherwise. When USE-SUBSTITUTES?, check and report what is prerequisites are
(let* ((req (append-map (lambda (drv-path) available for download."
(let ((d (call-with-input-file drv-path (let*-values (((build download)
read-derivation))) (fold2 (lambda (drv-path build download)
(derivation-prerequisites-to-build (let ((drv (call-with-input-file drv-path
store d))) read-derivation)))
drv)) (let-values (((b d)
(req* (delete-duplicates (derivation-prerequisites-to-build
(append (remove (compose (cute valid-path? store <>) store drv
derivation-path->output-path) #:use-substitutes?
drv) use-substitutes?)))
(map derivation-input-path req))))) (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? (if dry-run?
(format (current-error-port) (begin
(N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]" (format (current-error-port)
"~:[the following derivations would be built:~%~{ ~a~%~}~;~]" (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]"
(length req*)) "~:[the following derivations would be built:~%~{ ~a~%~}~;~]"
(null? req*) req*) (length build))
(format (current-error-port) (null? build) build)
(N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]" (format (current-error-port)
"~:[the following derivations will be built:~%~{ ~a~%~}~;~]" (N_ "~:[the following file would be downloaded:~%~{ ~a~%~}~;~]"
(length req*)) "~:[the following files would be downloaded:~%~{ ~a~%~}~;~]"
(null? req*) req*)) (length download))
(pair? req*))) (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 (define-syntax with-error-handling
(syntax-rules () (syntax-rules ()

46
tests/derivations.scm
View File

@ -32,6 +32,7 @@
#:use-module (srfi srfi-64) #:use-module (srfi srfi-64)
#:use-module (rnrs io ports) #:use-module (rnrs io ports)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (web uri)
#:use-module (ice-9 rdelim) #:use-module (ice-9 rdelim)
#:use-module (ice-9 regex) #:use-module (ice-9 regex)
#:use-module (ice-9 ftw) #:use-module (ice-9 ftw)
@ -398,6 +399,51 @@
;; prerequisite to build because DRV itself is already built. ;; prerequisite to build because DRV itself is already built.
(null? (derivation-prerequisites-to-build %store drv))))) (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" (test-assert "build-expression->derivation with expression returning #f"
(let* ((builder '(begin (let* ((builder '(begin
(mkdir %output) (mkdir %output)