summaryrefslogtreecommitdiff
path: root/guix/derivations.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2013-11-13 00:25:57 +0100
committerLudovic Courtès <ludo@gnu.org>2013-11-13 00:29:05 +0100
commite387ab7c10b18427b97cd22526f1b135856a083e (patch)
treec9d6aebc4abfdf1a943d4c8e1016676c659eb64a /guix/derivations.scm
parent56b943de6e61f41d6ebd2dfa65ff886cdfd83759 (diff)
derivations: Add 'map-derivation'.
* guix/derivations.scm (map-derivation): New procedure. * tests/derivations.scm ("map-derivation"): New test.
Diffstat (limited to 'guix/derivations.scm')
-rw-r--r--guix/derivations.scm97
1 files changed, 97 insertions, 0 deletions
diff --git a/guix/derivations.scm b/guix/derivations.scm
index 48e9d5ec05..011f4b778b 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -25,6 +25,7 @@
#:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
+ #:use-module (ice-9 vlist)
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (guix hash)
@@ -63,6 +64,7 @@
derivation-path->output-path
derivation-path->output-paths
derivation
+ map-derivation
%guile-for-build
imported-modules
@@ -655,6 +657,101 @@ the build environment in the corresponding file, in a simple text format."
inputs))))
(set-file-name drv file))))
+(define* (map-derivation store drv mapping
+ #:key (system (%current-system)))
+ "Given MAPPING, a list of pairs of derivations, return a derivation based on
+DRV where all the 'car's of MAPPING have been replaced by its 'cdr's,
+recursively."
+ (define (substitute str initial replacements)
+ (fold (lambda (path replacement result)
+ (string-replace-substring result path
+ replacement))
+ str
+ initial replacements))
+
+ (define (substitute-file file initial replacements)
+ (define contents
+ (with-fluids ((%default-port-encoding #f))
+ (call-with-input-file file get-string-all)))
+
+ (let ((updated (substitute contents initial replacements)))
+ (if (string=? updated contents)
+ file
+ ;; XXX: permissions aren't preserved.
+ (add-text-to-store store (store-path-package-name file)
+ updated))))
+
+ (define input->output-paths
+ (match-lambda
+ ((drv)
+ (list (derivation->output-path drv)))
+ ((drv sub-drvs ...)
+ (map (cut derivation->output-path drv <>)
+ sub-drvs))))
+
+ (let ((mapping (fold (lambda (pair result)
+ (match pair
+ ((orig . replacement)
+ (vhash-cons (derivation-file-name orig)
+ replacement result))))
+ vlist-null
+ mapping)))
+ (define rewritten-input
+ ;; Rewrite the given input according to MAPPING, and return an input
+ ;; in the format used in 'derivation' calls.
+ (memoize
+ (lambda (input loop)
+ (match input
+ (($ <derivation-input> path (sub-drvs ...))
+ (match (vhash-assoc path mapping)
+ ((_ . replacement)
+ (cons replacement sub-drvs))
+ (#f
+ (let* ((drv (loop (call-with-input-file path read-derivation))))
+ (cons drv sub-drvs)))))))))
+
+ (let loop ((drv drv))
+ (let* ((inputs (map (cut rewritten-input <> loop)
+ (derivation-inputs drv)))
+ (initial (append-map derivation-input-output-paths
+ (derivation-inputs drv)))
+ (replacements (append-map input->output-paths inputs))
+
+ ;; Sources typically refer to the output directories of the
+ ;; original inputs, INITIAL. Rewrite them by substituting
+ ;; REPLACEMENTS.
+ (sources (map (cut substitute-file <> initial replacements)
+ (derivation-sources drv)))
+
+ ;; Now augment the lists of initials and replacements.
+ (initial (append (derivation-sources drv) initial))
+ (replacements (append sources replacements))
+ (name (store-path-package-name
+ (string-drop-right (derivation-file-name drv)
+ 4))))
+ (derivation store name
+ (substitute (derivation-builder drv)
+ initial replacements)
+ (map (cut substitute <> initial replacements)
+ (derivation-builder-arguments drv))
+ #:system system
+ #:env-vars (map (match-lambda
+ ((var . value)
+ `(,var
+ . ,(substitute value initial
+ replacements))))
+ (derivation-builder-environment-vars drv))
+ #:inputs (append (map list sources) inputs)
+ #:outputs (map car (derivation-outputs drv))
+ #:hash (match (derivation-outputs drv)
+ ((($ <derivation-output> _ algo hash))
+ hash)
+ (_ #f))
+ #:hash-algo (match (derivation-outputs drv)
+ ((($ <derivation-output> _ algo hash))
+ algo)
+ (_ #f)))))))
+
;;;
;;; Store compatibility layer.