From eddd4077a5292052d95443078ee4db9f34f2f0e2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Nov 2013 00:10:10 +0100 Subject: store: Add 'log-file' procedure. * guix/store.scm (log-file): New procedure. * tests/store.scm ("log-file, derivation", "log-file, output file name"): New tests. --- tests/store.scm | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) (limited to 'tests') diff --git a/tests/store.scm b/tests/store.scm index b5e0cb0eab..430027c33b 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -140,6 +140,33 @@ (equal? (valid-derivers %store o) (list (derivation-file-name d)))))) +(test-assert "log-file, derivation" + (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '())) + (s (add-to-store %store "bash" #t "sha256" + (search-bootstrap-binary "bash" + (%current-system)))) + (d (derivation %store "the-thing" + s `("-e" ,b) + #:env-vars `(("foo" . ,(random-text))) + #:inputs `((,b) (,s))))) + (and (build-derivations %store (list d)) + (file-exists? (pk (log-file %store (derivation-file-name d))))))) + +(test-assert "log-file, output file name" + (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '())) + (s (add-to-store %store "bash" #t "sha256" + (search-bootstrap-binary "bash" + (%current-system)))) + (d (derivation %store "the-thing" + s `("-e" ,b) + #:env-vars `(("foo" . ,(random-text))) + #:inputs `((,b) (,s)))) + (o (derivation->output-path d))) + (and (build-derivations %store (list d)) + (file-exists? (pk (log-file %store o))) + (string=? (log-file %store (derivation-file-name d)) + (log-file %store o))))) + (test-assert "no substitutes" (let* ((s (open-connection)) (d1 (package-derivation s %bootstrap-guile (%current-system))) -- cgit v1.2.3 From bf4211523baf8ab1c853aac48ef0324f8f704510 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Nov 2013 01:06:25 +0100 Subject: guix build: Add '--log-file'. * guix/scripts/build.scm (show-help): Add '--log-file'. (%options): Likewise. (guix-build): Set %FILE-PORT-NAME-CANONICALIZATION. Honor '--log-file'. * tests/guix-build.sh: Add '--log-file' tests. * doc/guix.texi (Invoking guix build): Document '--log-file'. --- doc/guix.texi | 16 ++++++ guix/scripts/build.scm | 150 +++++++++++++++++++++++++++++-------------------- tests/guix-build.sh | 11 ++++ 3 files changed, 115 insertions(+), 62 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 4fb14063d0..d0dc523a01 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1546,6 +1546,22 @@ Use the given verbosity level. @var{level} must be an integer between 0 and 5; higher means more verbose output. Setting a level of 4 or more may be helpful when debugging setup issues with the build daemon. +@item --log-file +Return the build log file names for the given +@var{package-or-derivation}s, or raise an error if build logs are +missing. + +This works regardless of how packages or derivations are specified. For +instance, the following invocations are equivalent: + +@example +guix build --log-file `guix build -d guile` +guix build --log-file `guix build guile` +guix build --log-file guile +guix build --log-file -e '(@@ (gnu packages guile) guile-2.0)' +@end example + + @end table Behind the scenes, @command{guix build} is essentially an interface to diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index a06755dc7a..f63736c09c 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -95,6 +95,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) as a garbage collector root")) (display (_ " --verbosity=LEVEL use the given verbosity LEVEL")) + (display (_ " + --log-file return the log file names for the given derivations")) (newline) (display (_ " -h, --help display this help and exit")) @@ -161,7 +163,10 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (lambda (opt name arg result) (let ((level (string->number arg))) (alist-cons 'verbosity level - (alist-delete 'verbosity result))))))) + (alist-delete 'verbosity result))))) + (option '("log-file") #f #f + (lambda (opt name arg result) + (alist-cons 'log-file? #t result))))) ;;; @@ -235,68 +240,89 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (leave (_ "~A: unknown package~%") name)))))) (with-error-handling - (let ((opts (parse-options))) - (define package->derivation - (match (assoc-ref opts 'target) - (#f package-derivation) - (triplet - (cut package-cross-derivation <> <> triplet <>)))) + ;; Ask for absolute file names so that .drv file names passed from the + ;; user to 'read-derivation' are absolute when it returns. + (with-fluids ((%file-port-name-canonicalization 'absolute)) + (let ((opts (parse-options))) + (define package->derivation + (match (assoc-ref opts 'target) + (#f package-derivation) + (triplet + (cut package-cross-derivation <> <> triplet <>)))) - (parameterize ((%store (open-connection))) - (let* ((src? (assoc-ref opts 'source?)) - (sys (assoc-ref opts 'system)) - (drv (filter-map (match-lambda - (('expression . str) - (derivations-from-package-expressions - str package->derivation sys src?)) - (('argument . (? derivation-path? drv)) - (call-with-input-file drv read-derivation)) - (('argument . (? string? x)) - (let ((p (find-package x))) - (if src? - (let ((s (package-source p))) - (package-source-derivation - (%store) s)) - (package->derivation (%store) p sys)))) - (_ #f)) - opts)) - (roots (filter-map (match-lambda - (('gc-root . root) root) - (_ #f)) - opts))) + (parameterize ((%store (open-connection))) + (let* ((src? (assoc-ref opts 'source?)) + (sys (assoc-ref opts 'system)) + (drv (filter-map (match-lambda + (('expression . str) + (derivations-from-package-expressions + str package->derivation sys src?)) + (('argument . (? derivation-path? drv)) + (call-with-input-file drv read-derivation)) + (('argument . (? store-path?)) + ;; Nothing to do; maybe for --log-file. + #f) + (('argument . (? string? x)) + (let ((p (find-package x))) + (if src? + (let ((s (package-source p))) + (package-source-derivation + (%store) s)) + (package->derivation (%store) p sys)))) + (_ #f)) + opts)) + (roots (filter-map (match-lambda + (('gc-root . root) root) + (_ #f)) + opts))) - (show-what-to-build (%store) drv - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:dry-run? (assoc-ref opts 'dry-run?)) + (unless (assoc-ref opts 'log-file?) + (show-what-to-build (%store) drv + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:dry-run? (assoc-ref opts 'dry-run?))) - ;; TODO: Add more options. - (set-build-options (%store) - #:keep-failed? (assoc-ref opts 'keep-failed?) - #:build-cores (or (assoc-ref opts 'cores) 0) - #:fallback? (assoc-ref opts 'fallback?) - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:max-silent-time (assoc-ref opts 'max-silent-time) - #:verbosity (assoc-ref opts 'verbosity)) + ;; TODO: Add more options. + (set-build-options (%store) + #:keep-failed? (assoc-ref opts 'keep-failed?) + #:build-cores (or (assoc-ref opts 'cores) 0) + #:fallback? (assoc-ref opts 'fallback?) + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:max-silent-time (assoc-ref opts 'max-silent-time) + #:verbosity (assoc-ref opts 'verbosity)) - (if (assoc-ref opts 'derivations-only?) - (begin - (format #t "~{~a~%~}" (map derivation-file-name drv)) - (for-each (cut register-root <> <>) - (map (compose list derivation-file-name) drv) - roots)) - (or (assoc-ref opts 'dry-run?) - (and (build-derivations (%store) drv) - (for-each (lambda (d) - (format #t "~{~a~%~}" - (map (match-lambda - ((out-name . out) - (derivation->output-path - d out-name))) - (derivation-outputs d)))) - drv) - (for-each (cut register-root <> <>) - (map (lambda (drv) - (map cdr - (derivation->output-paths drv))) - drv) - roots))))))))) + (cond ((assoc-ref opts 'log-file?) + (for-each (lambda (file) + (let ((log (log-file (%store) file))) + (if log + (format #t "~a~%" log) + (leave (_ "no build log for '~a'~%") + file)))) + (delete-duplicates + (append (map derivation-file-name drv) + (filter-map (match-lambda + (('argument + . (? store-path? file)) + file) + (_ #f)) + opts))))) + ((assoc-ref opts 'derivations-only?) + (format #t "~{~a~%~}" (map derivation-file-name drv)) + (for-each (cut register-root <> <>) + (map (compose list derivation-file-name) drv) + roots)) + ((not (assoc-ref opts 'dry-run?)) + (and (build-derivations (%store) drv) + (for-each (lambda (d) + (format #t "~{~a~%~}" + (map (match-lambda + ((out-name . out) + (derivation->output-path + d out-name))) + (derivation-outputs d)))) + drv) + (for-each (cut register-root <> <>) + (map (lambda (drv) + (map cdr + (derivation->output-paths drv))) + drv) + roots)))))))))) diff --git a/tests/guix-build.sh b/tests/guix-build.sh index 83de9f5285..e228b38616 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -36,6 +36,17 @@ guix build -e '(@@ (gnu packages base) %bootstrap-guile)' | \ guix build hello -d | \ grep -e '-hello-[0-9\.]\+\.drv$' +# Should all return valid log files. +drv="`guix build -d -e '(@@ (gnu packages base) %bootstrap-guile)'`" +out="`guix build -e '(@@ (gnu packages base) %bootstrap-guile)'`" +log="`guix build --log-file $drv`" +echo "$log" | grep log/.*guile.*drv +test -f "$log" +test "`guix build -e '(@@ (gnu packages base) %bootstrap-guile)' --log-file`" \ + = "$log" +test "`guix build --log-file guile-bootstrap`" = "$log" +test "`guix build --log-file $out`" = "$log" + # Should fail because the name/version combination could not be found. if guix build hello-0.0.1 -n; then false; else true; fi -- cgit v1.2.3 From 56b943de6e61f41d6ebd2dfa65ff886cdfd83759 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Nov 2013 22:56:13 +0100 Subject: utils: Add 'string-replace-substring'. * guix/utils.scm (string-replace-substring): New procedure. Based on code by Mark H. Weaver. * tests/utils.scm ("string-replace-substring"): New test. --- guix/utils.scm | 24 ++++++++++++++++++++++++ tests/utils.scm | 8 ++++++++ 2 files changed, 32 insertions(+) (limited to 'tests') diff --git a/guix/utils.scm b/guix/utils.scm index 1f3c0c8ad6..b730340eda 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2013 Mark H Weaver ;;; ;;; This file is part of GNU Guix. ;;; @@ -62,6 +63,7 @@ guile-version>? package-name->name+version string-tokenize* + string-replace-substring file-extension file-sans-extension call-with-temporary-output-file @@ -387,6 +389,28 @@ like `string-tokenize', but SEPARATOR is a string." (else (reverse (cons string result)))))) +(define* (string-replace-substring str substr replacement + #:optional + (start 0) + (end (string-length str))) + "Replace all occurrences of SUBSTR in the START--END range of STR by +REPLACEMENT." + (match (string-length substr) + (0 + (error "string-replace-substring: empty substring")) + (substr-length + (let loop ((start start) + (pieces (list (substring str 0 start)))) + (match (string-contains str substr start end) + (#f + (string-concatenate-reverse + (cons (substring str start) pieces))) + (index + (loop (+ index substr-length) + (cons* replacement + (substring str start index) + pieces)))))))) + (define (call-with-temporary-output-file proc) "Call PROC with a name of a temporary file and open output port to that file; close the file and delete it when leaving the dynamic extent of this diff --git a/tests/utils.scm b/tests/utils.scm index 4f6ecc514d..017d9170fa 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -82,6 +82,14 @@ (string-tokenize* "foo!bar!" "!") (string-tokenize* "foo+-+bar+-+baz" "+-+"))) +(test-equal "string-replace-substring" + '("foo BAR! baz" + "/gnu/store/chbouib" + "") + (list (string-replace-substring "foo bar baz" "bar" "BAR!") + (string-replace-substring "/nix/store/chbouib" "/nix/" "/gnu/") + (string-replace-substring "" "foo" "bar"))) + (test-equal "fold2, 1 list" (list (reverse (iota 5)) (map - (reverse (iota 5)))) -- cgit v1.2.3 From e387ab7c10b18427b97cd22526f1b135856a083e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 13 Nov 2013 00:25:57 +0100 Subject: derivations: Add 'map-derivation'. * guix/derivations.scm (map-derivation): New procedure. * tests/derivations.scm ("map-derivation"): New test. --- guix/derivations.scm | 97 +++++++++++++++++++++++++++++++++++++++++++++++++++ tests/derivations.scm | 30 ++++++++++++++++ 2 files changed, 127 insertions(+) (limited to 'tests') 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 + (($ 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) + ((($ _ algo hash)) + hash) + (_ #f)) + #:hash-algo (match (derivation-outputs drv) + ((($ _ 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 . _) (stringderivation %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) -- cgit v1.2.3 From 9336e5b5e7b05e636b147aba2c97357620711c2a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Nov 2013 23:36:29 +0100 Subject: store: Make 'direct-store-path?' public. * guix/store.scm (direct-store-path?): New procedure. * guix/derivations.scm (derivation)[direct-store-path?]: Remove. * tests/store.scm ("direct-store-path?"): New test. --- guix/derivations.scm | 9 --------- guix/store.scm | 9 +++++++++ tests/store.scm | 9 +++++++++ 3 files changed, 18 insertions(+), 9 deletions(-) (limited to 'tests') diff --git a/guix/derivations.scm b/guix/derivations.scm index 011f4b778b..b33e835556 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -541,15 +541,6 @@ advance, such as a file download. When REFERENCES-GRAPHS is true, it must be a list of file name/store path pairs. In that case, the reference graph of each store path is exported in the build environment in the corresponding file, in a simple text format." - (define direct-store-path? - (let ((len (+ 1 (string-length (%store-prefix))))) - (lambda (p) - ;; Return #t if P is a store path, and not a sub-directory of a - ;; store path. This predicate is needed because files *under* a - ;; store path are not valid inputs. - (and (store-path? p) - (not (string-index (substring p len) #\/)))))) - (define (add-output-paths drv) ;; Return DRV with an actual store path for each of its output and the ;; corresponding environment variable. diff --git a/guix/store.scm b/guix/store.scm index 290118d74b..2821cacdcc 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -85,6 +85,7 @@ %store-prefix store-path? + direct-store-path? derivation-path? store-path-package-name store-path-hash-part @@ -640,6 +641,14 @@ collected, and the number of bytes freed." ;; `isStorePath' in Nix does something similar. (string-prefix? (%store-prefix) path)) +(define (direct-store-path? path) + "Return #t if PATH is a store path, and not a sub-directory of a store path. +This predicate is sometimes needed because files *under* a store path are not +valid inputs." + (and (store-path? path) + (let ((len (+ 1 (string-length (%store-prefix))))) + (not (string-index (substring path len) #\/))))) + (define (derivation-path? path) "Return #t if PATH is a derivation path." (and (store-path? path) (string-suffix? ".drv" path))) diff --git a/tests/store.scm b/tests/store.scm index 430027c33b..741803884d 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -65,6 +65,15 @@ (string-append (%store-prefix) "/foo/bar/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7"))) +(test-assert "direct-store-path?" + (and (direct-store-path? + (string-append (%store-prefix) + "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")) + (not (direct-store-path? + (string-append + (%store-prefix) + "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7/bin/guile"))))) + (test-skip (if %store 0 10)) (test-assert "dead-paths" -- cgit v1.2.3 From f80594cc41d7ad491f14a73d594228bacafdc871 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Nov 2013 23:44:47 +0100 Subject: packages: Suitably cope with indirect store paths as package sources. * guix/packages.scm (package-source-derivation): Don't let indirect store paths pass through. * tests/packages.scm ("package-source-derivation, indirect store path"): New test. --- guix/packages.scm | 2 +- tests/packages.scm | 11 +++++++++++ 2 files changed, 12 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/guix/packages.scm b/guix/packages.scm index d4a295e3ac..b25cc52bba 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -413,7 +413,7 @@ IMPORTED-MODULES specify modules to use/import for use by SNIPPET." #:guile-for-build (or guile-for-build (%guile-for-build) (default-guile store system))))) - ((and (? string?) (? store-path?) file) + ((and (? string?) (? direct-store-path?) file) file) ((? string? file) (add-to-store store (basename file) #t "sha256" file)))) diff --git a/tests/packages.scm b/tests/packages.scm index 7c5dd9f4e1..b499c380ce 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -122,6 +122,17 @@ (package-source package)))) (string=? file source))) +(test-assert "package-source-derivation, indirect store path" + (let* ((dir (add-to-store %store "guix-build" #t "sha256" + (dirname (search-path %load-path + "guix/build/utils.scm")))) + (package (package (inherit (dummy-package "p")) + (source (string-append dir "/utils.scm")))) + (source (package-source-derivation %store + (package-source package)))) + (and (direct-store-path? source) + (string-suffix? "utils.scm" source)))) + (test-equal "package-source-derivation, snippet" "OK" (let* ((file (search-bootstrap-binary "guile-2.0.7.tar.xz" -- cgit v1.2.3 From a716e36de915a275e4eab42b73cf0a2affc4aa33 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 13 Nov 2013 11:22:07 +0100 Subject: derivations: Allow 'map-derivations' to replace sources. * guix/derivations.scm (map-derivation)[input->output-paths]: Allow non-derivation inputs. Allow replacements to be store files. Replace in SOURCES too. * tests/derivations.scm ("map-derivation, sources"): New test. --- guix/derivations.scm | 26 +++++++++++++++++++------- tests/derivations.scm | 22 ++++++++++++++++++++++ 2 files changed, 41 insertions(+), 7 deletions(-) (limited to 'tests') diff --git a/guix/derivations.scm b/guix/derivations.scm index b33e835556..63c1ba4f2b 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -674,17 +674,21 @@ recursively." (define input->output-paths (match-lambda - ((drv) + (((? derivation? drv)) (list (derivation->output-path drv))) - ((drv sub-drvs ...) + (((? derivation? drv) sub-drvs ...) (map (cut derivation->output-path drv <>) - sub-drvs)))) + sub-drvs)) + ((file) + (list file)))) (let ((mapping (fold (lambda (pair result) (match pair - ((orig . replacement) + (((? derivation? orig) . replacement) (vhash-cons (derivation-file-name orig) - replacement result)))) + replacement result)) + ((file . replacement) + (vhash-cons file replacement result)))) vlist-null mapping))) (define rewritten-input @@ -695,8 +699,10 @@ recursively." (match input (($ path (sub-drvs ...)) (match (vhash-assoc path mapping) - ((_ . replacement) + ((_ . (? derivation? replacement)) (cons replacement sub-drvs)) + ((_ . replacement) + (list replacement)) (#f (let* ((drv (loop (call-with-input-file path read-derivation)))) (cons drv sub-drvs))))))))) @@ -711,7 +717,13 @@ recursively." ;; Sources typically refer to the output directories of the ;; original inputs, INITIAL. Rewrite them by substituting ;; REPLACEMENTS. - (sources (map (cut substitute-file <> initial replacements) + (sources (map (lambda (source) + (match (vhash-assoc source mapping) + ((_ . replacement) + replacement) + (#f + (substitute-file source + initial replacements)))) (derivation-sources drv))) ;; Now augment the lists of initials and replacements. diff --git a/tests/derivations.scm b/tests/derivations.scm index 09cf81972c..a4e073bf07 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -720,6 +720,28 @@ Deriver: ~a~%" (and (build-derivations %store (list (pk 'remapped drv4))) (call-with-input-file out get-string-all)))) +(test-equal "map-derivation, sources" + "hello" + (let* ((script1 (add-text-to-store %store "fail.sh" "exit 1")) + (script2 (add-text-to-store %store "hi.sh" "echo -n hello > $out")) + (bash-full (package-derivation %store (@ (gnu packages bash) bash))) + (drv1 (derivation %store "drv-to-remap" + + ;; XXX: This wouldn't work in practice, but if + ;; we append "/bin/bash" then we can't replace + ;; it with the bootstrap bash, which is a + ;; single file. + (derivation->output-path bash-full) + + `("-e" ,script1) + #:inputs `((,bash-full) (,script1)))) + (drv2 (map-derivation %store drv1 + `((,bash-full . ,%bash) + (,script1 . ,script2)))) + (out (derivation->output-path drv2))) + (and (build-derivations %store (list (pk 'remapped* drv2))) + (call-with-input-file out get-string-all)))) + (test-end) -- cgit v1.2.3 From ac5de156ae5de8cb61870469863fb862b6a1205e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 18 Nov 2013 23:08:20 +0100 Subject: guix build: '-e' can be passed a monadic thunk. * guix/ui.scm (read/eval): New procedure. (read/eval-package-expression): Use it. * guix/scripts/build.scm (derivations-from-package-expressions): Rename to... (derivation-from-expression): ... this. Accept procedures, under the assumption that they are monadic thunk. (show-help): Adjust accordingly. (guix-build): Ditto. * tests/guix-build.sh: Add test. * doc/guix.texi (Invoking guix build): Augment description of '-e'. --- doc/guix.texi | 6 +++++- guix/scripts/build.scm | 33 +++++++++++++++++++-------------- guix/ui.scm | 31 ++++++++++++++++++------------- tests/guix-build.sh | 8 ++++++++ 4 files changed, 50 insertions(+), 28 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index cfa5aac326..847c73ab8c 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1483,12 +1483,16 @@ The @var{options} may be zero or more of the following: @item --expression=@var{expr} @itemx -e @var{expr} -Build the package @var{expr} evaluates to. +Build the package or derivation @var{expr} evaluates to. For example, @var{expr} may be @code{(@@ (gnu packages guile) guile-1.8)}, which unambiguously designates this specific variant of version 1.8 of Guile. +Alternately, @var{expr} may refer to a zero-argument monadic procedure +(@pxref{The Store Monad}). The procedure must return a derivation as a +monadic value, which is then passed through @code{run-with-store}. + @item --source @itemx -S Build the packages' source derivations, rather than the packages diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index f63736c09c..dd9a9b8127 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -23,6 +23,7 @@ #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix utils) + #:use-module (guix monads) #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 vlist) @@ -38,19 +39,23 @@ (define %store (make-parameter #f)) -(define (derivations-from-package-expressions str package-derivation - system source?) +(define (derivation-from-expression str package-derivation + system source?) "Read/eval STR and return the corresponding derivation path for SYSTEM. -When SOURCE? is true, return the derivations of the package sources; -otherwise, use PACKAGE-DERIVATION to compute the derivation of a package." - (let ((p (read/eval-package-expression str))) - (if source? - (let ((source (package-source p))) - (if source - (package-source-derivation (%store) source) - (leave (_ "package `~a' has no source~%") - (package-name p)))) - (package-derivation (%store) p system)))) +When SOURCE? is true and STR evaluates to a package, return the derivation of +the package source; otherwise, use PACKAGE-DERIVATION to compute the +derivation of a package." + (match (read/eval str) + ((? package? p) + (if source? + (let ((source (package-source p))) + (if source + (package-source-derivation (%store) source) + (leave (_ "package `~a' has no source~%") + (package-name p)))) + (package-derivation (%store) p system))) + ((? procedure? proc) + (run-with-store (%store) (proc) #:system system)))) ;;; @@ -68,7 +73,7 @@ otherwise, use PACKAGE-DERIVATION to compute the derivation of a package." (display (_ "Usage: guix build [OPTION]... PACKAGE-OR-DERIVATION... Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (display (_ " - -e, --expression=EXPR build the package EXPR evaluates to")) + -e, --expression=EXPR build the package or derivation EXPR evaluates to")) (display (_ " -S, --source build the packages' source derivations")) (display (_ " @@ -255,7 +260,7 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (sys (assoc-ref opts 'system)) (drv (filter-map (match-lambda (('expression . str) - (derivations-from-package-expressions + (derivation-from-expression str package->derivation sys src?)) (('argument . (? derivation-path? drv)) (call-with-input-file drv read-derivation)) diff --git a/guix/ui.scm b/guix/ui.scm index 8a28574c3c..f15419f7a8 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -45,6 +45,7 @@ show-what-to-build call-with-error-handling with-error-handling + read/eval read/eval-package-expression location->string switch-symlinks @@ -193,25 +194,29 @@ General help using GNU software: ")) (leave (_ "~a~%") (strerror (system-error-errno args))))))) -(define (read/eval-package-expression str) - "Read and evaluate STR and return the package it refers to, or exit an -error." +(define (read/eval str) + "Read and evaluate STR, raising an error if something goes wrong." (let ((exp (catch #t (lambda () (call-with-input-string str read)) (lambda args (leave (_ "failed to read expression ~s: ~s~%") str args))))) - (let ((p (catch #t - (lambda () - (eval exp the-scm-module)) - (lambda args - (leave (_ "failed to evaluate expression `~a': ~s~%") - exp args))))) - (if (package? p) - p - (leave (_ "expression `~s' does not evaluate to a package~%") - exp))))) + (catch #t + (lambda () + (eval exp the-scm-module)) + (lambda args + (leave (_ "failed to evaluate expression `~a': ~s~%") + exp args))))) + +(define (read/eval-package-expression str) + "Read and evaluate STR and return the package it refers to, or exit an +error." + (match (read/eval str) + ((? package? p) p) + (_ + (leave (_ "expression ~s does not evaluate to a package~%") + str)))) (define* (show-what-to-build store drv #:key dry-run? (use-substitutes? #t)) diff --git a/tests/guix-build.sh b/tests/guix-build.sh index e228b38616..391e7b9da3 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -72,3 +72,11 @@ if guix build -n time-3.2; # FAIL, version not found then false; else true; fi if guix build -n something-that-will-never-exist; # FAIL then false; else true; fi + +# Invoking a monadic procedure. +guix build -e "(begin + (use-modules (guix monads) (guix utils)) + (lambda () + (derivation-expression \"test\" (%current-system) + '(mkdir %output) '())))" \ + --dry-run -- cgit v1.2.3 From 0b8749b7bdd68c9b28cf3d520b9a3a9cc1a5bddb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 18 Nov 2013 23:56:07 +0100 Subject: packages: 'package-field-location' returns a relative file name. * guix/packages.scm (package-field-location): Set %FILE-PORT-NAME-CANONICALIZATION. * tests/packages.scm ("package-field-location, relative file name"): New test. --- guix/packages.scm | 38 ++++++++++++++++++++------------------ tests/packages.scm | 6 ++++++ 2 files changed, 26 insertions(+), 18 deletions(-) (limited to 'tests') diff --git a/guix/packages.scm b/guix/packages.scm index b25cc52bba..bb7d873973 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -221,24 +221,26 @@ corresponds to the arguments expected by `set-path-environment-variable'." (($ file line column) (catch 'system (lambda () - (call-with-input-file (search-path %load-path file) - (lambda (port) - (goto port line column) - (match (read port) - (('package inits ...) - (let ((field (assoc field inits))) - (match field - ((_ value) - ;; Put the `or' here, and not in the first argument of - ;; `and=>', to work around a compiler bug in 2.0.5. - (or (and=> (source-properties value) - source-properties->location) - (and=> (source-properties field) - source-properties->location))) - (_ - #f)))) - (_ - #f))))) + ;; In general we want to keep relative file names for modules. + (with-fluids ((%file-port-name-canonicalization 'relative)) + (call-with-input-file (search-path %load-path file) + (lambda (port) + (goto port line column) + (match (read port) + (('package inits ...) + (let ((field (assoc field inits))) + (match field + ((_ value) + ;; Put the `or' here, and not in the first argument of + ;; `and=>', to work around a compiler bug in 2.0.5. + (or (and=> (source-properties value) + source-properties->location) + (and=> (source-properties field) + source-properties->location))) + (_ + #f)))) + (_ + #f)))))) (lambda _ #f))) (_ #f))) diff --git a/tests/packages.scm b/tests/packages.scm index b499c380ce..7de3fc2156 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -81,6 +81,12 @@ (list version `(version ,version)))) (not (package-field-location %bootstrap-guile 'does-not-exist))))) +;; Make sure we don't change the file name to an absolute file name. +(test-equal "package-field-location, relative file name" + (location-file (package-location %bootstrap-guile)) + (with-fluids ((%file-port-name-canonicalization 'absolute)) + (location-file (package-field-location %bootstrap-guile 'version)))) + (test-assert "package-transitive-inputs" (let* ((a (dummy-package "a")) (b (dummy-package "b" -- cgit v1.2.3