ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

scripts: Report what will be substituted.

Browse source 
* 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 @@ (define-module (guix derivations)
derivation-input?
derivation-input-path
derivation-input-sub-derivations
derivation-input-output-paths
fixed-output-derivation?
derivation-hash
@ -99,6 +100,14 @@ (define (fixed-output-derivation? drv)
#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 @@ (define (derivation-prerequisites drv)
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.

4
guix/scripts/build.scm
View file

@ -237,7 +237,9 @@ (define (find-package request)
(_ #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)

4
guix/scripts/package.scm
View file

@ -674,7 +674,9 @@ (define (show-what-to-remove/install remove install dry-run?)
(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
View file

@ -144,33 +144,66 @@ (define (read/eval-package-expression str)
(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 ()

46
tests/derivations.scm
View file

@ -32,6 +32,7 @@ (define-module (test-derivations)
#: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 @@ (define %coreutils
;; 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)