summaryrefslogtreecommitdiff
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
parent56b943de6e61f41d6ebd2dfa65ff886cdfd83759 (diff)
downloadpatches-e387ab7c10b18427b97cd22526f1b135856a083e.tar
patches-e387ab7c10b18427b97cd22526f1b135856a083e.tar.gz
derivations: Add 'map-derivation'.
* guix/derivations.scm (map-derivation): New procedure. * tests/derivations.scm ("map-derivation"): New test.
-rw-r--r--guix/derivations.scm97
-rw-r--r--tests/derivations.scm30
2 files changed, 127 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.
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 273db22765..09cf81972c 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -26,6 +26,7 @@
#:use-module ((guix packages) #:select (package-derivation))
#:use-module ((gnu packages) #:select (search-bootstrap-binary))
#:use-module (gnu packages bootstrap)
+ #:use-module ((gnu packages guile) #:select (guile-1.8))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
@@ -690,6 +691,35 @@ Deriver: ~a~%"
((p2 . _)
(string<? p1 p2)))))))))))))
+
+(test-equal "map-derivation"
+ "hello"
+ (let* ((joke (package-derivation %store guile-1.8))
+ (good (package-derivation %store %bootstrap-guile))
+ (drv1 (build-expression->derivation %store "original-drv1"
+ (%current-system)
+ #f ; systematically fail
+ '()
+ #:guile-for-build joke))
+ (drv2 (build-expression->derivation %store "original-drv2"
+ (%current-system)
+ '(call-with-output-file %output
+ (lambda (p)
+ (display "hello" p)))
+ '()))
+ (drv3 (build-expression->derivation %store "drv-to-remap"
+ (%current-system)
+ '(let ((in (assoc-ref
+ %build-inputs "in")))
+ (copy-file in %output))
+ `(("in" ,drv1))
+ #:guile-for-build joke))
+ (drv4 (map-derivation %store drv3 `((,drv1 . ,drv2)
+ (,joke . ,good))))
+ (out (derivation->output-path drv4)))
+ (and (build-derivations %store (list (pk 'remapped drv4)))
+ (call-with-input-file out get-string-all))))
+
(test-end)