mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 07:26:13 -05:00
derivations: Add 'map-derivation'.
* guix/derivations.scm (map-derivation): New procedure.
* tests/derivations.scm ("map-derivation"): New test.
This commit is contained in:
Ludovic Courtès
parent
56b943de6e
commit
e387ab7c10
2 changed files with 127 additions and 0 deletions
|
|
@ -25,6 +25,7 @@ (define-module (guix derivations)
|
|||
#: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 @@ (define-module (guix derivations)
|
|||
derivation-path->output-path
|
||||
derivation-path->output-paths
|
||||
derivation
|
||||
map-derivation
|
||||
|
||||
%guile-for-build
|
||||
imported-modules
|
||||
|
|
@ -655,6 +657,101 @@ (define (set-file-name drv file)
|
|||
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.
|
||||
|
|
|
|||
|
|
@ -26,6 +26,7 @@ (define-module (test-derivations)
|
|||
#: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 @@ (define (deps path . deps)
|
|||
((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)
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue