diff options
| -rw-r--r-- | guix/derivations.scm | 97 | ||||
| -rw-r--r-- | tests/derivations.scm | 30 |
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) |