From b911d6547444b5f8d17b224bafa5ee1b5aafaff5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 15 Sep 2020 14:24:05 +0200 Subject: authenticate: Encode strings as ISO-8859-1. Fixes . * guix/scripts/authenticate.scm (read-command): Decode strings as ISO-8859-1, not UTF-8. (guix-authenticate)[send-reply]: Encode strings as ISO-8859-1, not UTF-8. * tests/guix-authenticate.sh: Add test. --- tests/guix-authenticate.sh | 9 +++++++++ 1 file changed, 9 insertions(+) (limited to 'tests') diff --git a/tests/guix-authenticate.sh b/tests/guix-authenticate.sh index f3b36ee41d..3a05b232c1 100644 --- a/tests/guix-authenticate.sh +++ b/tests/guix-authenticate.sh @@ -61,6 +61,15 @@ sed -i "$sig" \ code="$(echo "verify $(cat $sig)" | guix authenticate | cut -f1 -d ' ')" test "$code" -ne 0 +# Make sure byte strings are correctly encoded. The hash string below is +# "café" repeated 8 times. Libgcrypt would normally choose to write it as a +# string rather than a hex sequence. We want that string to be Latin-1 +# encoded independently of the current locale: . +hash="636166e9636166e9636166e9636166e9636166e9636166e9636166e9636166e9" +latin1_cafe="caf$(printf '\351')" +echo "sign 21:tests/signing-key.sec 64:$hash" | guix authenticate \ + | LC_ALL=C grep "hash sha256 \"$latin1_cafe" + # Test for : make sure 'guix authenticate' produces # valid signatures when run in the C locale. hash="5eff0b55c9c5f5e87b4e34cd60a2d5654ca1eb78c7b3c67c3179fed1cff07b4c" -- cgit v1.2.3 From d7f7ed39be3be926b3c46c0ea15d416c593ef61f Mon Sep 17 00:00:00 2001 From: Konrad Hinsen Date: Fri, 11 Sep 2020 13:13:26 +0200 Subject: repl: Look for script files in (getcwd). MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . * guix/scripts/repl.scm (guix-repl): Replace "." by (getcwd) * tests/guix-repl.sh: Add test. Co-authored-by: Ludovic Courtès --- guix/scripts/repl.scm | 5 ++++- tests/guix-repl.sh | 4 ++++ 2 files changed, 8 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/guix/scripts/repl.scm b/guix/scripts/repl.scm index 3c79e89f8d..7d4e474e92 100644 --- a/guix/scripts/repl.scm +++ b/guix/scripts/repl.scm @@ -178,7 +178,10 @@ call THUNK." (lambda () (set-program-arguments script) (set-user-module) - (load-in-vicinity "." (car script))))) + + ;; When passed a relative file name, 'load-in-vicinity' searches the + ;; file in %LOAD-PATH. Thus, pass (getcwd) instead of ".". + (load-in-vicinity (getcwd) (car script))))) (when (null? script) ;; Start REPL diff --git a/tests/guix-repl.sh b/tests/guix-repl.sh index e1c2b8241f..d4ebb5f6c6 100644 --- a/tests/guix-repl.sh +++ b/tests/guix-repl.sh @@ -45,6 +45,10 @@ EOF test "`guix repl "$tmpfile"`" = "coreutils" +# Make sure that the file can also be loaded when passed as a relative file +# name. +(cd "$(dirname "$tmpfile")"; test "$(guix repl "$(basename "$tmpfile")")" = "coreutils") + cat > "$module_dir/foo.scm"< Date: Mon, 14 Sep 2020 22:49:06 +0200 Subject: environment: '--link-profile' uses ~/.guix-profile for environment variables. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Before this patch, we had: $ guix environment -CP --ad-hoc coreutils [env]$ echo $PATH /gnu/store/…-profile/bin [env]$ echo $GUIX_ENVIRONMENT /gnu/store/…-profile After this patch: $ guix environment -CP --ad-hoc coreutils [env]$ echo $PATH /home/ludo/.guix-profile/bin [env]$ echo $GUIX_ENVIRONMENT /home/ludo/.guix-profile * guix/scripts/environment.scm (launch-environment/container): When LINK-PROFILE? is true, pass ~/.guix-profile as the second argument to 'launch-environment'. * tests/guix-environment-container.sh: Adjust test accordingly. * doc/guix.texi (Invoking guix environment): Update accordingly. --- doc/guix.texi | 5 +++-- guix/scripts/environment.scm | 6 +++++- tests/guix-environment-container.sh | 10 +++++++--- 3 files changed, 15 insertions(+), 6 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index f7e2204b53..949551a163 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5420,8 +5420,9 @@ device. @item --link-profile @itemx -P For containers, link the environment profile to @file{~/.guix-profile} -within the container. This is equivalent to running the command -@samp{ln -s $GUIX_ENVIRONMENT ~/.guix-profile} within the container. +within the container and set @code{GUIX_ENVIRONMENT} to that. +This is equivalent to making @file{~/.guix-profile} a symlink to the +actual profile within the container. Linking will fail and abort the environment if the directory already exists, which will certainly be the case if @command{guix environment} was invoked in the user's home directory. diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index ad50281eb2..e2e481dd02 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -564,7 +564,11 @@ WHILE-LIST." (primitive-exit/status ;; A container's environment is already purified, so no need to ;; request it be purified again. - (launch-environment command profile manifest #:pure? #f))) + (launch-environment command + (if link-profile? + (string-append home-dir "/.guix-profile") + profile) + manifest #:pure? #f))) #:guest-uid uid #:guest-gid gid #:namespaces (if network? diff --git a/tests/guix-environment-container.sh b/tests/guix-environment-container.sh index 45264d4978..040f32cce9 100644 --- a/tests/guix-environment-container.sh +++ b/tests/guix-environment-container.sh @@ -127,11 +127,15 @@ grep -e "$NIX_STORE_DIR/.*-bash" $tmpdir/mounts # bootstrap bash rm $tmpdir/mounts -# Make sure 'GUIX_ENVIRONMENT' is linked to '~/.guix-profile' when requested +# Make sure 'GUIX_ENVIRONMENT' is set to '~/.guix-profile' when requested # within a container. ( - linktest='(exit (string=? (getenv "GUIX_ENVIRONMENT") -(readlink (string-append (getenv "HOME") "/.guix-profile"))))' + linktest=' +(exit (and (string=? (getenv "GUIX_ENVIRONMENT") + (string-append (getenv "HOME") "/.guix-profile")) + (string-prefix? "'"$NIX_STORE_DIR"'" + (readlink (string-append (getenv "HOME") + "/.guix-profile")))))' cd "$tmpdir" \ && guix environment --bootstrap --container --link-profile \ -- cgit v1.2.3 From f458cfbcc54ed87b1a87dd9e150ea276f17eab74 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 23 Sep 2020 22:29:17 +0200 Subject: guix build: Add '--without-tests'. * guix/scripts/build.scm (transform-package-tests): New procedure. (%transformations, %transformation-options) show-transformation-options-help): Add it. * tests/scripts-build.scm ("options->transformation, without-tests"): New test. * doc/guix.texi (Package Transformation Options): Document it. --- doc/guix.texi | 22 ++++++++++++++++++++++ guix/scripts/build.scm | 31 ++++++++++++++++++++++++++++--- tests/scripts-build.scm | 14 ++++++++++++++ 3 files changed, 64 insertions(+), 3 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 538e7cceab..8384eee6c3 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -9271,6 +9271,28 @@ guix build --with-branch=guile-sqlite3=master cuirass This is similar to @option{--with-branch}, except that it builds from @var{commit} rather than the tip of a branch. @var{commit} must be a valid Git commit SHA1 identifier or a tag. + +@cindex test suite, skipping +@item --without-tests=@var{package} +Build @var{package} without running its tests. This can be useful in +situations where you want to skip the lengthy test suite of a +intermediate package, or if a package's test suite fails in a +non-deterministic fashion. It should be used with care because running +the test suite is a good way to ensure a package is working as intended. + +Turning off tests leads to a different store item. Consequently, when +using this option, anything that depends on @var{package} must be +rebuilt, as in this example: + +@example +guix install --without-tests=python python-notebook +@end example + +The command above installs @code{python-notebook} on top of +@code{python} built without running its test suite. To do so, it also +rebuilds everything that depends on @code{python}, including +@code{python-notebook} itself. + @end table @node Additional Build Options diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 38e0516c95..f238e9b876 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -393,6 +393,25 @@ a checkout of the Git repository at the given URL." (rewrite obj) obj))) +(define (transform-package-tests specs) + "Return a procedure that, when passed a package, sets #:tests? #f in its +'arguments' field." + (define (package-without-tests p) + (package/inherit p + (arguments + (substitute-keyword-arguments (package-arguments p) + ((#:tests? _ #f) #f))))) + + (define rewrite + (package-input-rewriting/spec (map (lambda (spec) + (cons spec package-without-tests)) + specs))) + + (lambda (store obj) + (if (package? obj) + (rewrite obj) + obj))) + (define %transformations ;; Transformations that can be applied to things to build. The car is the ;; key used in the option alist, and the cdr is the transformation @@ -403,7 +422,8 @@ a checkout of the Git repository at the given URL." (with-graft . ,transform-package-inputs/graft) (with-branch . ,transform-package-source-branch) (with-commit . ,transform-package-source-commit) - (with-git-url . ,transform-package-source-git-url))) + (with-git-url . ,transform-package-source-git-url) + (without-tests . ,transform-package-tests))) (define %transformation-options ;; The command-line interface to the above transformations. @@ -423,7 +443,9 @@ a checkout of the Git repository at the given URL." (option '("with-commit") #t #f (parser 'with-commit)) (option '("with-git-url") #t #f - (parser 'with-git-url))))) + (parser 'with-git-url)) + (option '("without-tests") #t #f + (parser 'without-tests))))) (define (show-transformation-options-help) (display (G_ " @@ -443,7 +465,10 @@ a checkout of the Git repository at the given URL." build PACKAGE from COMMIT")) (display (G_ " --with-git-url=PACKAGE=URL - build PACKAGE from the repository at URL"))) + build PACKAGE from the repository at URL")) + (display (G_ " + --without-tests=PACKAGE + build PACKAGE without running its tests"))) (define (options->transformation opts) diff --git a/tests/scripts-build.scm b/tests/scripts-build.scm index 32876e956a..12114fc8f5 100644 --- a/tests/scripts-build.scm +++ b/tests/scripts-build.scm @@ -264,5 +264,19 @@ ((("x" dep3)) (map package-source (list dep1 dep3)))))))))))) +(test-assert "options->transformation, without-tests" + (let* ((dep (dummy-package "dep")) + (p (dummy-package "foo" + (inputs `(("dep" ,dep))))) + (t (options->transformation '((without-tests . "dep") + (without-tests . "tar"))))) + (with-store store + (let ((new (t store p))) + (match (bag-direct-inputs (package->bag new)) + ((("dep" dep) ("tar" tar) _ ...) + ;; TODO: Check whether TAR has #:tests? #f when transformations + ;; apply to implicit inputs. + (equal? (package-arguments dep) + '(#:tests? #f)))))))) (test-end) -- cgit v1.2.3 From ff39361c80dfc67a9afe35f315a774140d8cf99b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 21 Sep 2020 17:44:29 +0200 Subject: packages: 'package-mapping' can recurse on implicit inputs. * guix/packages.scm (build-system-with-package-mapping): New procedure. (package-mapping): Add #:deep? and honor it. * tests/packages.scm ("package-mapping"): Compare the direct inputs of the bag of P0 and that of P1. ("package-mapping, deep"): New test. --- doc/guix.texi | 5 +++-- guix/packages.scm | 65 +++++++++++++++++++++++++++++++++++++++++------------- tests/packages.scm | 36 +++++++++++++++++++++++++++++- 3 files changed, 88 insertions(+), 18 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 8384eee6c3..054449d8d6 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6296,10 +6296,11 @@ A more generic procedure to rewrite a package dependency graph is @code{package-mapping}: it supports arbitrary changes to nodes in the graph. -@deffn {Scheme Procedure} package-mapping @var{proc} [@var{cut?}] +@deffn {Scheme Procedure} package-mapping @var{proc} [@var{cut?}] [#:deep? #f] Return a procedure that, given a package, applies @var{proc} to all the packages depended on and returns the resulting package. The procedure stops recursion -when @var{cut?} returns true for a given package. +when @var{cut?} returns true for a given package. When @var{deep?} is true, @var{proc} is +applied to implicit inputs as well. @end deffn @menu diff --git a/guix/packages.scm b/guix/packages.scm index 6598bd3149..171fd048ef 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -968,10 +968,31 @@ packages they depend on, recursively." (vhash-consq package #t visited) (fold set-insert closure dependencies)))))))) -(define* (package-mapping proc #:optional (cut? (const #f))) +(define (build-system-with-package-mapping bs rewrite) + "Return a variant of BS, a build system, that rewrites a bag's inputs by +passing them through REWRITE, a procedure that takes an input tuplet and +returns a \"rewritten\" input tuplet." + (define lower + (build-system-lower bs)) + + (define (lower* . args) + (let ((lowered (apply lower args))) + (bag + (inherit lowered) + (build-inputs (map rewrite (bag-build-inputs lowered))) + (host-inputs (map rewrite (bag-host-inputs lowered))) + (target-inputs (map rewrite (bag-target-inputs lowered)))))) + + (build-system + (inherit bs) + (lower lower*))) + +(define* (package-mapping proc #:optional (cut? (const #f)) + #:key deep?) "Return a procedure that, given a package, applies PROC to all the packages depended on and returns the resulting package. The procedure stops recursion -when CUT? returns true for a given package." +when CUT? returns true for a given package. When DEEP? is true, PROC is +applied to implicit inputs as well." (define (rewrite input) (match input ((label (? package? package) outputs ...) @@ -980,21 +1001,35 @@ when CUT? returns true for a given package." (_ input))) + (define mapping-property + ;; Property indicating whether the package has already been processed. + (gensym " package-mapping-done")) + (define replace (mlambdaq (p) - ;; Return a variant of P with PROC applied to P and its explicit - ;; dependencies, recursively. Memoize the transformations. Failing to - ;; do that, we would build a huge object graph with lots of duplicates, - ;; which in turns prevents us from benefiting from memoization in - ;; 'package-derivation'. - (let ((p (proc p))) - (package - (inherit p) - (location (package-location p)) - (inputs (map rewrite (package-inputs p))) - (native-inputs (map rewrite (package-native-inputs p))) - (propagated-inputs (map rewrite (package-propagated-inputs p))) - (replacement (and=> (package-replacement p) proc)))))) + ;; If P is the result of a previous call, return it. + (if (assq-ref (package-properties p) mapping-property) + p + + ;; Return a variant of P with PROC applied to P and its explicit + ;; dependencies, recursively. Memoize the transformations. Failing + ;; to do that, we would build a huge object graph with lots of + ;; duplicates, which in turns prevents us from benefiting from + ;; memoization in 'package-derivation'. + (let ((p (proc p))) + (package + (inherit p) + (location (package-location p)) + (build-system (if deep? + (build-system-with-package-mapping + (package-build-system p) rewrite) + (package-build-system p))) + (inputs (map rewrite (package-inputs p))) + (native-inputs (map rewrite (package-native-inputs p))) + (propagated-inputs (map rewrite (package-propagated-inputs p))) + (replacement (and=> (package-replacement p) proc)) + (properties `((,mapping-property . #t) + ,@(package-properties p)))))))) replace) diff --git a/tests/packages.scm b/tests/packages.scm index cbd0503733..f33332a461 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -1172,15 +1172,24 @@ (let* ((dep (dummy-package "chbouib" (native-inputs `(("x" ,grep))))) (p0 (dummy-package "example" + (source 77) (inputs `(("foo" ,coreutils) ("bar" ,grep) ("baz" ,dep))))) (transform (lambda (p) (package (inherit p) (source 42)))) (rewrite (package-mapping transform)) - (p1 (rewrite p0))) + (p1 (rewrite p0)) + (bag0 (package->bag p0)) + (bag1 (package->bag p1))) (and (eq? p1 (rewrite p0)) (eqv? 42 (package-source p1)) + + ;; Implicit inputs should be left unchanged (skip "source", "foo", + ;; "bar", and "baz" in this comparison). + (equal? (drop (bag-direct-inputs bag0) 4) + (drop (bag-direct-inputs bag1) 4)) + (match (package-inputs p1) ((("foo" dep1) ("bar" dep2) ("baz" dep3)) (and (eq? dep1 (rewrite coreutils)) ;memoization @@ -1194,6 +1203,31 @@ (and (eq? dep (rewrite grep)) (package-source dep)))))))))) +(test-equal "package-mapping, deep" + '(42) + (let* ((p0 (dummy-package "example" + (inputs `(("foo" ,coreutils) + ("bar" ,grep))))) + (transform (lambda (p) + (package (inherit p) (source 42)))) + (rewrite (package-mapping transform #:deep? #t)) + (p1 (rewrite p0)) + (bag (package->bag p1))) + (and (eq? p1 (rewrite p0)) + (match (bag-direct-inputs bag) + ((("source" 42) ("foo" dep1) ("bar" dep2) rest ..1) + (and (eq? dep1 (rewrite coreutils)) ;memoization + (eq? dep2 (rewrite grep)) + (= 42 (package-source dep1)) + (= 42 (package-source dep2)) + + ;; Check that implicit inputs of P0 also got rewritten. + (delete-duplicates + (map (match-lambda + ((_ package . _) + (package-source package))) + rest)))))))) + (test-assert "package-input-rewriting" (let* ((dep (dummy-package "chbouib" (native-inputs `(("x" ,grep))))) -- cgit v1.2.3 From 2bf6f962b91123b0474c0f7123cd17efe7f09a66 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 23 Sep 2020 10:29:09 +0200 Subject: packages: 'package-input-rewriting/spec' can rewrite implicit dependencies. With this change, '--with-input', '--with-graft', etc. also apply to implicit dependencies. Thus, it's now possible to do: guix build python-itsdangerous --with-input=python-wrapper=python@2 or: guix build hello --with-graft=glibc=glibc@2.29 Additionally, before, implicit inputs were not rewritten, which could lead to duplicates in the output of 'bag-transitive-inputs' (packages that are not 'eq?' but lead to the same derivation). This in turn would lead to unnecessary rebuilds when using '--with-input' & co. This change fixes it by ensuring even implicit inputs are rewritten. Fixes . * guix/packages.scm (package-input-rewriting/spec): Add #:deep? defaulting to #true, and pass it to 'package-mapping'. [replacement-property]: New variable. [rewrite]: Check that property and set it on the result of PROC. [cut?]: New procedure. * tests/packages.scm ("package-input-rewriting/spec"): Ensure implicit inputs were unchanged. ("package-input-rewriting/spec, partial match"): Pass #:deep? #f. ("package-input-rewriting/spec, deep") ("package-input-rewriting/spec, no duplicates"): New tests. (package/inherit): Move before use. * tests/guix-build.sh: Add tests. * tests/scripts-build.scm ("options->transformation, with-graft"): Compare dependencies by package name or derivation file name. * doc/guix.texi (Defining Packages): Adjust accordingly. --- doc/guix.texi | 13 +++++----- guix/packages.scm | 55 ++++++++++++++++++++++++++--------------- tests/guix-build.sh | 11 +++++++++ tests/packages.scm | 66 ++++++++++++++++++++++++++++++++++++++++++++++--- tests/scripts-build.scm | 12 ++++++--- 5 files changed, 125 insertions(+), 32 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 054449d8d6..e72e1ec130 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6272,12 +6272,13 @@ This is exactly what the @option{--with-input} command-line option does The following variant of @code{package-input-rewriting} can match packages to be replaced by name rather than by identity. -@deffn {Scheme Procedure} package-input-rewriting/spec @var{replacements} -Return a procedure that, given a package, applies the given @var{replacements} to -all the package graph (excluding implicit inputs). @var{replacements} is a list of -spec/procedures pair; each spec is a package specification such as @code{"gcc"} or -@code{"guile@@2"}, and each procedure takes a matching package and returns a -replacement for that package. +@deffn {Scheme Procedure} package-input-rewriting/spec @var{replacements} [#:deep? #t] +Return a procedure that, given a package, applies the given +@var{replacements} to all the package graph, including implicit inputs +unless @var{deep?} is false. @var{replacements} is a list of +spec/procedures pair; each spec is a package specification such as +@code{"gcc"} or @code{"guile@@2"}, and each procedure takes a matching +package and returns a replacement for that package. @end deffn The example above could be rewritten this way: diff --git a/guix/packages.scm b/guix/packages.scm index 171fd048ef..f696945e30 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -422,6 +422,16 @@ name of its URI." package) 16))))) +(define-syntax-rule (package/inherit p overrides ...) + "Like (package (inherit P) OVERRIDES ...), except that the same +transformation is done to the package replacement, if any. P must be a bare +identifier, and will be bound to either P or its replacement when evaluating +OVERRIDES." + (let loop ((p p)) + (package (inherit p) + overrides ... + (replacement (and=> (package-replacement p) loop))))) + (define (package-upstream-name package) "Return the upstream name of PACKAGE, which could be different from the name it has in Guix." @@ -1051,12 +1061,12 @@ package and returns its new name after rewrite." (package-mapping rewrite (cut assq <> replacements))) -(define (package-input-rewriting/spec replacements) +(define* (package-input-rewriting/spec replacements #:key (deep? #t)) "Return a procedure that, given a package, applies the given REPLACEMENTS to -all the package graph (excluding implicit inputs). REPLACEMENTS is a list of -spec/procedures pair; each spec is a package specification such as \"gcc\" or -\"guile@2\", and each procedure takes a matching package and returns a -replacement for that package." +all the package graph, including implicit inputs unless DEEP? is false. +REPLACEMENTS is a list of spec/procedures pair; each spec is a package +specification such as \"gcc\" or \"guile@2\", and each procedure takes a +matching package and returns a replacement for that package." (define table (fold (lambda (replacement table) (match replacement @@ -1081,22 +1091,27 @@ replacement for that package." (package-name package) table)) - (define (rewrite package) - (match (find-replacement package) - (#f package) - (proc (proc package)))) - - (package-mapping rewrite find-replacement)) + (define replacement-property + (gensym " package-replacement")) -(define-syntax-rule (package/inherit p overrides ...) - "Like (package (inherit P) OVERRIDES ...), except that the same -transformation is done to the package replacement, if any. P must be a bare -identifier, and will be bound to either P or its replacement when evaluating -OVERRIDES." - (let loop ((p p)) - (package (inherit p) - overrides ... - (replacement (and=> (package-replacement p) loop))))) + (define (rewrite p) + (if (assq-ref (package-properties p) replacement-property) + p + (match (find-replacement p) + (#f p) + (proc + (let ((new (proc p))) + ;; Mark NEW as already processed. + (package/inherit new + (properties `((,replacement-property . #t) + ,@(package-properties new))))))))) + + (define (cut? p) + (or (assq-ref (package-properties p) replacement-property) + (find-replacement p))) + + (package-mapping rewrite cut? + #:deep? deep?)) ;;; diff --git a/tests/guix-build.sh b/tests/guix-build.sh index 6c08857358..ec2f736ccb 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -259,6 +259,17 @@ drv1=`guix build guile -d` drv2=`guix build guile --with-input=gimp=ruby -d` test "$drv1" = "$drv2" +# See . +drv1=`guix build glib -d` +drv2=`guix build glib -d --with-input=libreoffice=inkscape` +test "$drv1" = "$drv2" + +# Rewriting implicit inputs. +drv1=`guix build hello -d` +drv2=`guix build hello -d --with-input=gcc=gcc-toolchain` +test "$drv1" != "$drv2" +guix gc -R "$drv2" | grep `guix build -d gcc-toolchain` + if guix build guile --with-input=libunistring=something-really-silly then false; else true; fi diff --git a/tests/packages.scm b/tests/packages.scm index f33332a461..6fa4ad2f1b 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -38,6 +38,7 @@ #:use-module (guix build-system) #:use-module (guix build-system trivial) #:use-module (guix build-system gnu) + #:use-module (guix build-system python) #:use-module (guix memoization) #:use-module (guix profiles) #:use-module (guix scripts package) @@ -45,6 +46,7 @@ #:use-module (gnu packages base) #:use-module (gnu packages guile) #:use-module (gnu packages bootstrap) + #:use-module (gnu packages python) #:use-module (gnu packages version-control) #:use-module (gnu packages xml) #:use-module (srfi srfi-1) @@ -1262,7 +1264,8 @@ ("baz" ,dep))))) (rewrite (package-input-rewriting/spec `(("coreutils" . ,(const sed)) - ("grep" . ,(const findutils))))) + ("grep" . ,(const findutils))) + #:deep? #f)) (p1 (rewrite p0)) (p2 (rewrite p0))) (and (not (eq? p1 p0)) @@ -1279,7 +1282,11 @@ (match (package-native-inputs dep3) ((("x" dep)) (string=? (package-full-name dep) - (package-full-name findutils)))))))))) + (package-full-name findutils))))))) + + ;; Make sure implicit inputs were left unchanged. + (equal? (drop (bag-direct-inputs (package->bag p1)) 3) + (drop (bag-direct-inputs (package->bag p0)) 3))))) (test-assert "package-input-rewriting/spec, partial match" (let* ((dep (dummy-package "chbouib" @@ -1290,7 +1297,8 @@ ("bar" ,dep))))) (rewrite (package-input-rewriting/spec `(("chbouib@123" . ,(const sed)) ;not matched - ("grep" . ,(const findutils))))) + ("grep" . ,(const findutils))) + #:deep? #f)) (p1 (rewrite p0))) (and (not (eq? p1 p0)) (string=? "example" (package-name p1)) @@ -1304,6 +1312,58 @@ (string=? (package-full-name dep) (package-full-name findutils)))))))))) +(test-assert "package-input-rewriting/spec, deep" + (let* ((dep (dummy-package "chbouib")) + (p0 (dummy-package "example" + (build-system gnu-build-system) + (inputs `(("dep" ,dep))))) + (rewrite (package-input-rewriting/spec + `(("tar" . ,(const sed)) + ("gzip" . ,(const findutils))))) + (p1 (rewrite p0)) + (p2 (rewrite p0))) + (and (not (eq? p1 p0)) + (eq? p1 p2) ;memoization + (string=? "example" (package-name p1)) + (match (package-inputs p1) + ((("dep" dep1)) + (and (string=? (package-full-name dep1) + (package-full-name dep)) + (eq? dep1 (rewrite dep))))) ;memoization + + ;; Make sure implicit inputs were replaced. + (match (bag-direct-inputs (package->bag p1)) + ((("dep" dep1) ("tar" tar) ("gzip" gzip) _ ...) + (and (eq? dep1 (rewrite dep)) + (string=? (package-full-name tar) + (package-full-name sed)) + (string=? (package-full-name gzip) + (package-full-name findutils)))))))) + +(test-assert "package-input-rewriting/spec, no duplicates" + ;; Ensure that deep input rewriting does not forget implicit inputs. Doing + ;; so could lead to duplicates in a package's inputs: in the example below, + ;; P0's transitive inputs would contain one rewritten "python" and one + ;; original "python". These two "python" packages are thus not 'eq?' but + ;; they lower to the same derivation. See , + ;; which can be reproduced by passing #:deep? #f. + (let* ((dep0 (dummy-package "dep0" + (build-system trivial-build-system) + (propagated-inputs `(("python" ,python))))) + (p0 (dummy-package "chbouib" + (build-system python-build-system) + (arguments `(#:python ,python)) + (inputs `(("dep0" ,dep0))))) + (rewrite (package-input-rewriting/spec '() #:deep? #t)) + (p1 (rewrite p0)) + (bag1 (package->bag p1)) + (pythons (filter-map (match-lambda + (("python" python) python) + (_ #f)) + (bag-transitive-inputs bag1)))) + (match (delete-duplicates pythons eq?) + ((p) (eq? p (rewrite python)))))) + (test-equal "package-patched-vulnerabilities" '(("CVE-2015-1234") ("CVE-2016-1234" "CVE-2018-4567") diff --git a/tests/scripts-build.scm b/tests/scripts-build.scm index 12114fc8f5..5f91360953 100644 --- a/tests/scripts-build.scm +++ b/tests/scripts-build.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017, 2019 Ludovic Courtès +;;; Copyright © 2016, 2017, 2019, 2020 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,6 +19,7 @@ (define-module (test-scripts-build) #:use-module (guix tests) #:use-module (guix store) + #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix git-download) #:use-module (guix scripts build) @@ -163,11 +164,16 @@ ((("foo" dep1) ("bar" dep2)) (and (string=? (package-full-name dep1) (package-full-name grep)) - (eq? (package-replacement dep1) findutils) + (string=? (package-full-name (package-replacement dep1)) + (package-full-name findutils)) (string=? (package-name dep2) "chbouib") (match (package-native-inputs dep2) ((("x" dep)) - (eq? (package-replacement dep) findutils))))))))))) + (with-store store + (string=? (derivation-file-name + (package-derivation store findutils)) + (derivation-file-name + (package-derivation store dep)))))))))))))) (test-equal "options->transformation, with-branch" (git-checkout (url "https://example.org") -- cgit v1.2.3 From b3fc03ee266a5f6d810d780582d458e561efccf3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 23 Sep 2020 14:40:15 +0200 Subject: packages: 'package-mapping' correctly recurses into 'replacement'. Previously, something like: guix build glib --with-graft=glibc=glibc@2.29 would produce a result showing that rewriting rules were not applied to libx11@1.6.A (a replacement). * guix/packages.scm (package-mapping): Call REPLACE instead of PROC to 'replacement'. * tests/packages.scm ("package-input-rewriting/spec, graft"): New test. --- guix/packages.scm | 2 +- tests/packages.scm | 27 +++++++++++++++++++++++++++ 2 files changed, 28 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/guix/packages.scm b/guix/packages.scm index f696945e30..0d0d7492b6 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -1037,7 +1037,7 @@ applied to implicit inputs as well." (inputs (map rewrite (package-inputs p))) (native-inputs (map rewrite (package-native-inputs p))) (propagated-inputs (map rewrite (package-propagated-inputs p))) - (replacement (and=> (package-replacement p) proc)) + (replacement (and=> (package-replacement p) replace)) (properties `((,mapping-property . #t) ,@(package-properties p)))))))) diff --git a/tests/packages.scm b/tests/packages.scm index 6fa4ad2f1b..e31dea6f72 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -1364,6 +1364,33 @@ (match (delete-duplicates pythons eq?) ((p) (eq? p (rewrite python)))))) +(test-equal "package-input-rewriting/spec, graft" + (derivation-file-name (package-derivation %store sed)) + + ;; Make sure replacements are rewritten. + (let* ((dep0 (dummy-package "dep" + (version "1") + (build-system trivial-build-system) + (inputs `(("coreutils" ,coreutils))))) + (dep1 (dummy-package "dep" + (version "0") + (build-system trivial-build-system) + (replacement dep0))) + (p0 (dummy-package "p" + (build-system trivial-build-system) + (inputs `(("dep" ,dep1))))) + (rewrite (package-input-rewriting/spec + `(("coreutils" . ,(const sed))))) + (p1 (rewrite p0))) + (match (package-inputs p1) + ((("dep" dep)) + (match (package-inputs (package-replacement dep)) + ((("coreutils" coreutils)) + ;; COREUTILS is not 'eq?' to SED, so the most reliable way to check + ;; for equality is to lower to a derivation. + (derivation-file-name + (package-derivation %store coreutils)))))))) + (test-equal "package-patched-vulnerabilities" '(("CVE-2015-1234") ("CVE-2016-1234" "CVE-2018-4567") -- cgit v1.2.3 From 8819551c8d2a12cd4e84e09b51e434d05a012c9d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 23 Sep 2020 14:56:38 +0200 Subject: packages: 'package-input-rewriting' has a #:deep? parameter. * guix/packages.scm (package-input-rewriting): Add #:deep? and pass it to 'package-mapping'. [replacement-property]: New variable. [rewrite]: Check it. [cut?]: New procedure. * tests/packages.scm ("package-input-rewriting"): Pass #:deep? #f and ensure implicit inputs were not rewritten. Avoid 'eq?' comparisons. ("package-input-rewriting, deep"): New test. * gnu/packages/guile.scm (package-for-guile-2.0, package-for-guile-3.0): Pass #:deep? #f. --- doc/guix.texi | 10 +++++----- gnu/packages/guile.scm | 6 ++++-- guix/packages.scm | 35 +++++++++++++++++++++++++---------- tests/packages.scm | 20 ++++++++++++++++++-- 4 files changed, 52 insertions(+), 19 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index e72e1ec130..0805e2d508 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6238,12 +6238,12 @@ transformation is @dfn{input rewriting}, whereby the dependency tree of a package is rewritten by replacing specific inputs by others: @deffn {Scheme Procedure} package-input-rewriting @var{replacements} @ - [@var{rewrite-name}] + [@var{rewrite-name}] [#:deep? #t] Return a procedure that, when passed a package, replaces its direct and -indirect dependencies (but not its implicit inputs) according to -@var{replacements}. @var{replacements} is a list of package pairs; the -first element of each pair is the package to replace, and the second one -is the replacement. +indirect dependencies, including implicit inputs when @var{deep?} is +true, according to @var{replacements}. @var{replacements} is a list of +package pairs; the first element of each pair is the package to replace, +and the second one is the replacement. Optionally, @var{rewrite-name} is a one-argument procedure that takes the name of a package and returns its new name after rewrite. diff --git a/gnu/packages/guile.scm b/gnu/packages/guile.scm index c59daeebe2..280053bf06 100644 --- a/gnu/packages/guile.scm +++ b/gnu/packages/guile.scm @@ -420,11 +420,13 @@ GNU@tie{}Guile. Use the @code{(ice-9 readline)} module and call its ;; A procedure that rewrites the dependency tree of the given package to use ;; GUILE-2.0 instead of GUILE-3.0. (package-input-rewriting `((,guile-3.0 . ,guile-2.0)) - (guile-variant-package-name "guile2.0"))) + (guile-variant-package-name "guile2.0") + #:deep? #f)) (define package-for-guile-2.2 (package-input-rewriting `((,guile-3.0 . ,guile-2.2)) - (guile-variant-package-name "guile2.2"))) + (guile-variant-package-name "guile2.2") + #:deep? #f)) (define-syntax define-deprecated-guile3.0-package (lambda (s) diff --git a/guix/packages.scm b/guix/packages.scm index 0d0d7492b6..4f2bb432be 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -1044,22 +1044,37 @@ applied to implicit inputs as well." replace) (define* (package-input-rewriting replacements - #:optional (rewrite-name identity)) + #:optional (rewrite-name identity) + #:key (deep? #t)) "Return a procedure that, when passed a package, replaces its direct and -indirect dependencies (but not its implicit inputs) according to REPLACEMENTS. -REPLACEMENTS is a list of package pairs; the first element of each pair is the -package to replace, and the second one is the replacement. +indirect dependencies, including implicit inputs when DEEP? is true, according +to REPLACEMENTS. REPLACEMENTS is a list of package pairs; the first element +of each pair is the package to replace, and the second one is the replacement. Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a package and returns its new name after rewrite." + (define replacement-property + ;; Property to tag right-hand sides in REPLACEMENTS. + (gensym " package-replacement")) + (define (rewrite p) - (match (assq-ref replacements p) - (#f (package - (inherit p) - (name (rewrite-name (package-name p))))) - (new new))) + (if (assq-ref (package-properties p) replacement-property) + p + (match (assq-ref replacements p) + (#f (package/inherit p + (name (rewrite-name (package-name p))))) + (new (if deep? + (package/inherit new + (properties `((,replacement-property . #t) + ,@(package-properties new)))) + new))))) - (package-mapping rewrite (cut assq <> replacements))) + (define (cut? p) + (or (assq-ref (package-properties p) replacement-property) + (assq-ref replacements p))) + + (package-mapping rewrite cut? + #:deep? deep?)) (define* (package-input-rewriting/spec replacements #:key (deep? #t)) "Return a procedure that, given a package, applies the given REPLACEMENTS to diff --git a/tests/packages.scm b/tests/packages.scm index e31dea6f72..af8941c2e2 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -1239,7 +1239,8 @@ ("baz" ,dep))))) (rewrite (package-input-rewriting `((,coreutils . ,sed) (,grep . ,findutils)) - (cut string-append "r-" <>))) + (cut string-append "r-" <>) + #:deep? #f)) (p1 (rewrite p0)) (p2 (rewrite p0))) (and (not (eq? p1 p0)) @@ -1253,7 +1254,22 @@ (eq? dep3 (rewrite dep)) ;memoization (match (package-native-inputs dep3) ((("x" dep)) - (eq? dep findutils))))))))) + (eq? dep findutils)))))) + + ;; Make sure implicit inputs were left unchanged. + (equal? (drop (bag-direct-inputs (package->bag p1)) 3) + (drop (bag-direct-inputs (package->bag p0)) 3))))) + +(test-eq "package-input-rewriting, deep" + (derivation-file-name (package-derivation %store sed)) + (let* ((p0 (dummy-package "chbouib" + (build-system python-build-system) + (arguments `(#:python ,python)))) + (rewrite (package-input-rewriting `((,python . ,sed)))) + (p1 (rewrite p0))) + (match (bag-direct-inputs (package->bag p1)) + ((("python" python) _ ...) + (derivation-file-name (package-derivation %store python)))))) (test-assert "package-input-rewriting/spec" (let* ((dep (dummy-package "chbouib" -- cgit v1.2.3 From d8934360d2453a403b5433e71d09188e4ed23b57 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Fri, 25 Sep 2020 11:00:11 -0500 Subject: tests: Simplify shell exit status negation; * tests/guix-archive.sh, tests/guix-build-branch.sh, tests/guix-build.sh, tests/guix-daemon.sh, tests/guix-download.sh, tests/guix-environment.sh, tests/guix-gc.sh, tests/guix-git-authenticate.sh, tests/guix-graph.sh, tests/guix-hash.sh, tests/guix-lint.sh, tests/guix-pack-relocatable.sh, tests/guix-pack.sh, tests/guix-package-aliases.sh, tests/guix-package-net.sh, tests/guix-package.sh: Use the shell '!' keyword to negate command exit status in place of 'if ...; then false; else true; fi' --- tests/guix-archive.sh | 9 +++------ tests/guix-build-branch.sh | 3 +-- tests/guix-build.sh | 22 ++++++++------------- tests/guix-daemon.sh | 2 +- tests/guix-download.sh | 12 ++++------- tests/guix-environment.sh | 8 +++----- tests/guix-gc.sh | 13 +++++------- tests/guix-git-authenticate.sh | 5 ++--- tests/guix-graph.sh | 7 +++---- tests/guix-hash.sh | 12 ++++------- tests/guix-lint.sh | 18 ++++++----------- tests/guix-pack-relocatable.sh | 3 +-- tests/guix-pack.sh | 3 +-- tests/guix-package-aliases.sh | 14 +++++-------- tests/guix-package-net.sh | 9 +++------ tests/guix-package.sh | 45 ++++++++++++++++-------------------------- 16 files changed, 67 insertions(+), 118 deletions(-) (limited to 'tests') diff --git a/tests/guix-archive.sh b/tests/guix-archive.sh index 4c5eea05cf..e796c62f9a 100644 --- a/tests/guix-archive.sh +++ b/tests/guix-archive.sh @@ -44,8 +44,7 @@ cmp "$archive" "$archive_alt" # Check the exit value upon import. guix archive --import < "$archive" -if guix archive something-that-does-not-exist -then false; else true; fi +! guix archive something-that-does-not-exist # This one must not be listed as missing. guix build guile-bootstrap > "$archive" @@ -62,8 +61,7 @@ cmp "$archive" "$archive_alt" # This is not a valid store file name, so an error. echo something invalid > "$archive" -if guix archive --missing < "$archive" -then false; else true; fi +! guix archive --missing < "$archive" # Check '--extract'. guile -c "(use-modules (guix serialization)) @@ -79,5 +77,4 @@ guix archive -t < "$archive" | grep "^D /share/guile" guix archive -t < "$archive" | grep "^x /bin/guile" guix archive -t < "$archive" | grep "^r /share/guile.*/boot-9\.scm" -if echo foo | guix archive --authorize -then false; else true; fi +! echo foo | guix archive --authorize diff --git a/tests/guix-build-branch.sh b/tests/guix-build-branch.sh index c5b07e07c6..79aa06a58f 100644 --- a/tests/guix-build-branch.sh +++ b/tests/guix-build-branch.sh @@ -58,5 +58,4 @@ guix gc -R "$v0_1_0_drv" | grep guile-gcrypt-8fe64e8 # this is the tag ID test "$v0_1_0_drv" != "$latest_drv" test "$v0_1_0_drv" != "$orig_drv" -if guix build guix --with-commit=guile-gcrypt=000 -d -then false; else true; fi +! guix build guix --with-commit=guile-gcrypt=000 -d diff --git a/tests/guix-build.sh b/tests/guix-build.sh index ec2f736ccb..6dbb53206e 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -24,8 +24,7 @@ guix build --version # Should fail. -if guix build -e +; -then false; else true; fi +! guix build -e + # Source-less packages are accepted; they just return nothing. guix build -e '(@ (gnu packages bootstrap) %bootstrap-glibc)' -S @@ -178,7 +177,7 @@ cat > "$module_dir/foo.scm" < "$module_dir/err" || true grep "unbound" "$module_dir/err" # actual error grep "forget.*(gnu packages base)" "$module_dir/err" # hint @@ -222,7 +221,7 @@ 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 +! guix build hello-0.0.1 -n # Keep a symlink to the result, registered as a root. result="t-result-$$" @@ -231,8 +230,7 @@ guix build -r "$result" \ test -x "$result/bin/guile" # Should fail, because $result already exists. -if guix build -r "$result" -e '(@@ (gnu packages bootstrap) %bootstrap-guile)' -then false; else true; fi +! guix build -r "$result" -e '(@@ (gnu packages bootstrap) %bootstrap-guile)' rm -f "$result" @@ -270,8 +268,7 @@ drv2=`guix build hello -d --with-input=gcc=gcc-toolchain` test "$drv1" != "$drv2" guix gc -R "$drv2" | grep `guix build -d gcc-toolchain` -if guix build guile --with-input=libunistring=something-really-silly -then false; else true; fi +! guix build guile --with-input=libunistring=something-really-silly # Deprecated/superseded packages. test "`guix build superseded -d`" = "`guix build bar -d`" @@ -279,10 +276,8 @@ test "`guix build superseded -d`" = "`guix build bar -d`" # Parsing package names and versions. guix build -n time # PASS guix build -n time@1.9 # PASS, version found -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 +! guix build -n time@3.2 # FAIL, version not found +! guix build -n something-that-will-never-exist # FAIL # Invoking a monadic procedure. guix build -e "(begin @@ -354,5 +349,4 @@ export GUIX_BUILD_OPTIONS guix build emacs GUIX_BUILD_OPTIONS="--something-completely-crazy" -if guix build emacs; -then false; else true; fi +! guix build emacs diff --git a/tests/guix-daemon.sh b/tests/guix-daemon.sh index b58500966b..330ad68835 100644 --- a/tests/guix-daemon.sh +++ b/tests/guix-daemon.sh @@ -224,7 +224,7 @@ daemon_pid=$! GUIX_DAEMON_SOCKET="guix://$tcp_socket" export GUIX_DAEMON_SOCKET -if guix gc; then false; else true; fi +! guix gc unset GUIX_DAEMON_SOCKET kill "$daemon_pid" diff --git a/tests/guix-download.sh b/tests/guix-download.sh index 30f55fbe2b..5475d43e60 100644 --- a/tests/guix-download.sh +++ b/tests/guix-download.sh @@ -23,14 +23,11 @@ guix download --version # Make sure it fails here. -if guix download http://does.not/exist -then false; else true; fi +! guix download http://does.not/exist -if guix download unknown://some/where; -then false; else true; fi +! guix download unknown://some/where; -if guix download /does-not-exist -then false; else true; fi +! guix download /does-not-exist # This one should succeed. guix download "file://$abs_top_srcdir/README" @@ -46,5 +43,4 @@ GUIX_DAEMON_SOCKET="/nowhere" guix download -o "$output" \ cmp "$output" "$abs_top_srcdir/README" # This one should fail. -if guix download "file:///does-not-exist" "file://$abs_top_srcdir/README" -then false; else true; fi +! guix download "file:///does-not-exist" "file://$abs_top_srcdir/README" diff --git a/tests/guix-environment.sh b/tests/guix-environment.sh index 2faf38df06..f8be48f0c0 100644 --- a/tests/guix-environment.sh +++ b/tests/guix-environment.sh @@ -60,7 +60,7 @@ guix environment --bootstrap --ad-hoc guile-bootstrap --pure \ grep '^PATH=' "$tmpdir/a" grep '^GUIX_TEST_ABC=' "$tmpdir/a" grep '^GUIX_TEST_DEF=' "$tmpdir/a" -if grep '^GUIX_TEST_XYZ=' "$tmpdir/a"; then false; else true; fi +! grep '^GUIX_TEST_XYZ=' "$tmpdir/a" # Make sure the exit value is preserved. if guix environment --bootstrap --ad-hoc guile-bootstrap --pure \ @@ -194,8 +194,7 @@ then done # 'make-boot0' itself must not be listed. - if guix gc --references "$profile" | grep make-boot0 - then false; else true; fi + ! guix gc --references "$profile" | grep make-boot0 # Make sure that the shell spawned with '--exec' sees the same environment # as returned by '--search-paths'. @@ -212,8 +211,7 @@ then test "x$make_boot0_debug" != "x" # Make sure the "debug" output is not listed. - if guix gc --references "$profile" | grep "$make_boot0_debug" - then false; else true; fi + ! guix gc --references "$profile" | grep "$make_boot0_debug" # Compute the build environment for the initial GNU Make, but add in the # bootstrap Guile as an ad-hoc addition. diff --git a/tests/guix-gc.sh b/tests/guix-gc.sh index 8284287730..f40619876d 100644 --- a/tests/guix-gc.sh +++ b/tests/guix-gc.sh @@ -36,11 +36,11 @@ unset out # For some operations, passing extra arguments is an error. for option in "" "-C 500M" "--verify" "--optimize" "--list-roots" do - if guix gc $option whatever; then false; else true; fi + ! guix gc $option whatever done # This should fail. -if guix gc --verify=foo; then false; else true; fi +! guix gc --verify=foo # Check the references of a .drv. drv="`guix build guile-bootstrap -d`" @@ -51,8 +51,7 @@ guix gc --references "$drv" | grep -e -bash guix gc --references "$out" guix gc --references "$out/bin/guile" -if guix gc --references /dev/null; -then false; else true; fi +! guix gc --references /dev/null; # Check derivers. guix gc --derivers "$out" | grep "$drv" @@ -72,8 +71,7 @@ test -f "$drv" && test -L guix-gc-root guix gc --list-roots | grep "$PWD/guix-gc-root" guix gc --list-live | grep "$drv" -if guix gc --delete "$drv"; -then false; else true; fi +! guix gc --delete "$drv"; rm guix-gc-root guix gc --list-dead | grep "$drv" @@ -84,8 +82,7 @@ guix gc --delete "$drv" guix gc -C 1KiB # Check trivial error cases. -if guix gc --delete /dev/null; -then false; else true; fi +! guix gc --delete /dev/null; # Bug #19757 out="`guix build guile-bootstrap`" diff --git a/tests/guix-git-authenticate.sh b/tests/guix-git-authenticate.sh index 1c76e240b5..8ebbea398b 100644 --- a/tests/guix-git-authenticate.sh +++ b/tests/guix-git-authenticate.sh @@ -46,9 +46,8 @@ v1_0_0_signer="3CE4 6455 8A84 FDC6 9DB4 0CFB 090B 1199 3D9A EBB5" # civodul v1_0_1_commit="d68de958b60426798ed62797ff7c96c327a672ac" # This should fail because these commits lack '.guix-authorizations'. -if guix git authenticate "$v1_0_0_commit" "$v1_0_0_signer" \ - --cache-key="$cache_key" --end="$v1_0_1_commit"; -then false; else true; fi +! guix git authenticate "$v1_0_0_commit" "$v1_0_0_signer" \ + --cache-key="$cache_key" --end="$v1_0_1_commit" # This should work thanks to '--historical-authorizations'. guix git authenticate "$v1_0_0_commit" "$v1_0_0_signer" \ diff --git a/tests/guix-graph.sh b/tests/guix-graph.sh index ccb4933c88..666660ab4b 100644 --- a/tests/guix-graph.sh +++ b/tests/guix-graph.sh @@ -60,7 +60,7 @@ guix graph -t references guile-bootstrap | grep guile-bootstrap guix graph -e '(@ (gnu packages bootstrap) %bootstrap-guile)' \ | grep guile-bootstrap -if guix graph -e +; then false; else true; fi +! guix graph -e + # Try passing store file names. @@ -77,14 +77,13 @@ cmp "$tmpfile1" "$tmpfile2" # Try package transformation options. guix graph git | grep 'label = "openssl' guix graph git --with-input=openssl=libressl | grep 'label = "libressl' -if guix graph git --with-input=openssl=libressl | grep 'label = "openssl' -then false; else true; fi +! guix graph git --with-input=openssl=libressl | grep 'label = "openssl' # Try --load-path guix graph -L $module_dir dummy | grep 'label = "dummy' # Displaying shortest paths (or lack thereof). -if guix graph --path emacs vim; then false; else true; fi +! guix graph --path emacs vim path="\ emacs diff --git a/tests/guix-hash.sh b/tests/guix-hash.sh index 3538b9aeda..346355539f 100644 --- a/tests/guix-hash.sh +++ b/tests/guix-hash.sh @@ -34,8 +34,7 @@ test `guix hash -f base32 /dev/null` = 4oymiquy7qobjgx36tejs35zeqt24qpemsnzgtfes test `guix hash -H sha512 -f hex /dev/null` = cf83e1357eefb8bdf1542850d66d8007d620e4050b5715dc83f4a921d36ce9ce47d0d13c5d85f2b0ff8318d2877eec2f63b931bd47417a81a538327af927da3e test `guix hash -H sha1 -f base64 /dev/null` = "2jmj7l5rSw0yVb/vlWAYkK/YBwk=" -if guix hash -H abcd1234 /dev/null; -then false; else true; fi +! guix hash -H abcd1234 /dev/null mkdir "$tmpdir" echo -n executable > "$tmpdir/exe" @@ -46,13 +45,11 @@ mkdir "$tmpdir/subdir" test `guix hash -r "$tmpdir"` = 10k1lw41wyrjf9mxydi0is5nkpynlsvgslinics4ppir13g7d74p # Without '-r', this should fail. -if guix hash "$tmpdir" -then false; else true; fi +! guix hash "$tmpdir" # This should fail because /dev/null is a character device, which # the archive format doesn't support. -if guix hash -r /dev/null -then false; else true; fi +! guix hash -r /dev/null # Adding a .git directory mkdir "$tmpdir/.git" @@ -65,6 +62,5 @@ test `guix hash -r $tmpdir` = 0a50z04zyzf7pidwxv0nwbj82pgzbrhdy9562kncnvkcfvb48m test `guix hash -r $tmpdir -x` = 10k1lw41wyrjf9mxydi0is5nkpynlsvgslinics4ppir13g7d74p # Without '-r', this should fail. -if guix hash "$tmpdir" -then false; else true; fi +! guix hash "$tmpdir" diff --git a/tests/guix-lint.sh b/tests/guix-lint.sh index ebe79efb84..fdf548fbf1 100644 --- a/tests/guix-lint.sh +++ b/tests/guix-lint.sh @@ -58,24 +58,19 @@ grep_warning () # 3) the description has a single space following the end-of-sentence period. out=`guix lint -c synopsis,description dummy 2>&1` -if [ `grep_warning "$out"` -ne 3 ] -then false; else true; fi +test `grep_warning "$out"` -eq 3 out=`guix lint -c synopsis dummy 2>&1` -if [ `grep_warning "$out"` -ne 2 ] -then false; else true; fi +test `grep_warning "$out"` -eq 2 out=`guix lint -c description dummy 2>&1` -if [ `grep_warning "$out"` -ne 1 ] -then false; else true; fi +test `grep_warning "$out"` -eq 1 out=`guix lint -c description,synopsis dummy 2>&1` -if [ `grep_warning "$out"` -ne 3 ] -then false; else true; fi +test `grep_warning "$out"` -eq 3 -if guix lint -c synopsis,invalid-checker dummy 2>&1 | \ +guix lint -c synopsis,invalid-checker dummy 2>&1 | \ grep -q 'invalid-checker: invalid checker' -then true; else false; fi # Make sure specifying multiple packages works. guix lint -c inputs-should-be-native dummy dummy@42 dummy @@ -85,8 +80,7 @@ guix lint -c inputs-should-be-native dummy dummy@42 dummy unset GUIX_PACKAGE_PATH out=`guix lint -L $module_dir -c synopsis,description dummy 2>&1` -if [ `grep_warning "$out"` -ne 3 ] -then false; else true; fi +test `grep_warning "$out"` -eq 3 # Make sure specifying multiple packages works. guix lint -L $module_dir -c inputs-should-be-native dummy dummy@42 dummy diff --git a/tests/guix-pack-relocatable.sh b/tests/guix-pack-relocatable.sh index b8d36a02c6..a960ecd209 100644 --- a/tests/guix-pack-relocatable.sh +++ b/tests/guix-pack-relocatable.sh @@ -77,8 +77,7 @@ then grep 'GNU sed' "$test_directory/output" # Check whether the exit code is preserved. - if run_without_store "$test_directory/Bin/sed" --does-not-exist; - then false; else true; fi + ! run_without_store "$test_directory/Bin/sed" --does-not-exist chmod -Rf +w "$test_directory"; rm -rf "$test_directory"/* else diff --git a/tests/guix-pack.sh b/tests/guix-pack.sh index 39b64791e2..0339221ac2 100644 --- a/tests/guix-pack.sh +++ b/tests/guix-pack.sh @@ -45,8 +45,7 @@ guix gc -R "$drv" | grep "`guix build coreutils -d --no-grafts`" drv="`guix pack idutils -d --no-grafts --target=arm-linux-gnueabihf`" guix gc -R "$drv" | \ grep "`guix build idutils --target=arm-linux-gnueabihf -d --no-grafts`" -if guix gc -R "$drv" | grep "`guix build idutils -d --no-grafts`"; -then false; else true; fi +! guix gc -R "$drv" | grep "`guix build idutils -d --no-grafts`" # Build a tarball with no compression. guix pack --compression=none --bootstrap guile-bootstrap diff --git a/tests/guix-package-aliases.sh b/tests/guix-package-aliases.sh index e24bff3a56..e4ddace057 100644 --- a/tests/guix-package-aliases.sh +++ b/tests/guix-package-aliases.sh @@ -36,26 +36,22 @@ guix install --bootstrap guile-bootstrap -p "$profile" test -x "$profile/bin/guile" # Make sure '-r' isn't passed as-is to 'guix package'. -if guix install -r guile-bootstrap -p "$profile" --bootstrap -then false; else true; fi +! guix install -r guile-bootstrap -p "$profile" --bootstrap test -x "$profile/bin/guile" guix upgrade --version guix upgrade -n guix upgrade gui.e -n -if guix upgrade foo bar -n; -then false; else true; fi +! guix upgrade foo bar -n; guix remove --version guix remove --bootstrap guile-bootstrap -p "$profile" ! test -x "$profile/bin/guile" test `guix package -p "$profile" -I | wc -l` -eq 0 -if guix remove -p "$profile" this-is-not-installed --bootstrap -then false; else true; fi +! guix remove -p "$profile" this-is-not-installed --bootstrap -if guix remove -i guile-bootstrap -p "$profile" --bootstrap -then false; else true; fi +! guix remove -i guile-bootstrap -p "$profile" --bootstrap guix search '\' game | grep '^name: gnubg' @@ -64,7 +60,7 @@ guix show guile guix show python@3 | grep "^name: python" # "python@2" exists but is deprecated; make sure it doesn't show up. -if guix show python@2; then false; else true; fi +! guix show python@2 # Specifying multiple packages. output="`guix show sed grep | grep ^name:`" diff --git a/tests/guix-package-net.sh b/tests/guix-package-net.sh index 3876701fa2..6d21c6cff6 100644 --- a/tests/guix-package-net.sh +++ b/tests/guix-package-net.sh @@ -95,10 +95,8 @@ test "`guix package -p "$profile" -l | cut -f1 | grep guile | head -n1`" \ = " guile-bootstrap" # Exit with 1 when a generation does not exist. -if guix package -p "$profile" --list-generations=42; -then false; else true; fi -if guix package -p "$profile" --switch-generation=99; -then false; else true; fi +! guix package -p "$profile" --list-generations=42 +! guix package -p "$profile" --switch-generation=99 # Remove a package. guix package --bootstrap -p "$profile" -r "guile-bootstrap" @@ -174,8 +172,7 @@ test -z "`guix package -p "$profile" -l 3`" rm "$profile" guix package --bootstrap -p "$profile" -i guile-bootstrap guix package --bootstrap -p "$profile_alt" -i gcc-bootstrap -if guix package -p "$profile" --search-paths | grep LIBRARY_PATH -then false; fi +! guix package -p "$profile" --search-paths | grep LIBRARY_PATH guix package -p "$profile" -p "$profile_alt" --search-paths \ | grep "LIBRARY_PATH.*$profile/lib.$profile_alt/lib" diff --git a/tests/guix-package.sh b/tests/guix-package.sh index 1f955257be..1a95b8e9a4 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -36,8 +36,7 @@ rm -f "$profile" "$tmpfile" trap 'rm -f "$profile" "$profile.lock" "$profile-"[0-9]* "$tmpfile"; rm -rf "$module_dir" t-home-'"$$" EXIT # Use `-e' with a non-package expression. -if guix package --bootstrap -e +; -then false; else true; fi +! guix package --bootstrap -e + # Install a store item and make sure the version and output in the manifest # are correct. @@ -62,8 +61,7 @@ test -f "$profile/bin/guile" # Collisions are properly flagged (in this case, 'g-wrap' propagates # guile@2.2, which conflicts with guile@2.0.) -if guix package --bootstrap -n -p "$profile" -i g-wrap guile@2.0 -then false; else true; fi +! guix package --bootstrap -n -p "$profile" -i g-wrap guile@2.0 guix package --bootstrap -n -p "$profile" -i g-wrap guile@2.0 \ --allow-collisions @@ -78,8 +76,7 @@ test "`guix package -p "$profile" --search-paths | wc -l`" = 1 # $PATH type -P rm ) # Exit with 1 when a generation does not exist. -if guix package -p "$profile" --delete-generations=42; -then false; else true; fi +! guix package -p "$profile" --delete-generations=42 # Exit with 0 when trying to delete the zeroth generation. guix package -p "$profile" --delete-generations=0 @@ -92,15 +89,12 @@ guix package --bootstrap -i "glibc:debug" -p "$profile" -n # Make sure nonexistent outputs are reported. guix package --bootstrap -i "guile-bootstrap:out" -p "$profile" -n -if guix package --bootstrap -i "guile-bootstrap:does-not-exist" -p "$profile" -n; -then false; else true; fi -if guix package --bootstrap -i "guile-bootstrap:does-not-exist" -p "$profile"; -then false; else true; fi +! guix package --bootstrap -i "guile-bootstrap:does-not-exist" -p "$profile" -n +! guix package --bootstrap -i "guile-bootstrap:does-not-exist" -p "$profile" # Make sure we get an error when trying to remove something that's not # installed. -if guix package --bootstrap -r something-not-installed -p "$profile"; -then false; else true; fi +! guix package --bootstrap -r something-not-installed -p "$profile" # Check whether `--list-available' returns something sensible. guix package -p "$profile" -A 'gui.*e' | grep guile @@ -112,8 +106,8 @@ guix package --show=guile | grep "^name: guile" guix package --show=texlive # Fail for non-existent packages or package/version pairs. -if guix package --show=does-not-exist; then false; else true; fi -if guix package --show=emacs@42; then false; else true; fi +! guix package --show=does-not-exist +! guix package --show=emacs@42 # Search. LC_MESSAGES=C @@ -157,22 +151,19 @@ guix package --search="" > /dev/null # There's no generation older than 12 months, so the following command should # have no effect. generation="`readlink_base "$profile"`" -if guix package -p "$profile" --delete-generations=12m; -then false; else true; fi +! guix package -p "$profile" --delete-generations=12m test "`readlink_base "$profile"`" = "$generation" # The following command should not delete the current generation, even though # it matches the given pattern (see .) And since # there's nothing else to delete, it should just fail. guix package --list-generations -p "$profile" -if guix package --bootstrap -p "$profile" --delete-generations=1.. -then false; else true; fi +! guix package --bootstrap -p "$profile" --delete-generations=1.. test "`readlink_base "$profile"`" = "$generation" # Make sure $profile is a GC root at this point. real_profile="`readlink -f "$profile"`" -if guix gc -d "$real_profile" -then false; else true; fi +! guix gc -d "$real_profile" test -d "$real_profile" # Now, let's remove all the symlinks to $real_profile, and make sure @@ -238,16 +229,15 @@ done # Check whether '-p ~/.guix-profile' makes any difference. # See . -if test -e "$HOME/.guix-profile-0-link"; then false; fi -if test -e "$HOME/.guix-profile-1-link"; then false; fi +! test -e "$HOME/.guix-profile-0-link" +! test -e "$HOME/.guix-profile-1-link" guix package --bootstrap -p "$HOME/.guix-profile" -i guile-bootstrap -if test -e "$HOME/.guix-profile-1-link"; then false; fi +! test -e "$HOME/.guix-profile-1-link" guix package --bootstrap --roll-back -p "$HOME/.guix-profile" -if test -e "$HOME/.guix-profile-0-link"; then false; fi +! test -e "$HOME/.guix-profile-0-link" # Extraneous argument. -if guix package install foo-bar; -then false; else true; fi +! guix package install foo-bar # Make sure the "broken pipe" doesn't yield an error. # Note: 'pipefail' is a Bash-specific option. @@ -336,8 +326,7 @@ cat > "$module_dir/package.scm"< Date: Tue, 29 Sep 2020 10:29:23 +0200 Subject: openpgp: Fix argument order of 'fxbit-set?'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/openpgp.scm (fxbit-set?): Change to swap arguments compared to 'bit-set?'. * tests/openpgp.scm (%binary-sample): New test vector. ("port-ascii-armored?, #t"): Add test. ("port-ascii-armored?, #f"): Add another test. Co-authored-by: Ludovic Courtès --- guix/openpgp.scm | 2 +- tests/openpgp.scm | 12 ++++++++++++ 2 files changed, 13 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/guix/openpgp.scm b/guix/openpgp.scm index 33c851255b..153752ee73 100644 --- a/guix/openpgp.scm +++ b/guix/openpgp.scm @@ -110,7 +110,7 @@ (define-alias fx/ /) (define-alias fxdiv quotient) (define-alias fxand logand) -(define-alias fxbit-set? bit-set?) +(define-inlinable (fxbit-set? n index) (bit-set? index n)) (define-alias fxbit-field bit-field) (define-alias bitwise-bit-field bit-field) (define-alias fxarithmetic-shift-left ash) diff --git a/tests/openpgp.scm b/tests/openpgp.scm index 0beab6f88b..c2be26fa49 100644 --- a/tests/openpgp.scm +++ b/tests/openpgp.scm @@ -50,6 +50,12 @@ vBSFjNSiVHsuAA== =AAAA -----END PGP MESSAGE-----\n") +(define %binary-sample + ;; Same message as %radix-64-sample, decoded into bytevector. + (base16-string->bytevector + "c838013b6d96c411efecef17ecefe3ca0004ce8979ea250a897995f979a9\ +0ad9a9a9050a890ac5a9c945a940c1a2fcd2bc14858cd4a2547b2e00")) + (define %civodul-fingerprint "3CE4 6455 8A84 FDC6 9DB4 0CFB 090B 1199 3D9A EBB5") @@ -155,6 +161,12 @@ Pz7oopeN72xgggYUNT37ezqN3MeCqw0= read-radix-64)) list)) +(test-assert "port-ascii-armored?, #t" + (call-with-input-string %radix-64-sample port-ascii-armored?)) + +(test-assert "port-ascii-armored?, #f" + (not (port-ascii-armored? (open-bytevector-input-port %binary-sample)))) + (test-assert "get-openpgp-keyring" (let* ((key (search-path %load-path "tests/civodul.key")) (keyring (get-openpgp-keyring -- cgit v1.2.3 From 313f492657f1d0863c641fa5ee7f5b7028e27c94 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Fri, 31 Jul 2020 16:49:29 +0200 Subject: scripts: system: Add support for image-type. * guix/scripts/system.scm (list-image-types): New procedure, (%options): add "image-type" and "list-image-types" options, remove "file-system-type" option, (show-help): adapt accordingly, (%default-options): also adapt, and set the default "image-type" to "raw", (perform-action): add image-type argument and remove file-system-type argument, (process-action): adapt perform-action call, (system-derivation-for-action): remove base-image argument, add image-type argument, and use it to create the image passed to "system-image". * tests/guix-system.sh: Adapt accordingly and add a test for "--list-image-types" command. * doc/guix.texi (Building the Installation Image, Invoking guix system): Adapt accordingly. Signed-off-by: Mathieu Othacehe --- Makefile.am | 5 ++-- doc/guix.texi | 43 ++++++++++++++++-------------- guix/scripts/system.scm | 70 +++++++++++++++++++++++++++++++------------------ tests/guix-system.sh | 9 ++++--- 4 files changed, 75 insertions(+), 52 deletions(-) (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index 8e91e1e558..9c3ff4420f 100644 --- a/Makefile.am +++ b/Makefile.am @@ -833,9 +833,8 @@ release: dist-with-updated-version -v1 --no-grafts --fallback for system in $(GUIX_SYSTEM_SUPPORTED_SYSTEMS) ; do \ image=`$(top_builddir)/pre-inst-env \ - guix system disk-image \ - --file-system-type=iso9660 \ - --label="GUIX_$${system}_$(VERSION)" \ + guix system disk-image -t iso9660 \ + --label="GUIX_$${system}_$(VERSION)" \ --system=$$system --fallback \ gnu/system/install.scm` ; \ if [ ! -f "$$image" ] ; then \ diff --git a/doc/guix.texi b/doc/guix.texi index ff2e582347..e8458ad8d8 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -40,7 +40,7 @@ Copyright @copyright{} 2016, 2017, 2018, 2019, 2020 Julien Lepiller@* Copyright @copyright{} 2016 Alex ter Weele@* Copyright @copyright{} 2016, 2017, 2018, 2019 Christopher Baines@* Copyright @copyright{} 2017, 2018, 2019 Clément Lassieur@* -Copyright @copyright{} 2017, 2018 Mathieu Othacehe@* +Copyright @copyright{} 2017, 2018, 2020 Mathieu Othacehe@* Copyright @copyright{} 2017 Federico Beffa@* Copyright @copyright{} 2017, 2018 Carlo Zancanaro@* Copyright @copyright{} 2017 Thomas Danckaert@* @@ -2568,8 +2568,7 @@ The installation image described above was built using the @command{guix system} command, specifically: @example -guix system disk-image --file-system-type=iso9660 \ - gnu/system/install.scm +guix system disk-image -t iso9660 gnu/system/install.scm @end example Have a look at @file{gnu/system/install.scm} in the source tree, @@ -29375,24 +29374,28 @@ a value. Docker images are built to contain exactly what they need, so the @option{--image-size} option is ignored in the case of @code{docker-image}. -You can specify the root file system type by using the -@option{--file-system-type} option. It defaults to @code{ext4}. When its -value is @code{iso9660}, the @option{--label} option can be used to specify -a volume ID with @code{disk-image}. +The @code{disk-image} command can produce various image types. The +image type can be selected using the @command{--image-type} option. It +defaults to @code{raw}. When its value is @code{iso9660}, the +@option{--label} option can be used to specify a volume ID with +@code{disk-image}. -When using @code{vm-image}, the returned image is in qcow2 format, which -the QEMU emulator can efficiently use. @xref{Running Guix in a VM}, -for more information on how to run the image in a virtual machine. - -When using @code{disk-image}, a raw disk image is produced; it can be -copied as is to a USB stick, for instance. Assuming @code{/dev/sdc} is -the device corresponding to a USB stick, one can copy the image to it -using the following command: +When using the @code{raw} image type, a raw disk image is produced; it +can be copied as is to a USB stick, for instance. Assuming +@code{/dev/sdc} is the device corresponding to a USB stick, one can copy +the image to it using the following command: @example # dd if=$(guix system disk-image my-os.scm) of=/dev/sdc status=progress @end example +The @code{--list-image-types} command lists all the available image +types. + +When using @code{vm-image}, the returned image is in qcow2 format, which +the QEMU emulator can efficiently use. @xref{Running Guix in a VM}, +for more information on how to run the image in a virtual machine. + When using @code{docker-image}, a Docker image is produced. Guix builds the image from scratch, not from a pre-existing Docker base image. As a result, it contains @emph{exactly} what you define in the operating @@ -29494,17 +29497,17 @@ information, one can rebuild the image to make sure it really contains what it pretends to contain; or they could use that to derive a variant of the image. -@item --file-system-type=@var{type} +@item --image-type=@var{type} @itemx -t @var{type} -For the @code{disk-image} action, create a file system of the given -@var{type} on the image. +For the @code{disk-image} action, create an image with given @var{type}. -When this option is omitted, @command{guix system} uses @code{ext4}. +When this option is omitted, @command{guix system} uses the @code{raw} +image type. @cindex ISO-9660 format @cindex CD image format @cindex DVD image format -@option{--file-system-type=iso9660} produces an ISO-9660 image, suitable +@option{--image-type=iso9660} produces an ISO-9660 image, suitable for burning on CDs and DVDs. @item --image-size=@var{size} diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index bd5f84fc5b..7b3eacf2e1 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -666,8 +666,8 @@ checking this by themselves in their 'check' procedure." ;;; Action. ;;; -(define* (system-derivation-for-action os base-image action - #:key image-size file-system-type +(define* (system-derivation-for-action os action + #:key image-size image-type full-boot? container-shared-network? mappings label) "Return as a monadic value the derivation for OS according to ACTION." @@ -690,12 +690,15 @@ checking this by themselves in their 'check' procedure." (* 70 (expt 2 20))) #:mappings mappings)) ((disk-image) - (lower-object - (system-image - (image - (inherit (if label (image-with-label base-image label) base-image)) - (size image-size) - (operating-system os))))) + (let ((base-image (os->image os #:type image-type))) + (lower-object + (system-image + (image + (inherit (if label + (image-with-label base-image label) + base-image)) + (size image-size) + (operating-system os)))))) ((docker-image) (system-docker-image os #:shared-network? container-shared-network?)))) @@ -748,18 +751,19 @@ and TARGET arguments." install-bootloader? dry-run? derivations-only? use-substitutes? bootloader-target target - image-size file-system-type full-boot? label - container-shared-network? + image-size image-type + full-boot? label container-shared-network? (mappings '()) (gc-root #f)) "Perform ACTION for OS. INSTALL-BOOTLOADER? specifies whether to install bootloader; BOOTLOADER-TAGET is the target for the bootloader; TARGET is the target root directory; IMAGE-SIZE is the size of the image to be built, for -the 'vm-image' and 'disk-image' actions. The root file system is created as a -FILE-SYSTEM-TYPE file system. FULL-BOOT? is used for the 'vm' action; it -determines whether to boot directly to the kernel or to the bootloader. -CONTAINER-SHARED-NETWORK? determines if the container will use a separate -network namespace. +the 'vm-image' and 'disk-image' actions. IMAGE-TYPE is the type of image to +be built. + +FULL-BOOT? is used for the 'vm' action; it determines whether to +boot directly to the kernel or to the bootloader. CONTAINER-SHARED-NETWORK? +determines if the container will use a separate network namespace. When DERIVATIONS-ONLY? is true, print the derivation file name(s) without building anything. @@ -799,11 +803,9 @@ static checks." (check-initrd-modules os))) (mlet* %store-monad - ((target* (current-target-system)) - (image -> (find-image file-system-type target*)) - (sys (system-derivation-for-action os image action + ((sys (system-derivation-for-action os action #:label label - #:file-system-type file-system-type + #:image-type image-type #:image-size image-size #:full-boot? full-boot? #:container-shared-network? container-shared-network? @@ -886,6 +888,17 @@ Run 'herd status' to view the list of services on your system.\n")))))) #:node-type (shepherd-service-node-type shepherds) #:reverse-edges? #t))) + +;;; +;;; Images. +;;; + +(define (list-image-types) + "Print the available image types." + (display (G_ "The available image types are:\n")) + (newline) + (format #t "~{ - ~a ~%~}" (map image-type-name (force %image-types)))) + ;;; ;;; Options. @@ -945,9 +958,9 @@ Some ACTIONS support additional ARGS.\n")) apply STRATEGY (one of nothing-special, backtrace, or debug) when an error occurs while reading FILE")) (display (G_ " - --file-system-type=TYPE - for 'disk-image', produce a root file system of TYPE - (one of 'ext4', 'iso9660')")) + --list-image-types list available image types")) + (display (G_ " + -t, --image-type=TYPE for 'disk-image', produce an image of TYPE")) (display (G_ " --image-size=SIZE for 'vm-image', produce an image of SIZE")) (display (G_ " @@ -1008,10 +1021,14 @@ Some ACTIONS support additional ARGS.\n")) (lambda (opt name arg result) (alist-cons 'on-error (string->symbol arg) result))) - (option '(#\t "file-system-type") #t #f + (option '(#\t "image-type") #t #f (lambda (opt name arg result) - (alist-cons 'file-system-type arg + (alist-cons 'image-type (string->symbol arg) result))) + (option '("list-image-types") #f #f + (lambda (opt name arg result) + (list-image-types) + (exit 0))) (option '("image-size") #t #f (lambda (opt name arg result) (alist-cons 'image-size (size->number arg) @@ -1080,7 +1097,7 @@ Some ACTIONS support additional ARGS.\n")) (debug . 0) (verbosity . #f) ;default (validate-reconfigure . ,ensure-forward-reconfigure) - (file-system-type . "ext4") + (image-type . raw) (image-size . guess) (install-bootloader? . #t) (label . #f))) @@ -1177,7 +1194,8 @@ resulting from command-line parsing." (assoc-ref opts 'skip-safety-checks?) #:validate-reconfigure (assoc-ref opts 'validate-reconfigure) - #:file-system-type (assoc-ref opts 'file-system-type) + #:image-type (lookup-image-type-by-name + (assoc-ref opts 'image-type)) #:image-size (assoc-ref opts 'image-size) #:full-boot? (assoc-ref opts 'full-boot?) #:container-shared-network? diff --git a/tests/guix-system.sh b/tests/guix-system.sh index 0e22686a34..667e084fcf 100644 --- a/tests/guix-system.sh +++ b/tests/guix-system.sh @@ -261,8 +261,8 @@ guix system vm "$tmpfile" -d | grep '\.drv$' drv1="`guix system vm "$tmpfile" -d`" drv2="`guix system vm "$tmpfile" -d`" test "$drv1" = "$drv2" -drv1="`guix system disk-image --file-system-type=iso9660 "$tmpfile" -d`" -drv2="`guix system disk-image --file-system-type=iso9660 "$tmpfile" -d`" +drv1="`guix system disk-image -t iso9660 "$tmpfile" -d`" +drv2="`guix system disk-image -t iso9660 "$tmpfile" -d`" test "$drv1" = "$drv2" make_user_config "group-that-does-not-exist" "users" @@ -320,5 +320,8 @@ guix system -n vm gnu/system/examples/vm-image.tmpl guix system -n vm-image gnu/system/examples/vm-image.tmpl # This invocation was taken care of in the loop above: # guix system -n disk-image gnu/system/examples/bare-bones.tmpl -guix system -n disk-image --file-system-type=iso9660 gnu/system/examples/bare-bones.tmpl +guix system -n disk-image -t iso9660 gnu/system/examples/bare-bones.tmpl guix system -n docker-image gnu/system/examples/docker-image.tmpl + +# Verify that at least the raw image type is available. +guix system --list-image-types | grep "raw" -- cgit v1.2.3 From e74818353882f187e5971b5a3a481f17df883dbe Mon Sep 17 00:00:00 2001 From: Jelle Licht Date: Tue, 29 Sep 2020 23:25:13 +0200 Subject: linux-container: Reset jailed root permissions. * gnu/build/linux-container.scm (mount-file-systems): Add 'chmod' call. * tests/containers.scm ("call-with-container, mnt namespace, root permissions"): New test. --- gnu/build/linux-container.scm | 3 ++- tests/containers.scm | 8 ++++++++ 2 files changed, 10 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm index 2d4de788df..4a8bed5a9a 100644 --- a/gnu/build/linux-container.scm +++ b/gnu/build/linux-container.scm @@ -170,7 +170,8 @@ for the process." (pivot-root root put-old) (chdir "/") (umount "real-root" MNT_DETACH) - (rmdir "real-root"))) + (rmdir "real-root") + (chmod "/" #o755))) (define* (initialize-user-namespace pid host-uids #:key (guest-uid 0) (guest-gid 0)) diff --git a/tests/containers.scm b/tests/containers.scm index 7b63e5c108..608902c41a 100644 --- a/tests/containers.scm +++ b/tests/containers.scm @@ -133,6 +133,14 @@ (lambda () (primitive-exit 0))))) +(skip-if-unsupported) +(test-assert "call-with-container, mnt namespace, root permissions" + (zero? + (call-with-container '() + (lambda () + (assert-exit (= #o755 (stat:perms (lstat "/"))))) + #:namespaces '(user mnt)))) + (skip-if-unsupported) (test-assert "container-excursion" (call-with-temporary-directory -- cgit v1.2.3 From ad05537e32173403d034a0d552092f566abd05a5 Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Fri, 2 Oct 2020 00:16:10 +0200 Subject: tests: opam: Factorize tests. * tests/opam.scm: Remove duplicate code. --- tests/opam.scm | 130 +++++++++++++++++++++++++-------------------------------- 1 file changed, 58 insertions(+), 72 deletions(-) (limited to 'tests') diff --git a/tests/opam.scm b/tests/opam.scm index 68b5908e3f..ef61fbb5cc 100644 --- a/tests/opam.scm +++ b/tests/opam.scm @@ -116,81 +116,67 @@ url { ;; Test the opam file parser ;; We fold over some test cases. Each case is a pair of the string to parse and the ;; expected result. -(test-assert "parse-strings" - (fold (lambda (test acc) - (display test) (newline) - (and acc - (let ((result (peg:tree (match-pattern string-pat (car test))))) - (if (equal? result (cdr test)) - #t - (pk 'fail (list (car test) result (cdr test)) #f))))) - #t '(("" . #f) - ("\"hello\"" . (string-pat "hello")) - ("\"hello world\"" . (string-pat "hello world")) - ("\"The dreaded \\\"é\\\"\"" . (string-pat "The dreaded \"é\"")) - ("\"Have some \\\\\\\\ :)\"" . (string-pat "Have some \\\\ :)")) - ("\"今日は\"" . (string-pat "今日は"))))) +(define (test-opam-syntax name pattern test-cases) + (test-assert name + (fold (lambda (test acc) + (display test) (newline) + (match test + ((str . expected) + (and acc + (let ((result (peg:tree (match-pattern pattern str)))) + (if (equal? result expected) + #t + (pk 'fail (list str result expected) #f))))))) + #t test-cases))) -(test-assert "parse-multiline-strings" - (fold (lambda (test acc) - (display test) (newline) - (and acc - (let ((result (peg:tree (match-pattern multiline-string (car test))))) - (if (equal? result (cdr test)) - #t - (pk 'fail (list (car test) result (cdr test)) #f))))) - #t '(("" . #f) - ("\"\"\"hello\"\"\"" . (multiline-string "hello")) - ("\"\"\"hello \"world\"!\"\"\"" . (multiline-string "hello \"world\"!")) - ("\"\"\"hello \"\"world\"\"!\"\"\"" . (multiline-string "hello \"\"world\"\"!"))))) +(test-opam-syntax + "parse-strings" string-pat + '(("" . #f) + ("\"hello\"" . (string-pat "hello")) + ("\"hello world\"" . (string-pat "hello world")) + ("\"The dreaded \\\"é\\\"\"" . (string-pat "The dreaded \"é\"")) + ("\"Have some \\\\\\\\ :)\"" . (string-pat "Have some \\\\ :)")) + ("\"今日は\"" . (string-pat "今日は")))) -(test-assert "parse-lists" - (fold (lambda (test acc) - (and acc - (let ((result (peg:tree (match-pattern list-pat (car test))))) - (if (equal? result (cdr test)) - #t - (pk 'fail (list (car test) result (cdr test)) #f))))) - #t '(("" . #f) - ("[]" . list-pat) - ("[make]" . (list-pat (var "make"))) - ("[\"make\"]" . (list-pat (string-pat "make"))) - ("[\n a\n b\n c]" . (list-pat (var "a") (var "b") (var "c"))) - ("[a b \"c\"]" . (list-pat (var "a") (var "b") (string-pat "c")))))) +(test-opam-syntax + "parse-multiline-strings" multiline-string + '(("" . #f) + ("\"\"\"hello\"\"\"" . (multiline-string "hello")) + ("\"\"\"hello \"world\"!\"\"\"" . (multiline-string "hello \"world\"!")) + ("\"\"\"hello \"\"world\"\"!\"\"\"" . (multiline-string "hello \"\"world\"\"!")))) -(test-assert "parse-dicts" - (fold (lambda (test acc) - (and acc - (let ((result (peg:tree (match-pattern dict (car test))))) - (if (equal? result (cdr test)) - #t - (pk 'fail (list (car test) result (cdr test)) #f))))) - #t '(("" . #f) - ("{}" . dict) - ("{a: \"b\"}" . (dict (record "a" (string-pat "b")))) - ("{a: \"b\"\nc: \"d\"}" . (dict (record "a" (string-pat "b")) (record "c" (string-pat "d"))))))) +(test-opam-syntax + "parse-lists" list-pat + '(("" . #f) + ("[]" . list-pat) + ("[make]" . (list-pat (var "make"))) + ("[\"make\"]" . (list-pat (string-pat "make"))) + ("[\n a\n b\n c]" . (list-pat (var "a") (var "b") (var "c"))) + ("[a b \"c\"]" . (list-pat (var "a") (var "b") (string-pat "c"))))) -(test-assert "parse-conditions" - (fold (lambda (test acc) - (and acc - (let ((result (peg:tree (match-pattern condition (car test))))) - (if (equal? result (cdr test)) - #t - (pk 'fail (list (car test) result (cdr test)) #f))))) - #t '(("" . #f) - ("{}" . #f) - ("{build}" . (condition-var "build")) - ("{>= \"0.2.0\"}" . (condition-greater-or-equal - (condition-string "0.2.0"))) - ("{>= \"0.2.0\" & test}" . (condition-and - (condition-greater-or-equal - (condition-string "0.2.0")) - (condition-var "test"))) - ("{>= \"0.2.0\" | build}" . (condition-or - (condition-greater-or-equal - (condition-string "0.2.0")) - (condition-var "build"))) - ("{ = \"1.0+beta19\" }" . (condition-eq - (condition-string "1.0+beta19")))))) +(test-opam-syntax + "parse-dicts" dict + '(("" . #f) + ("{}" . dict) + ("{a: \"b\"}" . (dict (record "a" (string-pat "b")))) + ("{a: \"b\"\nc: \"d\"}" . (dict (record "a" (string-pat "b")) (record "c" (string-pat "d")))))) + +(test-opam-syntax + "parse-conditions" condition + '(("" . #f) + ("{}" . #f) + ("{build}" . (condition-var "build")) + ("{>= \"0.2.0\"}" . (condition-greater-or-equal + (condition-string "0.2.0"))) + ("{>= \"0.2.0\" & test}" . (condition-and + (condition-greater-or-equal + (condition-string "0.2.0")) + (condition-var "test"))) + ("{>= \"0.2.0\" | build}" . (condition-or + (condition-greater-or-equal + (condition-string "0.2.0")) + (condition-var "build"))) + ("{ = \"1.0+beta19\" }" . (condition-eq + (condition-string "1.0+beta19"))))) (test-end "opam") -- cgit v1.2.3 From 23dc21f05b54ef63daaea9eb301cfddbc4c82ddb Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Fri, 2 Oct 2020 00:28:30 +0200 Subject: tests: opam: Test additional syntax. * tests/opam.scm (test-comment): New test. (test-lists): Add more tests for complex list patterns. --- tests/opam.scm | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/tests/opam.scm b/tests/opam.scm index ef61fbb5cc..ec2a668307 100644 --- a/tests/opam.scm +++ b/tests/opam.scm @@ -152,7 +152,11 @@ url { ("[make]" . (list-pat (var "make"))) ("[\"make\"]" . (list-pat (string-pat "make"))) ("[\n a\n b\n c]" . (list-pat (var "a") (var "b") (var "c"))) - ("[a b \"c\"]" . (list-pat (var "a") (var "b") (string-pat "c"))))) + ("[a b \"c\"]" . (list-pat (var "a") (var "b") (string-pat "c"))) + ;; complex lists + ("[(a & b)]" . (list-pat (choice-pat (group-pat (var "a") (var "b"))))) + ("[(a | b & c)]" . (list-pat (choice-pat (var "a") (group-pat (var "b") (var "c"))))) + ("[a (b | c) d]" . (list-pat (var "a") (choice-pat (var "b") (var "c")) (var "d"))))) (test-opam-syntax "parse-dicts" dict @@ -179,4 +183,9 @@ url { ("{ = \"1.0+beta19\" }" . (condition-eq (condition-string "1.0+beta19"))))) +(test-opam-syntax + "parse-comment" list-pat + '(("" . #f) + ("[#comment\n]" . list-pat))) + (test-end "opam") -- cgit v1.2.3 From f43ffee90882c2d61b46d69728daa7432be297e4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 1 Oct 2020 22:09:58 +0200 Subject: gexp: 'local-file' warns when passed a non-literal relative file name. Fixes . Reported by Vitaliy Shatrov . * guix/gexp.scm (%local-file): Add #:literal? and #:location. Emit a warning when LITERAL? is false and FILE is not absolute. (local-file): In the non-literal case, pass #:location and #:literal?. * po/guix/POTFILES.in: Add guix/gexp.scm. * tests/guix-system.sh: Add test for the warning. --- guix/gexp.scm | 19 +++++++++++++++---- po/guix/POTFILES.in | 1 + tests/guix-system.sh | 14 ++++++++++++++ 3 files changed, 30 insertions(+), 4 deletions(-) (limited to 'tests') diff --git a/guix/gexp.scm b/guix/gexp.scm index 9d3c52e783..40346b61e1 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -26,6 +26,8 @@ #:use-module (guix derivations) #:use-module (guix grafts) #:use-module (guix utils) + #:use-module (guix diagnostics) + #:use-module (guix i18n) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) @@ -401,9 +403,15 @@ Here TARGET is bound to the cross-compilation triplet or #f." (define (true file stat) #t) (define* (%local-file file promise #:optional (name (basename file)) - #:key recursive? (select? true)) + #:key + (literal? #t) location + recursive? (select? true)) ;; This intermediate procedure is part of our ABI, but the underlying ;; %%LOCAL-FILE is not. + (when (and (not literal?) (not (string-prefix? "/" file))) + (warning (and=> location source-properties->location) + (G_ "resolving '~a' relative to current directory~%") + file)) (%%local-file file promise name recursive? select?)) (define (absolute-file-name file directory) @@ -443,9 +451,12 @@ appears." rest ...)) ((_ file rest ...) ;; Resolve FILE relative to the current directory. - #'(%local-file file - (delay (absolute-file-name file (getcwd))) - rest ...)) + (with-syntax ((location (datum->syntax s (syntax-source s)))) + #`(%local-file file + (delay (absolute-file-name file (getcwd))) + #:location 'location + #:literal? #f + rest ...))) ((_) #'(syntax-error "missing file name")) (id diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index f4d020782c..b877fac9df 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -76,6 +76,7 @@ guix/scripts/weather.scm guix/scripts/describe.scm guix/scripts/processes.scm guix/scripts/deploy.scm +guix/gexp.scm guix/gnu-maintenance.scm guix/scripts/container.scm guix/scripts/container/exec.scm diff --git a/tests/guix-system.sh b/tests/guix-system.sh index 667e084fcf..957479ede0 100644 --- a/tests/guix-system.sh +++ b/tests/guix-system.sh @@ -297,6 +297,20 @@ EOF guix system build "$tmpdir/config.scm" -n (cd "$tmpdir"; guix system build "config.scm" -n) +# Check that we get a warning when passing 'local-file' a non-literal relative +# file name. +cat > "$tmpdir/config.scm" <&1 | \ + grep "config\.scm:4:2: warning:.*whatever.*relative to current directory" + # Searching. guix system search tor | grep "^name: tor" guix system search tor | grep "^shepherdnames: tor" -- cgit v1.2.3 From cc346931523a7235a8093ec96f05412d5f2f468d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 2 Oct 2020 09:38:46 +0200 Subject: tests: Adjust to recent changes to the 'emacs' package. Test regression introduced in f88fea0eaa5796303790450ee4543a6d7e61a06e. * tests/guix-package.sh: Add minor and patch levels in the version numbers of 'emacs-foo-bar' and 'emacs-foo-bar-patched'. --- tests/guix-package.sh | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'tests') diff --git a/tests/guix-package.sh b/tests/guix-package.sh index 1a95b8e9a4..a43496699b 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès +# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès # Copyright © 2013 Nikita Karetnikov # # This file is part of GNU Guix. @@ -257,7 +257,7 @@ cat > "$module_dir/foo.scm"< "$module_dir/foo.scm"< Date: Thu, 24 Sep 2020 22:13:06 +0200 Subject: guix build: Record package transformations in manifest entries. With this change, package transformation options used while building a manifest are saved in the metadata of the manifest entries. * guix/scripts/build.scm (transformation-procedure): New procedure. (options->transformation)[applicable]: Use it. Change to a list of key/value/proc tuples instead of key/proc pairs. [package-with-transformation-properties, tagged-object]: New procedures. Use them. (package-transformations, manifest-entry-with-transformations): New procedures. * guix/scripts/pack.scm (guix-pack)[with-transformations]: New procedure. Use it. * guix/scripts/package.scm (process-actions)[transform-entry]: Use it. * tests/guix-package-aliases.sh: Add test. --- guix/scripts/build.scm | 80 ++++++++++++++++++++++++++++++++++--------- guix/scripts/pack.scm | 29 +++++++++------- guix/scripts/package.scm | 13 +++---- tests/guix-package-aliases.sh | 6 ++++ 4 files changed, 93 insertions(+), 35 deletions(-) (limited to 'tests') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 476e556618..72a5d46347 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -63,6 +63,7 @@ %transformation-options options->transformation + manifest-entry-with-transformations show-transformation-options-help guix-build @@ -427,6 +428,14 @@ a checkout of the Git repository at the given URL." (with-git-url . ,transform-package-source-git-url) (without-tests . ,transform-package-tests))) +(define (transformation-procedure key) + "Return the transformation procedure associated with KEY, a symbol such as +'with-source', or #f if there is none." + (any (match-lambda + ((k . proc) + (and (eq? k key) proc))) + %transformations)) + (define %transformation-options ;; The command-line interface to the above transformations. (let ((parser (lambda (symbol) @@ -481,32 +490,69 @@ derivation, etc.), applies the transformations specified by OPTS." ;; order in which they appear on the command line. (filter-map (match-lambda ((key . value) - (match (any (match-lambda - ((k . proc) - (and (eq? k key) proc))) - %transformations) + (match (transformation-procedure key) (#f #f) (transform ;; XXX: We used to pass TRANSFORM a list of several ;; arguments, but we now pass only one, assuming that ;; transform composes well. - (cons key (transform (list value))))))) + (list key value (transform (list value))))))) (reverse opts))) + (define (package-with-transformation-properties p) + (package/inherit p + (properties `((transformations + . ,(map (match-lambda + ((key value _) + (cons key value))) + applicable)) + ,@(package-properties p))))) + (lambda (store obj) - (fold (match-lambda* - (((name . transform) obj) - (let ((new (transform store obj))) - (when (eq? new obj) - (warning (G_ "transformation '~a' had no effect on ~a~%") - name - (if (package? obj) - (package-full-name obj) - obj))) - new))) - obj - applicable))) + (define (tagged-object new) + (if (and (not (eq? obj new)) + (package? new) (not (null? applicable))) + (package-with-transformation-properties new) + new)) + + (tagged-object + (fold (match-lambda* + (((name value transform) obj) + (let ((new (transform store obj))) + (when (eq? new obj) + (warning (G_ "transformation '~a' had no effect on ~a~%") + name + (if (package? obj) + (package-full-name obj) + obj))) + new))) + obj + applicable)))) + +(define (package-transformations package) + "Return the transformations applied to PACKAGE according to its properties." + (match (assq-ref (package-properties package) 'transformations) + (#f '()) + (transformations transformations))) + +(define (manifest-entry-with-transformations entry) + "Return ENTRY with an additional 'transformations' property if it's not +already there." + (let ((properties (manifest-entry-properties entry))) + (if (assq 'transformations properties) + entry + (let ((item (manifest-entry-item entry))) + (manifest-entry + (inherit entry) + (properties + (match (and (package? item) + (package-transformations item)) + ((or #f '()) + properties) + (transformations + `((transformations . ,transformations) + ,@properties))))))))) ;;; diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index bab3a3e2e4..0b66da01f9 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -1140,19 +1140,24 @@ Create a bundle of PACKAGE.\n")) manifest)) identity)) + (define (with-transformations manifest) + (map-manifest-entries manifest-entry-with-transformations + manifest)) + (with-provenance - (cond - ((and (not (null? manifests)) (not (null? packages))) - (leave (G_ "both a manifest and a package list were given~%"))) - ((not (null? manifests)) - (concatenate-manifests - (map (lambda (file) - (let ((user-module (make-user-module - '((guix profiles) (gnu))))) - (load* file user-module))) - manifests))) - (else - (packages->manifest packages)))))) + (with-transformations + (cond + ((and (not (null? manifests)) (not (null? packages))) + (leave (G_ "both a manifest and a package list were given~%"))) + ((not (null? manifests)) + (concatenate-manifests + (map (lambda (file) + (let ((user-module (make-user-module + '((guix profiles) (gnu))))) + (load* file user-module))) + manifests))) + (else + (packages->manifest packages))))))) (with-error-handling (with-store store diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 7e7c37eac4..83f8c123d9 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -864,12 +864,13 @@ processed, #f otherwise." (define (transform-entry entry) (let ((item (transform store (manifest-entry-item entry)))) - (manifest-entry - (inherit entry) - (item item) - (version (if (package? item) - (package-version item) - (manifest-entry-version entry)))))) + (manifest-entry-with-transformations + (manifest-entry + (inherit entry) + (item item) + (version (if (package? item) + (package-version item) + (manifest-entry-version entry))))))) (when (equal? profile %current-profile) ;; Normally the daemon created %CURRENT-PROFILE when we connected, unless diff --git a/tests/guix-package-aliases.sh b/tests/guix-package-aliases.sh index e4ddace057..311838b768 100644 --- a/tests/guix-package-aliases.sh +++ b/tests/guix-package-aliases.sh @@ -39,6 +39,12 @@ test -x "$profile/bin/guile" ! guix install -r guile-bootstrap -p "$profile" --bootstrap test -x "$profile/bin/guile" +# Use a package transformation option and make sure it's recorded. +guix install --bootstrap guile-bootstrap -p "$profile" \ + --with-input=libreoffice=inkscape +test -x "$profile/bin/guile" +grep "libreoffice=inkscape" "$profile/manifest" + guix upgrade --version guix upgrade -n guix upgrade gui.e -n -- cgit v1.2.3 From 8e1907a72430aa989125b053573ef0897c480697 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 25 Sep 2020 17:16:34 +0200 Subject: guix package: Re-apply package transformation when upgrading. * guix/scripts/package.scm (transaction-upgrade-entry)[upgrade]: Add 'transform' parameter. Pass PKG through it. Use 'manifest-entry-with-transformations'. Call 'options->transformation' to get the transformation procedure. * tests/guix-package.sh: Add 'guix package -u' test. * tests/packages.scm ("transaction-upgrade-entry, transformation options preserved"): New test. * doc/guix.texi (Invoking guix package): Mention that transformations are preserved across upgrades. (Package Transformation Options): Likewise. --- doc/guix.texi | 27 +++++++++++++++++++++++++++ guix/scripts/package.scm | 20 +++++++++++++++----- tests/guix-package.sh | 15 +++++++++++++++ tests/packages.scm | 23 +++++++++++++++++++++++ 4 files changed, 80 insertions(+), 5 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index da48c8a72d..a6260a12aa 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3101,6 +3101,29 @@ in the distribution currently installed. To update your distribution, you should regularly run @command{guix pull} (@pxref{Invoking guix pull}). +@cindex package transformations, upgrades +When upgrading, package transformations that were originally applied +when creating the profile are automatically re-applied (@pxref{Package +Transformation Options}). For example, assume you first installed Emacs +from the tip of its development branch with: + +@example +guix install emacs-next --with-branch=emacs-next=master +@end example + +Next time you run @command{guix upgrade}, Guix will again pull the tip +of the Emacs development branch and build @code{emacs-next} from that +checkout. + +Note that transformation options such as @option{--with-branch} and +@option{--with-source} depend on external state; it is up to you to +ensure that they work as expected. You can also discard a +transformations that apply to a package by running: + +@example +guix install @var{package} +@end example + @item --do-not-upgrade[=@var{regexp} @dots{}] When used together with the @option{--upgrade} option, do @emph{not} upgrade any packages whose name matches a @var{regexp}. For example, to @@ -9193,6 +9216,10 @@ This is a convenient way to create customized packages on the fly without having to type in the definitions of package variants (@pxref{Defining Packages}). +Package transformation options are preserved across upgrades: +@command{guix upgrade} attempts to apply transformation options +initially used when creating the profile to the upgraded packages. + @table @code @item --with-source=@var{source} diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 83f8c123d9..2f04652634 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -218,12 +218,13 @@ non-zero relevance score." (output (manifest-entry-output old))) transaction))) - (define (upgrade entry) + (define (upgrade entry transform) (match entry (($ name version output (? string? path)) (match (find-best-packages-by-name name #f) ((pkg . rest) - (let ((candidate-version (package-version pkg))) + (let* ((pkg (transform store pkg)) + (candidate-version (package-version pkg))) (match (package-superseded pkg) ((? package? new) (supersede entry new)) @@ -231,12 +232,14 @@ non-zero relevance score." (case (version-compare candidate-version version) ((>) (manifest-transaction-install-entry - (package->manifest-entry* pkg output) + (manifest-entry-with-transformations + (package->manifest-entry* pkg output)) transaction)) ((<) transaction) ((=) - (let* ((new (package->manifest-entry* pkg output))) + (let* ((new (manifest-entry-with-transformations + (package->manifest-entry* pkg output)))) ;; Here we want to determine whether the NEW actually ;; differs from ENTRY, but we need to intercept ;; 'build-things' calls because they would prevent us from @@ -255,7 +258,14 @@ non-zero relevance score." (if (manifest-transaction-removal-candidate? entry transaction) transaction - (upgrade entry))) + + ;; Upgrade ENTRY, preserving transformation options listed in its + ;; properties. + (let ((transform (options->transformation + (or (assq-ref (manifest-entry-properties entry) + 'transformations) + '())))) + (upgrade entry transform)))) ;;; diff --git a/tests/guix-package.sh b/tests/guix-package.sh index a43496699b..3e5fa71d20 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -184,6 +184,21 @@ grep -E 'emacs[[:blank:]]+42\.5\.9rc7' "$tmpfile" rm "$emacs_tarball" "$tmpfile" rmdir "$module_dir" +# Install with package transformations. +guix install --bootstrap -p "$profile" sed --with-input=sed=guile-bootstrap +grep "sed=guile-bootstrap" "$profile/manifest" +test "$(readlink -f "$profile/bin/guile")" \ + = "$(guix build guile-bootstrap)/bin/guile" +test ! -f "$profile/bin/sed" + +# Make sure the package transformation is preserved. +guix package --bootstrap -p "$profile" -u +grep "sed=guile-bootstrap" "$profile/manifest" +test "$(readlink -f "$profile/bin/guile")" \ + = "$(guix build guile-bootstrap)/bin/guile" +test ! -f "$profile/bin/sed" +rm "$profile" "$profile"-[0-9]-link + # Profiles with a relative file name. Make sure we don't create dangling # symlinks--see bug report at # . diff --git a/tests/packages.scm b/tests/packages.scm index af8941c2e2..5d5abcbd76 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -187,6 +187,29 @@ (string=? (manifest-pattern-version pattern) "1") (string=? (manifest-pattern-output pattern) "out"))))))) +(test-equal "transaction-upgrade-entry, transformation options preserved" + (derivation-file-name (package-derivation %store grep)) + + (let* ((old (dummy-package "emacs" (version "1"))) + (props '((transformations . ((with-input . "emacs=grep"))))) + (tx (transaction-upgrade-entry + %store + (manifest-entry + (inherit (package->manifest-entry old)) + (properties props) + (item (string-append (%store-prefix) "/" + (make-string 32 #\e) "-foo-1"))) + (manifest-transaction)))) + (match (manifest-transaction-install tx) + (((? manifest-entry? entry)) + (and (string=? (manifest-entry-version entry) + (package-version grep)) + (string=? (manifest-entry-name entry) + (package-name grep)) + (equal? (manifest-entry-properties entry) props) + (derivation-file-name + (package-derivation %store (manifest-entry-item entry)))))))) + (test-assert "transaction-upgrade-entry, grafts" ;; Ensure that, when grafts are enabled, 'transaction-upgrade-entry' doesn't ;; try to build stuff. -- cgit v1.2.3 From 0f53c801b91919380a924b402d1ff822bb1dc6ea Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 2 Oct 2020 23:17:40 +0200 Subject: environment: Provide /etc/hosts in containers without '--network'. Fixes . * guix/scripts/environment.scm (launch-environment/container): Create /etc/hosts when NETWORK? is false. * tests/guix-environment-container.sh: Add "localhost" resolution test. --- guix/scripts/environment.scm | 7 +++++++ tests/guix-environment-container.sh | 4 ++++ 2 files changed, 11 insertions(+) (limited to 'tests') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index e2e481dd02..9698111cd2 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -549,6 +549,13 @@ WHILE-LIST." (write-passwd (list passwd)) (write-group groups) + (unless network? + ;; When isolated from the network, provide a minimal /etc/hosts + ;; to resolve "localhost". + (call-with-output-file "/etc/hosts" + (lambda (port) + (display "127.0.0.1 localhost\n" port)))) + ;; For convenience, start in the user's current working ;; directory or, if unmapped, the home directory. (chdir (if map-cwd? diff --git a/tests/guix-environment-container.sh b/tests/guix-environment-container.sh index 040f32cce9..3674aa6026 100644 --- a/tests/guix-environment-container.sh +++ b/tests/guix-environment-container.sh @@ -44,6 +44,10 @@ else test $? = 42 fi +# Make sure "localhost" resolves. +guix environment --container --ad-hoc --bootstrap guile-bootstrap \ + -- guile -c '(exit (pair? (getaddrinfo "localhost" "80")))' + # Make sure '--preserve' is honored. result="`FOOBAR=42; export FOOBAR; guix environment -C --ad-hoc --bootstrap \ guile-bootstrap -E ^FOO -- guile -c '(display (getenv \"FOOBAR\"))'`" -- cgit v1.2.3 From b68d4106518abed20ba308831b65dcc69bf120a5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 4 Oct 2020 22:40:26 +0200 Subject: environment: Turn "lo" up in network-less containers. This is a followup to 0f53c801b91919380a924b402d1ff822bb1dc6ea. * guix/scripts/environment.scm (launch-environment/container): Add call to 'set-network-interface-up'. * tests/guix-environment-container.sh: Add test. --- guix/scripts/environment.scm | 6 +++++- tests/guix-environment-container.sh | 11 +++++++++++ 2 files changed, 16 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 9698111cd2..085f11a9d4 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -34,6 +34,7 @@ #:use-module (guix scripts build) #:use-module (gnu build linux-container) #:use-module (gnu build accounts) + #:use-module ((guix build syscalls) #:select (set-network-interface-up)) #:use-module (gnu system linux-container) #:use-module (gnu system file-systems) #:use-module (gnu packages) @@ -554,7 +555,10 @@ WHILE-LIST." ;; to resolve "localhost". (call-with-output-file "/etc/hosts" (lambda (port) - (display "127.0.0.1 localhost\n" port)))) + (display "127.0.0.1 localhost\n" port))) + + ;; Allow local AF_INET communications. + (set-network-interface-up "lo")) ;; For convenience, start in the user's current working ;; directory or, if unmapped, the home directory. diff --git a/tests/guix-environment-container.sh b/tests/guix-environment-container.sh index 3674aa6026..f2d15c8d0c 100644 --- a/tests/guix-environment-container.sh +++ b/tests/guix-environment-container.sh @@ -48,6 +48,17 @@ fi guix environment --container --ad-hoc --bootstrap guile-bootstrap \ -- guile -c '(exit (pair? (getaddrinfo "localhost" "80")))' +# We should get ECONNREFUSED, not ENETUNREACH, which would indicate that "lo" +# is down. +guix environment --container --ad-hoc --bootstrap guile-bootstrap \ + -- guile -c "(exit (= ECONNREFUSED + (catch 'system-error + (lambda () + (let ((sock (socket AF_INET SOCK_STREAM 0))) + (connect sock AF_INET INADDR_LOOPBACK 12345))) + (lambda args + (pk 'errno (system-error-errno args))))))" + # Make sure '--preserve' is honored. result="`FOOBAR=42; export FOOBAR; guix environment -C --ad-hoc --bootstrap \ guile-bootstrap -E ^FOO -- guile -c '(display (getenv \"FOOBAR\"))'`" -- cgit v1.2.3 From 875c01f82dc5f2c4ca82952ea88b3240fbe8bede Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Mon, 12 Oct 2020 00:30:14 -0400 Subject: tests: Mark the channel-instances->manifest as expected to fail. Allow the Guix package to be updated while awaiting resolution for . * tests/channels.scm (channel-instances->manifest): Mark test as expected to fail. --- tests/channels.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'tests') diff --git a/tests/channels.scm b/tests/channels.scm index 1b6f640c4a..ba8cfe639e 100644 --- a/tests/channels.scm +++ b/tests/channels.scm @@ -230,6 +230,7 @@ #:current-channels (list new) #:validate-pull validate-pull))))))) +(test-expect-fail 1) ;see: https://issues.guix.gnu.org/43940 (test-assert "channel-instances->manifest" ;; Compute the manifest for a graph of instances and make sure we get a ;; derivation graph that mirrors the instance graph. This test also ensures -- cgit v1.2.3 From 6c46e477eb50c6ee7c9b7c8199bdfb3708dc32b5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 12 Oct 2020 10:10:03 +0200 Subject: channels: Address test failure. Fixes . Reported by Maxim Cournoyer . The "channel-instances->manifest" test would fail since 1d4ab335b22a93e01c2eb1eb3e93fc6534157040: 'quiet-guile' would be passed #f as GUILE, and thus 'package-version' would fail with wrong-type-arg. * guix/channels.scm (whole-package-for-legacy): Pass #:guile to 'whole-package'. * tests/channels.scm ("channel-instances->manifest"): Remove 'test-expect-fail'. --- guix/channels.scm | 3 ++- tests/channels.scm | 1 - 2 files changed, 2 insertions(+), 2 deletions(-) (limited to 'tests') diff --git a/guix/channels.scm b/guix/channels.scm index ad2442f50e..916d663e9f 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -783,7 +783,8 @@ modules in the old ~/.config/guix/latest style." ;; derivation that builds modules. We have to infer what the ;; dependencies of these modules were. (list guile-json-3 guile-git guile-bytestructures - (ssh -> guile-ssh) (tls -> gnutls))))) + (ssh -> guile-ssh) (tls -> gnutls)) + #:guile (default-guile)))) (define (old-style-guix? drv) "Return true if DRV corresponds to a ~/.config/guix/latest style of diff --git a/tests/channels.scm b/tests/channels.scm index ba8cfe639e..1b6f640c4a 100644 --- a/tests/channels.scm +++ b/tests/channels.scm @@ -230,7 +230,6 @@ #:current-channels (list new) #:validate-pull validate-pull))))))) -(test-expect-fail 1) ;see: https://issues.guix.gnu.org/43940 (test-assert "channel-instances->manifest" ;; Compute the manifest for a graph of instances and make sure we get a ;; derivation graph that mirrors the instance graph. This test also ensures -- cgit v1.2.3 From d3162b98a824a32ce955de18b9b891fbc4342d44 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 12 Oct 2020 11:51:13 +0200 Subject: tests: Add missing copyright line. * tests/channels.scm: Add copyright line for past changes. --- tests/channels.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'tests') diff --git a/tests/channels.scm b/tests/channels.scm index 1b6f640c4a..0264369d9e 100644 --- a/tests/channels.scm +++ b/tests/channels.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Ricardo Wurmus +;;; Copyright © 2019, 2020 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; -- cgit v1.2.3 From 46135ce4cefab9e164d75697d7ea0c8359b842e4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 Sep 2020 17:36:42 +0200 Subject: packages: Add 'package-with-c-toolchain'. * guix/build-system.scm (build-system-with-c-toolchain): New procedure. * guix/packages.scm (package-with-c-toolchain): New procedure. * tests/packages.scm ("package-with-c-toolchain"): New test. * doc/guix.texi (package Reference): Document 'package-with-c-toolchain'. (Build Systems): Mention it. --- doc/guix.texi | 32 ++++++++++++++++++++++++++++++++ guix/build-system.scm | 35 +++++++++++++++++++++++++++++++++-- guix/packages.scm | 9 +++++++++ tests/packages.scm | 20 ++++++++++++++++++++ 4 files changed, 94 insertions(+), 2 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 8514dfe86f..e084144a82 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6558,6 +6558,35 @@ cross-compiling: It is an error to refer to @code{this-package} outside a package definition. @end deffn +Because packages are regular Scheme objects that capture a complete +dependency graph and associated build procedures, it is often useful to +write procedures that take a package and return a modified version +thereof according to some parameters. Below are a few examples. + +@cindex tool chain, choosing a package's tool chain +@deffn {Scheme Procedure} package-with-c-toolchain @var{package} @var{toolchain} +Return a variant of @var{package} that uses @var{toolchain} instead of +the default GNU C/C++ toolchain. @var{toolchain} must be a list of +inputs (label/package tuples) providing equivalent functionality, such +as the @code{gcc-toolchain} package. + +The example below returns a variant of the @code{hello} package built +with GCC@tie{}10.x and the rest of the GNU tool chain (Binutils and the +GNU C Library) instead of the default tool chain: + +@lisp +(let ((toolchain (specification->package "gcc-toolchain@@10"))) + (package-with-c-toolchain hello `(("toolchain" ,toolchain)))) +@end lisp + +The build tool chain is part of the @dfn{implicit inputs} of +packages---it's usually not listed as part of the various ``inputs'' +fields and is instead pulled in by the build system. Consequently, this +procedure works by changing the build system of @var{package} so that it +pulls in @var{toolchain} instead of the defaults. @ref{Build Systems}, +for more on build systems. +@end deffn + @node origin Reference @subsection @code{origin} Reference @@ -6694,6 +6723,9 @@ ornamentation---in other words, a bag is a lower-level representation of a package, which includes all the inputs of that package, including some that were implicitly added by the build system. This intermediate representation is then compiled to a derivation (@pxref{Derivations}). +The @code{package-with-c-toolchain} is an example of a way to change the +implicit inputs that a package's build system pulls in (@pxref{package +Reference, @code{package-with-c-toolchain}}). Build systems accept an optional list of @dfn{arguments}. In package definitions, these are passed @i{via} the @code{arguments} field diff --git a/guix/build-system.scm b/guix/build-system.scm index 4174972b98..76d670995c 100644 --- a/guix/build-system.scm +++ b/guix/build-system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2020 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,6 +18,7 @@ (define-module (guix build-system) #:use-module (guix records) + #:use-module (srfi srfi-1) #:use-module (ice-9 match) #:export (build-system build-system? @@ -37,7 +38,9 @@ bag-arguments bag-build - make-bag)) + make-bag + + build-system-with-c-toolchain)) (define-record-type* build-system make-build-system build-system? @@ -98,3 +101,31 @@ intermediate representation just above derivations." #:outputs outputs #:target target arguments)))) + +(define (build-system-with-c-toolchain bs toolchain) + "Return a variant of BS, a build system, that uses TOOLCHAIN instead of the +default GNU C/C++ toolchain. TOOLCHAIN must be a list of +inputs (label/package tuples) providing equivalent functionality, such as the +'gcc-toolchain' package." + (define lower + (build-system-lower bs)) + + (define toolchain-packages + ;; These are the GNU toolchain packages pulled in by GNU-BUILD-SYSTEM and + ;; all the build systems that inherit from it. Keep the list in sync with + ;; 'standard-packages' in (guix build-system gnu). + '("gcc" "binutils" "libc" "libc:static" "ld-wrapper")) + + (define (lower* . args) + (let ((lowered (apply lower args))) + (bag + (inherit lowered) + (build-inputs + (append (fold alist-delete + (bag-build-inputs lowered) + toolchain-packages) + toolchain))))) + + (build-system + (inherit bs) + (lower lower*))) diff --git a/guix/packages.scm b/guix/packages.scm index 4f2bb432be..24d6417065 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -124,6 +124,7 @@ package-patched-vulnerabilities package-with-patches package-with-extra-patches + package-with-c-toolchain package/inherit transitive-input-references @@ -790,6 +791,14 @@ specifies modules in scope when evaluating SNIPPET." (append (origin-patches (package-source original)) patches))) +(define (package-with-c-toolchain package toolchain) + "Return a variant of PACKAGE that uses TOOLCHAIN instead of the default GNU +C/C++ toolchain. TOOLCHAIN must be a list of inputs (label/package tuples) +providing equivalent functionality, such as the 'gcc-toolchain' package." + (let ((bs (package-build-system package))) + (package/inherit package + (build-system (build-system-with-c-toolchain bs toolchain))))) + (define (transitive-inputs inputs) "Return the closure of INPUTS when considering the 'propagated-inputs' edges. Omit duplicate inputs, except for those already present in INPUTS diff --git a/tests/packages.scm b/tests/packages.scm index 5d5abcbd76..2d13d91344 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -1430,6 +1430,26 @@ (derivation-file-name (package-derivation %store coreutils)))))))) +(test-assert "package-with-c-toolchain" + (let* ((dep (dummy-package "chbouib" + (build-system gnu-build-system) + (native-inputs `(("x" ,grep))))) + (p0 (dummy-package "thingie" + (build-system gnu-build-system) + (inputs `(("foo" ,grep) + ("bar" ,dep))))) + (tc (dummy-package "my-toolchain")) + (p1 (package-with-c-toolchain p0 `(("toolchain" ,tc))))) + (define toolchain-packages + '("gcc" "binutils" "glibc" "ld-wrapper")) + + (match (bag-build-inputs (package->bag p1)) + ((("foo" foo) ("bar" bar) (_ (= package-name packages) . _) ...) + (and (not (any (cut member <> packages) toolchain-packages)) + (member "my-toolchain" packages) + (eq? foo grep) + (eq? bar dep)))))) + (test-equal "package-patched-vulnerabilities" '(("CVE-2015-1234") ("CVE-2016-1234" "CVE-2018-4567") -- cgit v1.2.3 From abd7a474615353149a44f4504f0b4b248dcc0716 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 Sep 2020 18:56:00 +0200 Subject: guix build: Add '--with-c-toolchain'. * guix/scripts/build.scm (package-dependents/spec) (package-toolchain-rewriting, transform-package-toolchain): New procedures. (%transformations): Add it. (%transformation-options, show-transformation-options-help): Add '--with-c-toolchain'. * tests/scripts-build.scm (depends-on-toolchain?): New procedure. ("options->transformation, with-c-toolchain") ("options->transformation, with-c-toolchain twice") New test. ("options->transformation, with-c-toolchain, no effect"): New tests. * doc/guix.texi (Package Transformation Options): Document it. --- doc/guix.texi | 38 ++++++++++++++++++++++ guix/scripts/build.scm | 84 +++++++++++++++++++++++++++++++++++++++++++++++++ tests/scripts-build.scm | 82 +++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 204 insertions(+) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index e084144a82..7150adeaa8 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -9364,6 +9364,44 @@ must be compatible. If @var{replacement} is somehow incompatible with @var{package}, then the resulting package may be unusable. Use with care! +@cindex tool chain, changing the build tool chain of a package +@item --with-c-toolchain=@var{package}=@var{toolchain} +This option changes the compilation of @var{package} and everything that +depends on it so that they get built with @var{toolchain} instead of the +default GNU tool chain for C/C++. + +Consider this example: + +@example +guix build octave-cli \ + --with-c-toolchain=fftw=gcc-toolchain@@10 \ + --with-c-toolchain=fftwf=gcc-toolchain@@10 +@end example + +The command above builds a variant of the @code{fftw} and @code{fftwf} +packages using version 10 of @code{gcc-toolchain} instead of the default +tool chain, and then builds a variant of the GNU@tie{}Octave +command-line interface using them. GNU@tie{}Octave itself is also built +with @code{gcc-toolchain@@10}. + +This other example builds the Hardware Locality (@code{hwloc}) library +and its dependents up to @code{intel-mpi-benchmarks} with the Clang C +compiler: + +@example +guix build --with-c-toolchain=hwloc=clang-toolchain \ + intel-mpi-benchmarks +@end example + +@quotation Note +There can be application binary interface (ABI) incompatibilities among +tool chains. This is particularly true of the C++ standard library and +run-time support libraries such as that of OpenMP. By rebuilding all +dependents with the same tool chain, @option{--with-c-toolchain} minimizes +the risks of incompatibility but cannot entirely eliminate them. Choose +@var{package} wisely. +@end quotation + @item --with-git-url=@var{package}=@var{url} @cindex Git, using the latest commit @cindex latest commit, building diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 72a5d46347..e59e0ee67f 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -26,6 +26,7 @@ #:use-module (guix store) #:use-module (guix derivations) #:use-module (guix packages) + #:use-module (guix memoization) #:use-module (guix grafts) #:use-module (guix utils) @@ -396,6 +397,83 @@ a checkout of the Git repository at the given URL." (rewrite obj) obj))) +(define (package-dependents/spec top bottom) + "Return the list of dependents of BOTTOM, a spec string, that are also +dependencies of TOP, a package." + (define-values (name version) + (package-name->name+version bottom)) + + (define dependent? + (mlambda (p) + (and (package? p) + (or (and (string=? name (package-name p)) + (or (not version) + (version-prefix? version (package-version p)))) + (match (bag-direct-inputs (package->bag p)) + (((labels dependencies . _) ...) + (any dependent? dependencies))))))) + + (filter dependent? (package-closure (list top)))) + +(define (package-toolchain-rewriting p bottom toolchain) + "Return a procedure that, when passed a package that's either BOTTOM or one +of its dependents up to P so, changes it so it is built with TOOLCHAIN. +TOOLCHAIN must be an input list." + (define rewriting-property + (gensym " package-toolchain-rewriting")) + + (match (package-dependents/spec p bottom) + (() ;P does not depend on BOTTOM + identity) + (set + ;; SET is the list of packages "between" P and BOTTOM (included) whose + ;; toolchain needs to be changed. + (package-mapping (lambda (p) + (if (or (assq rewriting-property + (package-properties p)) + (not (memq p set))) + p + (let ((p (package-with-c-toolchain p toolchain))) + (package/inherit p + (properties `((,rewriting-property . #t) + ,@(package-properties p))))))) + (lambda (p) + (or (assq rewriting-property (package-properties p)) + (not (memq p set)))) + #:deep? #t)))) + +(define (transform-package-toolchain replacement-specs) + "Return a procedure that, when passed a package, changes its toolchain or +that of its dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is +a list of strings like \"fftw=gcc-toolchain@10\" meaning that the package to +the left of the equal sign must be built with the toolchain to the right of +the equal sign." + (define split-on-commas + (cute string-tokenize <> (char-set-complement (char-set #\,)))) + + (define (specification->input spec) + (let ((package (specification->package spec))) + (list (package-name package) package))) + + (define replacements + (map (lambda (spec) + (match (string-tokenize spec %not-equal) + ((spec (= split-on-commas toolchain)) + (cons spec (map specification->input toolchain))) + (_ + (leave (G_ "~a: invalid toolchain replacement specification~%") + spec)))) + replacement-specs)) + + (lambda (store obj) + (if (package? obj) + (or (any (match-lambda + ((bottom . toolchain) + ((package-toolchain-rewriting obj bottom toolchain) obj))) + replacements) + obj) + obj))) + (define (transform-package-tests specs) "Return a procedure that, when passed a package, sets #:tests? #f in its 'arguments' field." @@ -426,6 +504,7 @@ a checkout of the Git repository at the given URL." (with-branch . ,transform-package-source-branch) (with-commit . ,transform-package-source-commit) (with-git-url . ,transform-package-source-git-url) + (with-c-toolchain . ,transform-package-toolchain) (without-tests . ,transform-package-tests))) (define (transformation-procedure key) @@ -455,6 +534,8 @@ a checkout of the Git repository at the given URL." (parser 'with-commit)) (option '("with-git-url") #t #f (parser 'with-git-url)) + (option '("with-c-toolchain") #t #f + (parser 'with-c-toolchain)) (option '("without-tests") #t #f (parser 'without-tests))))) @@ -477,6 +558,9 @@ a checkout of the Git repository at the given URL." (display (G_ " --with-git-url=PACKAGE=URL build PACKAGE from the repository at URL")) + (display (G_ " + --with-c-toolchain=PACKAGE=TOOLCHAIN + build PACKAGE and its dependents with TOOLCHAIN")) (display (G_ " --without-tests=PACKAGE build PACKAGE without running its tests"))) diff --git a/tests/scripts-build.scm b/tests/scripts-build.scm index 5f91360953..6925374baa 100644 --- a/tests/scripts-build.scm +++ b/tests/scripts-build.scm @@ -22,6 +22,8 @@ #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix git-download) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) #:use-module (guix scripts build) #:use-module (guix ui) #:use-module (guix utils) @@ -30,6 +32,8 @@ #:use-module (gnu packages base) #:use-module (gnu packages busybox) #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-64)) @@ -270,6 +274,80 @@ ((("x" dep3)) (map package-source (list dep1 dep3)))))))))))) +(define* (depends-on-toolchain? p #:optional (toolchain "gcc-toolchain")) + "Return true if P depends on TOOLCHAIN instead of the default tool chain." + (define toolchain-packages + '("gcc" "binutils" "glibc" "ld-wrapper")) + + (define (package-name* obj) + (and (package? obj) (package-name obj))) + + (match (bag-build-inputs (package->bag p)) + (((_ (= package-name* packages) . _) ...) + (and (not (any (cut member <> packages) toolchain-packages)) + (member toolchain packages))))) + +(test-assert "options->transformation, with-c-toolchain" + (let* ((dep0 (dummy-package "chbouib" + (build-system gnu-build-system) + (native-inputs `(("y" ,grep))))) + (dep1 (dummy-package "stuff" + (native-inputs `(("x" ,dep0))))) + (p (dummy-package "thingie" + (build-system gnu-build-system) + (inputs `(("foo" ,grep) + ("bar" ,dep1))))) + (t (options->transformation + '((with-c-toolchain . "chbouib=gcc-toolchain"))))) + ;; Here we check that the transformation applies to DEP0 and all its + ;; dependents: DEP0 must use GCC-TOOLCHAIN, DEP1 must use GCC-TOOLCHAIN + ;; and the DEP0 that uses GCC-TOOLCHAIN, and so on. + (with-store store + (let ((new (t store p))) + (and (depends-on-toolchain? new "gcc-toolchain") + (match (bag-build-inputs (package->bag new)) + ((("foo" dep0) ("bar" dep1) _ ...) + (and (depends-on-toolchain? dep1 "gcc-toolchain") + (not (depends-on-toolchain? dep0 "gcc-toolchain")) + (string=? (package-full-name dep0) + (package-full-name grep)) + (match (bag-build-inputs (package->bag dep1)) + ((("x" dep) _ ...) + (and (depends-on-toolchain? dep "gcc-toolchain") + (match (bag-build-inputs (package->bag dep)) + ((("y" dep) _ ...) ;this one is unchanged + (eq? dep grep)))))))))))))) + +(test-equal "options->transformation, with-c-toolchain twice" + (package-full-name grep) + (let* ((dep0 (dummy-package "chbouib")) + (dep1 (dummy-package "stuff")) + (p (dummy-package "thingie" + (build-system gnu-build-system) + (inputs `(("foo" ,dep0) + ("bar" ,dep1) + ("baz" ,grep))))) + (t (options->transformation + '((with-c-toolchain . "chbouib=clang-toolchain") + (with-c-toolchain . "stuff=clang-toolchain"))))) + (with-store store + (let ((new (t store p))) + (and (depends-on-toolchain? new "clang-toolchain") + (match (bag-build-inputs (package->bag new)) + ((("foo" dep0) ("bar" dep1) ("baz" dep2) _ ...) + (and (depends-on-toolchain? dep0 "clang-toolchain") + (depends-on-toolchain? dep1 "clang-toolchain") + (not (depends-on-toolchain? dep2 "clang-toolchain")) + (package-full-name dep2))))))))) + +(test-assert "options->transformation, with-c-toolchain, no effect" + (let ((p (dummy-package "thingie")) + (t (options->transformation + '((with-c-toolchain . "does-not-exist=gcc-toolchain"))))) + ;; When it has no effect, '--with-c-toolchain' returns P. + (with-store store + (eq? (t store p) p)))) + (test-assert "options->transformation, without-tests" (let* ((dep (dummy-package "dep")) (p (dummy-package "foo" @@ -286,3 +364,7 @@ '(#:tests? #f)))))))) (test-end) + +;;; Local Variables: +;;; eval: (put 'dummy-package 'scheme-indent-function 1) +;;; End: -- cgit v1.2.3 From 5ef1508942ee083ed22b844f5291e59320016b79 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 15 Oct 2020 16:41:14 +0200 Subject: ui: Only suggest modules that export the unbound variable identifier. Fixes . Reported by Tobias Geerinckx-Rice . * guix/ui.scm (known-variable-definition): Check for variables in the public interface of HEAD, not in HEAD itself. * tests/guix-build.sh: Add test. --- guix/ui.scm | 3 ++- tests/guix-build.sh | 27 +++++++++++++++++++++++++++ 2 files changed, 29 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/guix/ui.scm b/guix/ui.scm index 8213e8ebab..8d7bc238bc 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -297,7 +297,8 @@ VARIABLE and return it, or #f if none was found." (hash-map->list (lambda (name module) module) (module-submodules head))))) - (match (module-local-variable head variable) + (match (and=> (module-public-interface head) + (cut module-local-variable <> variable)) (#f (loop next suggestions visited)) (_ (match (module-name head) diff --git a/tests/guix-build.sh b/tests/guix-build.sh index 6dbb53206e..4a58ea1476 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -198,6 +198,33 @@ grep "forget.*(guix build-system gnu)" "$module_dir/err" # hint rm -f "$module_dir"/* +# Unbound variable: don't suggest modules that do not export the variable. +cat > "$module_dir/aa-private.scm" < "$module_dir/bb-public.scm" < "$module_dir/cc-user.scm" < "$module_dir/err" +cat "$module_dir/err" +grep "make-thing.*unbound" "$module_dir/err" # actual error +grep "forget.*(bb-public)" "$module_dir/err" # hint + +rm -f "$module_dir"/* + # Wrong 'define-module' clause reported by 'warn-about-load-error'. cat > "$module_dir/foo.scm" < Date: Mon, 21 Oct 2019 12:23:40 +0200 Subject: system: Add locale to boot-parameters. * gnu/system.scm (define-module)[export]: Add boot-parameters-locale. ()[locale]: New field. [boot-parameters-locale]: New accessor. (read-boot-parameters): Read locale field. (operating-system-boot-parameters): Provide operating-system locale to boot-parameters record. (opeating-system-boot-parameters-file): Likewise. * Makefile.am (SCM_TESTS): Add tests/boot-parameters.scm. * tests/boot-parameters.scm: New test file. --- Makefile.am | 1 + gnu/system.scm | 11 ++ tests/boot-parameters.scm | 256 ++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 268 insertions(+) create mode 100644 tests/boot-parameters.scm (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index a75d9c1ffc..c509562567 100644 --- a/Makefile.am +++ b/Makefile.am @@ -407,6 +407,7 @@ SCM_TESTS = \ tests/base16.scm \ tests/base32.scm \ tests/base64.scm \ + tests/boot-parameters.scm \ tests/bournish.scm \ tests/builders.scm \ tests/build-utils.scm \ diff --git a/gnu/system.scm b/gnu/system.scm index 59dfeb99b4..e8fe41cc24 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2016 Chris Marusich ;;; Copyright © 2017 Mathieu Othacehe ;;; Copyright © 2019 Meiyo Peng +;;; Copyright © 2019 Miguel Ángel Arruga Vivas ;;; Copyright © 2020 Danny Milosavljevic ;;; Copyright © 2020 Brice Waegeneire ;;; Copyright © 2020 Florian Pelz @@ -148,6 +149,7 @@ boot-parameters-bootloader-menu-entries boot-parameters-store-device boot-parameters-store-mount-point + boot-parameters-locale boot-parameters-kernel boot-parameters-kernel-arguments boot-parameters-initrd @@ -297,6 +299,7 @@ directly by the user." boot-parameters-bootloader-menu-entries) (store-device boot-parameters-store-device) (store-mount-point boot-parameters-store-mount-point) + (locale boot-parameters-locale) (kernel boot-parameters-kernel) (kernel-arguments boot-parameters-kernel-arguments) (initrd boot-parameters-initrd) @@ -374,6 +377,11 @@ file system labels." ((_ args) args) (#f '()))) + (locale + (match (assq 'locale rest) + ((_ locale) locale) + (#f #f))) + (store-device ;; Linux device names like "/dev/sda1" are not suitable GRUB device ;; identifiers, so we just filter them out. @@ -1284,6 +1292,7 @@ such as '--root' and '--load' to ." (let* ((initrd (and (not (operating-system-hurd os)) (operating-system-initrd-file os))) (store (operating-system-store-file-system os)) + (locale (operating-system-locale os)) (bootloader (bootloader-configuration-bootloader (operating-system-bootloader os))) (bootloader-name (bootloader-name bootloader)) @@ -1302,6 +1311,7 @@ such as '--root' and '--load' to ." (bootloader-name bootloader-name) (bootloader-menu-entries (bootloader-configuration-menu-entries (operating-system-bootloader os))) + (locale locale) (store-device (ensure-not-/dev (file-system-device store))) (store-mount-point (file-system-mount-point store))))) @@ -1354,6 +1364,7 @@ being stored into the \"parameters\" file)." (or (and=> (operating-system-bootloader os) bootloader-configuration-menu-entries) '()))) + (locale #$(boot-parameters-locale params)) (store (device #$(device->sexp (boot-parameters-store-device params))) diff --git a/tests/boot-parameters.scm b/tests/boot-parameters.scm new file mode 100644 index 0000000000..d7e579bc89 --- /dev/null +++ b/tests/boot-parameters.scm @@ -0,0 +1,256 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019, 2020 Miguel Ángel Arruga Vivas +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +;;; Commentary: +;;; +;;; Test boot parameters value storage and compatibility. +;;; +;;; Code: + +(define-module (test-boot-parameters) + #:use-module (gnu bootloader) + #:use-module (gnu bootloader grub) + #:use-module (gnu system) + #:use-module (gnu system file-systems) + #:use-module (gnu system uuid) + #:use-module (guix gexp) + #:use-module (guix store) + #:use-module (guix tests) + #:use-module (srfi srfi-64) + #:use-module (rnrs bytevectors)) + +(define %default-label "GNU with Linux-libre 99.1.2") +(define %default-kernel-path + (string-append (%store-prefix) + "/zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz-linux-libre-99.1.2")) +(define %default-kernel + (string-append %default-kernel-path "/" (system-linux-image-file-name))) +(define %default-kernel-arguments '()) +(define %default-initrd-path + (string-append (%store-prefix) "/wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww-initrd")) +(define %default-initrd (string-append %default-initrd-path "/initrd.cpio.gz")) +(define %default-root-device (uuid "abcdef12-3456-7890-abcd-ef1234567890")) +(define %default-store-device (uuid "01234567-89ab-cdef-0123-456789abcdef")) +(define %default-store-mount-point (%store-prefix)) +(define %default-multiboot-modules '()) +(define %default-locale "es_ES.utf8") +(define %root-path "/") + +(define %grub-boot-parameters + (boot-parameters + (bootloader-name 'grub) + (bootloader-menu-entries '()) + (root-device %default-root-device) + (label %default-label) + (kernel %default-kernel) + (kernel-arguments %default-kernel-arguments) + (initrd %default-initrd) + (multiboot-modules %default-multiboot-modules) + (locale %default-locale) + (store-device %default-store-device) + (store-mount-point %default-store-mount-point))) + +(define %default-operating-system + (operating-system + (host-name "host") + (timezone "Europe/Berlin") + (locale %default-locale) + + (bootloader (bootloader-configuration + (bootloader grub-bootloader) + (target "/dev/sda"))) + (file-systems (cons* (file-system + (device %default-root-device) + (mount-point %root-path) + (type "ext4")) + (file-system + (device %default-store-device) + (mount-point %default-store-mount-point) + (type "btrfs")) + %base-file-systems)))) + +(define (quote-uuid uuid) + (list 'uuid (uuid-type uuid) (uuid-bytevector uuid))) + +;; Call read-boot-parameters with the desired string as input. +(define* (test-read-boot-parameters + #:key + (version 0) + (bootloader-name 'grub) + (bootloader-menu-entries '()) + (label %default-label) + (root-device (quote-uuid %default-root-device)) + (kernel %default-kernel) + (kernel-arguments %default-kernel-arguments) + (initrd %default-initrd) + (multiboot-modules %default-multiboot-modules) + (locale %default-locale) + (with-store #t) + (store-device + (quote-uuid %default-store-device)) + (store-mount-point %default-store-mount-point)) + (define (generate-boot-parameters) + (define (sexp-or-nothing fmt val) + (cond ((eq? 'false val) (format #false fmt #false)) + (val (format #false fmt val)) + (else ""))) + (format #false "(boot-parameters~a~a~a~a~a~a~a~a~a~a)" + (sexp-or-nothing " (version ~S)" version) + (sexp-or-nothing " (label ~S)" label) + (sexp-or-nothing " (root-device ~S)" root-device) + (sexp-or-nothing " (kernel ~S)" kernel) + (sexp-or-nothing " (kernel-arguments ~S)" kernel-arguments) + (sexp-or-nothing " (initrd ~S)" initrd) + (if with-store + (format #false " (store~a~a)" + (sexp-or-nothing " (device ~S)" store-device) + (sexp-or-nothing " (mount-point ~S)" + store-mount-point)) + "") + (sexp-or-nothing " (locale ~S)" locale) + (sexp-or-nothing " (bootloader-name ~a)" bootloader-name) + (sexp-or-nothing " (bootloader-menu-entries ~S)" + bootloader-menu-entries))) + (let ((str (generate-boot-parameters))) + (call-with-input-string str read-boot-parameters))) + +(test-begin "boot-parameters") + +;; XXX: +(test-assert "read, construction, mandatory fields" + (not (or (test-read-boot-parameters #:version #false) + (test-read-boot-parameters #:version 'false) + (test-read-boot-parameters #:version -1) + (test-read-boot-parameters #:version "0") + (test-read-boot-parameters #:root-device #false) + (test-read-boot-parameters #:kernel #false) + (test-read-boot-parameters #:label #false)))) + +(test-assert "read, construction, optional fields" + (and (test-read-boot-parameters #:bootloader-name #false) + (test-read-boot-parameters #:bootloader-menu-entries #false) + (test-read-boot-parameters #:kernel-arguments #false) + (test-read-boot-parameters #:with-store #false) + (test-read-boot-parameters #:store-device #false) + (test-read-boot-parameters #:store-device 'false) + (test-read-boot-parameters #:store-mount-point #false) + (test-read-boot-parameters #:multiboot-modules #false) + (test-read-boot-parameters #:locale #false) + (test-read-boot-parameters #:bootloader-name #false + #:kernel-arguments #false + #:with-store #false + #:locale #false))) + +(test-equal "read, default equality" + %grub-boot-parameters + (test-read-boot-parameters)) + +(test-equal "read, root-device, label" + (file-system-label "my-root") + (boot-parameters-root-device + (test-read-boot-parameters #:root-device '(file-system-label "my-root")))) + +(test-equal "read, root-device, /dev node" + "/dev/sda2" + (boot-parameters-root-device + (test-read-boot-parameters #:root-device "/dev/sda2"))) + +(test-equal "read, kernel, only store path" + %default-kernel + (boot-parameters-kernel + (test-read-boot-parameters #:kernel %default-kernel-path))) + +(test-equal "read, kernel, full-path" + %default-kernel + (boot-parameters-kernel + (test-read-boot-parameters #:kernel %default-kernel))) + +(test-assert "read, construction, missing initrd" + (not (boot-parameters-initrd (test-read-boot-parameters #:initrd #false)))) + +(test-equal "read, initrd, old format" + "/a/b" + (boot-parameters-initrd + (test-read-boot-parameters #:initrd (list 'string-append "/a" "/b")))) + + ;; Compatibility reasons specified in gnu/system.scm. +(test-eq "read, bootloader-name, default value" + 'grub + (boot-parameters-bootloader-name + (test-read-boot-parameters #:bootloader-name #false))) + +(test-eq "read, bootloader-menu-entries, default value" + '() + (boot-parameters-bootloader-menu-entries + (test-read-boot-parameters #:bootloader-menu-entries #false))) + +(test-eq "read, kernel-arguments, default value" + '() + (boot-parameters-kernel-arguments + (test-read-boot-parameters #:kernel-arguments #false))) + +(test-assert "read, store-device, filter /dev" + (not (boot-parameters-store-device + (test-read-boot-parameters #:store-device "/dev/sda3")))) + +(test-assert "read, no-store, filter /dev from root" + (not (boot-parameters-store-device + (test-read-boot-parameters #:root-device "/dev/sda3" + #:with-store #false)))) + +(test-assert "read, no store-device, filter /dev from root" + (not (boot-parameters-store-device + (test-read-boot-parameters #:root-device "/dev/sda3" + #:store-device #false)))) + +(test-assert "read, store-device #false, filter /dev from root" + (not (boot-parameters-store-device + (test-read-boot-parameters #:root-device "/dev/sda3" + #:store-device 'false)))) + +(test-equal "read, store-device, label (legacy)" + (file-system-label "my-store") + (boot-parameters-store-device + (test-read-boot-parameters #:store-device "my-store"))) + +(test-equal "read, store-device, from root" + %default-root-device + (boot-parameters-store-device + (test-read-boot-parameters #:with-store #false))) + +(test-equal "read, no store-mount-point, default" + %root-path + (boot-parameters-store-mount-point + (test-read-boot-parameters #:store-mount-point #false))) + +(test-equal "read, no store, default store-mount-point" + %root-path + (boot-parameters-store-mount-point + (test-read-boot-parameters #:with-store #false))) + +;; For whitebox testing +(define operating-system-boot-parameters + (@@ (gnu system) operating-system-boot-parameters)) + +(test-equal "from os, locale" + %default-locale + (boot-parameters-locale + (operating-system-boot-parameters %default-operating-system + %default-root-device))) + +(test-end "boot-parameters") -- cgit v1.2.3