diff options
| -rw-r--r-- | guix/packages.scm | 71 | ||||
| -rw-r--r-- | tests/packages.scm | 19 |
2 files changed, 65 insertions, 25 deletions
diff --git a/guix/packages.scm b/guix/packages.scm index 4b687717e4..9a54eb747a 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -227,6 +227,51 @@ recursively." (define* (package-derivation store package #:optional (system (%current-system))) "Return the derivation of PACKAGE for SYSTEM." + (define (intern file) + ;; Add FILE to the store. Set the `recursive?' bit to #t, so that + ;; file permissions are preserved. + (add-to-store store (basename file) + #t #t "sha256" file)) + + (define expand-input + ;; Expand the given input tuple such that it contains only + ;; references to derivation paths or store paths. + (match-lambda + (((? string? name) (? package? package)) + (list name (package-derivation store package))) + (((? string? name) (? package? package) + (? string? sub-drv)) + (list name (package-derivation store package) + sub-drv)) + (((? string? name) + (and (? string?) (? derivation-path?) drv)) + (list name drv)) + (((? string? name) + (and (? string?) (? file-exists? file))) + ;; Add FILE to the store. When FILE is in the sub-directory of a + ;; store path, it needs to be added anyway, so it can be used as a + ;; source. + (list name (intern file))) + (((? string? name) (? origin? source)) + (list name (package-source-derivation store source))) + ((and i ((? string? name) (? procedure? proc) sub-drv ...)) + ;; This form allows PROC to make a SYSTEM-dependent choice. + + ;; XXX: Currently PROC must return a .drv, a store path, a local + ;; file name, or an <origin>. If it were allowed to return a + ;; package, then `transitive-inputs' and co. would need to be + ;; adjusted. + (let ((input (proc system))) + (if (or (string? input) (origin? input)) + (expand-input (cons* name input sub-drv)) + (raise (condition (&package-input-error + (package package) + (input i))))))) + (x + (raise (condition (&package-input-error + (package package) + (input x))))))) + (or (cached-derivation package system) ;; Compute the derivation and cache the result. Caching is @@ -241,31 +286,7 @@ recursively." outputs) ;; TODO: For `search-paths', add a builder prologue that calls ;; `set-path-environment-variable'. - (let ((inputs (map (match-lambda - (((? string? name) (? package? package)) - (list name (package-derivation store package))) - (((? string? name) (? package? package) - (? string? sub-drv)) - (list name (package-derivation store package) - sub-drv)) - (((? string? name) - (and (? string?) (? derivation-path?) drv)) - (list name drv)) - (((? string? name) - (and (? string?) (? file-exists? file))) - ;; Add FILE to the store. When FILE is in the - ;; sub-directory of a store path, it needs to be - ;; added anyway, so it can be used as a source. - (list name - (add-to-store store (basename file) - #t #f "sha256" file))) - (((? string? name) (? origin? source)) - (list name - (package-source-derivation store source))) - (x - (raise (condition (&package-input-error - (package package) - (input x)))))) + (let ((inputs (map expand-input (package-transitive-inputs package)))) (apply builder diff --git a/tests/packages.scm b/tests/packages.scm index 1319bf8634..ff23a7bf41 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -95,6 +95,25 @@ (equal? '(hello guix) (call-with-input-file (string-append p "/test") read)))))) +(test-assert "trivial with system-dependent input" + (let* ((p (package (inherit (dummy-package "trivial-system-dependent-input")) + (build-system trivial-build-system) + (source #f) + (arguments + `(#:guile ,%bootstrap-guile + #:builder + (let ((out (assoc-ref %outputs "out")) + (bash (assoc-ref %build-inputs "bash"))) + (zero? (system* bash "-c" + (format #f "echo hello > ~a" out)))))) + (inputs `(("bash" ,(lambda (system) + (search-bootstrap-binary "bash" + system))))))) + (d (package-derivation %store p))) + (and (build-derivations %store (list d)) + (let ((p (pk 'drv d (derivation-path->output-path d)))) + (eq? 'hello (call-with-input-file p read)))))) + (test-assert "GNU Hello" (let ((hello (package-with-explicit-inputs hello %bootstrap-inputs #:guile %bootstrap-guile))) |