diff options
author | Ludovic Courtès <ludo@gnu.org> | 2016-02-27 23:06:50 +0100 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2016-03-01 16:00:46 +0100 |
commit | c22a1324e64d6906be5e9a8e64b8716ad763434a (patch) | |
tree | a85accaeaa4c727c703f208e01a9296821832de7 /guix/grafts.scm | |
parent | d06fc008bdb86169d951721bbb4604948368d7c2 (diff) | |
download | patches-c22a1324e64d6906be5e9a8e64b8716ad763434a.tar patches-c22a1324e64d6906be5e9a8e64b8716ad763434a.tar.gz |
grafts: Graft recursively.
Fixes <http://bugs.gnu.org/22139>.
* guix/grafts.scm (graft-derivation): Rename to...
(graft-derivation/shallow): ... this.
(graft-origin-file-name, item->deriver, non-self-references)
(cumulative-grafts, graft-derivation): New procedures
* tests/grafts.scm ("graft-derivation, grafted item is a direct
dependency"): Clarify title. Use 'grafted' instead of 'graft' to refer
to the grafted derivation.
("graft-derivation, grafted item is an indirect dependency")
("graft-derivation, no dependencies on grafted output"): New tests.
* guix/packages.scm (input-graft): Change to take a package instead of
an input.
(input-cross-graft): Likewise.
(fold-bag-dependencies): New procedure.
(bag-grafts): Rewrite in terms of 'fold-bag-dependencies'.
* tests/packages.scm ("package-derivation, indirect grafts"): Comment out.
* doc/guix.texi (Security Updates): Mention run-time dependencies and
recursive grafting.
Diffstat (limited to 'guix/grafts.scm')
-rw-r--r-- | guix/grafts.scm | 104 |
1 files changed, 98 insertions, 6 deletions
diff --git a/guix/grafts.scm b/guix/grafts.scm index ea53959b37..9bcc5e2ef8 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -17,11 +17,14 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix grafts) + #:use-module (guix store) + #:use-module (guix monads) #:use-module (guix records) #:use-module (guix derivations) #:use-module ((guix utils) #:select (%current-system)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:export (graft? @@ -32,6 +35,7 @@ graft-replacement-output graft-derivation + graft-derivation/shallow %graft? set-grafting)) @@ -61,13 +65,22 @@ (set-record-type-printer! <graft> write-graft) -(define* (graft-derivation store drv grafts - #:key - (name (derivation-name drv)) - (guile (%guile-for-build)) - (system (%current-system))) +(define (graft-origin-file-name graft) + "Return the output file name of the origin of GRAFT." + (match graft + (($ <graft> (? derivation? origin) output) + (derivation->output-path origin output)) + (($ <graft> (? string? item)) + item))) + +(define* (graft-derivation/shallow store drv grafts + #:key + (name (derivation-name drv)) + (guile (%guile-for-build)) + (system (%current-system))) "Return a derivation called NAME, based on DRV but with all the GRAFTS -applied." +applied. This procedure performs \"shallow\" grafting in that GRAFTS are not +recursively applied to dependencies of DRV." ;; XXX: Someday rewrite using gexps. (define mapping ;; List of store item pairs. @@ -133,6 +146,85 @@ applied." (map add-label targets))) #:outputs output-names #:local-build? #t))))) +(define (item->deriver store item) + "Return two values: the derivation that led to ITEM (a store item), and the +name of the output of that derivation ITEM corresponds to (for example +\"out\"). When ITEM has no deriver, for instance because it is a plain file, +#f and #f are returned." + (match (valid-derivers store item) + (() ;ITEM is a plain file + (values #f #f)) + ((drv-file _ ...) + (let ((drv (call-with-input-file drv-file read-derivation))) + (values drv + (any (match-lambda + ((name . path) + (and (string=? item path) name))) + (derivation->output-paths drv))))))) + +(define (non-self-references store drv outputs) + "Return the list of references of the OUTPUTS of DRV, excluding self +references." + (let ((refs (append-map (lambda (output) + (references store + (derivation->output-path drv output))) + outputs)) + (self (match (derivation->output-paths drv) + (((names . items) ...) + items)))) + (remove (cut member <> self) refs))) + +(define* (cumulative-grafts store drv grafts + #:key + (outputs (derivation-output-names drv)) + (guile (%guile-for-build)) + (system (%current-system))) + "Augment GRAFTS with additional grafts resulting from the application of +GRAFTS to the dependencies of DRV. Return the resulting list of grafts." + (define (dependency-grafts item) + (let-values (((drv output) (item->deriver store item))) + (if drv + (cumulative-grafts store drv grafts + #:outputs (list output) + #:guile guile + #:system system) + grafts))) + + ;; TODO: Memoize. + (match (non-self-references store drv outputs) + (() ;no dependencies + grafts) + (deps ;one or more dependencies + (let* ((grafts (delete-duplicates (append-map dependency-grafts deps) + eq?)) + (origins (map graft-origin-file-name grafts))) + (if (find (cut member <> deps) origins) + (let ((new (graft-derivation/shallow store drv grafts + #:guile guile + #:system system))) + (cons (graft (origin drv) (replacement new)) + grafts)) + grafts))))) + +(define* (graft-derivation store drv grafts + #:key (guile (%guile-for-build)) + (system (%current-system))) + "Applied GRAFTS to DRV and all its dependencies, recursively. That is, if +GRAFTS apply only indirectly to DRV, graft the dependencies of DRV, and graft +DRV itself to refer to those grafted dependencies." + + ;; First, we need to build the ungrafted DRV so we can query its run-time + ;; dependencies in 'cumulative-grafts'. + (build-derivations store (list drv)) + + (match (cumulative-grafts store drv grafts + #:guile guile #:system system) + ((first . rest) + ;; If FIRST is not a graft for DRV, it means that GRAFTS are not + ;; applicable to DRV and nothing needs to be done. + (if (equal? drv (graft-origin first)) + (graft-replacement first) + drv)))) ;; The following might feel more at home in (guix packages) but since (guix |