From c22a1324e64d6906be5e9a8e64b8716ad763434a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 27 Feb 2016 23:06:50 +0100 Subject: grafts: Graft recursively. Fixes . * 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. --- guix/grafts.scm | 104 ++++++++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 98 insertions(+), 6 deletions(-) (limited to 'guix/grafts.scm') 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 . (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! 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 + (($ (? derivation? origin) output) + (derivation->output-path origin output)) + (($ (? 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 -- cgit v1.2.3