From 99aec37a78e7be6a591d0e5b7439896d669a75d1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 14 Mar 2019 17:02:53 +0100 Subject: pack: "-RR" produces PRoot-enabled relocatable binaries. * gnu/packages/aux-files/run-in-namespace.c (exec_with_proot): New function. (main): When 'clone' fails, call 'rm_rf'. [PROOT_PROGRAM]: When 'clone' fails, call 'exec_with_proot'. * guix/scripts/pack.scm (wrapped-package): Add #:proot?. [proot]: New procedure. [build]: Compile with -DPROOT_PROGRAM when PROOT? is true. * guix/scripts/pack.scm (%options): Set the 'relocatable?' value to 'proot when "-R" is passed several times. (guix-pack): Pass #:proot? to 'wrapped-package'. * tests/guix-pack-relocatable.sh: Use "-RR" on Intel systems that lack user namespace support. * doc/guix.texi (Invoking guix pack): Document -RR. --- tests/guix-pack-relocatable.sh | 21 ++++++++++++++++----- 1 file changed, 16 insertions(+), 5 deletions(-) (limited to 'tests') diff --git a/tests/guix-pack-relocatable.sh b/tests/guix-pack-relocatable.sh index 554416627b..38dcf1e485 100644 --- a/tests/guix-pack-relocatable.sh +++ b/tests/guix-pack-relocatable.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2018 Ludovic Courtès +# Copyright © 2018, 2019 Ludovic Courtès # # This file is part of GNU Guix. # @@ -41,17 +41,28 @@ STORE_PARENT="`dirname $NIX_STORE_DIR`" export STORE_PARENT if test "$STORE_PARENT" = "/"; then exit 77; fi -# This test requires user namespaces and associated command-line tools. -if ! unshare -mrf sh -c 'mount -t tmpfs none "$STORE_PARENT"' +if unshare -mrf sh -c 'mount -t tmpfs none "$STORE_PARENT"' then - exit 77 + # Test the wrapper that relies on user namespaces. + relocatable_option="-R" +else + case "`uname -m`" in + x86_64|i?86) + # Test the wrapper that falls back to PRoot. + relocatable_option="-RR";; + *) + # XXX: Our 'proot' package currently fails tests on non-Intel + # architectures, so skip this by default. + exit 77;; + esac fi test_directory="`mktemp -d`" export test_directory trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory"' EXIT -tarball="`guix pack -R -S /Bin=bin sed`" +export relocatable_option +tarball="`guix pack $relocatable_option -S /Bin=bin sed`" (cd "$test_directory"; tar xvf "$tarball") # Run that relocatable 'sed' in a user namespace where we "erase" the store by -- cgit v1.2.3 From 22f95e028f038cee342f455dfc55bd32b804907c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 16 Mar 2019 15:11:29 +0100 Subject: tests: Add 'with-environment-variable'. * tests/scripts.scm (with-environment-variable): Move to... * guix/tests.scm (with-environment-variable): ... here. * tests/build-utils.scm ("wrap-program, one input, multiple calls"): Use it instead of 'setenv'. --- guix/tests.scm | 15 +++++++++++++++ tests/build-utils.scm | 30 ++++++++++++++++-------------- tests/scripts.scm | 15 +-------------- 3 files changed, 32 insertions(+), 28 deletions(-) (limited to 'tests') diff --git a/guix/tests.scm b/guix/tests.scm index 749a4edd7a..35ebf8464d 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -39,6 +39,8 @@ (define-module (guix tests) canonical-file? network-reachable? shebang-too-long? + with-environment-variable + mock %test-substitute-urls test-assertm @@ -195,6 +197,19 @@ (define-syntax-rule (test-equalm name value exp) (run-with-store store exp #:guile-for-build (%guile-for-build))))) +(define-syntax-rule (with-environment-variable variable value body ...) + "Run BODY with VARIABLE set to VALUE." + (let ((orig (getenv variable))) + (dynamic-wind + (lambda () + (setenv variable value)) + (lambda () + body ...) + (lambda () + (if orig + (setenv variable orig) + (unsetenv variable)))))) + ;;; ;;; Narinfo files, as used by the substituter. diff --git a/tests/build-utils.scm b/tests/build-utils.scm index 7d49446f66..03216f9a35 100644 --- a/tests/build-utils.scm +++ b/tests/build-utils.scm @@ -107,19 +107,21 @@ (define-module (test-build-utils) ;; it can't know about the bootstrap bash in the store, since it's not ;; named "bash". Help it out a bit by providing a symlink it this ;; package's output. - (setenv "PATH" (dirname bash)) - (wrap-program foo `("GUIX_FOO" prefix ("hello"))) - (wrap-program foo `("GUIX_BAR" prefix ("world"))) - - ;; The bootstrap Bash is linked against an old libc and would abort with - ;; an assertion failure when trying to load incompatible locale data. - (unsetenv "LOCPATH") - - (let* ((pipe (open-input-pipe foo)) - (str (get-string-all pipe))) - (with-directory-excursion directory - (for-each delete-file '("foo" ".foo-real"))) - (and (zero? (close-pipe pipe)) - str)))))) + (with-environment-variable "PATH" (dirname bash) + (wrap-program foo `("GUIX_FOO" prefix ("hello"))) + (wrap-program foo `("GUIX_BAR" prefix ("world"))) + + ;; The bootstrap Bash is linked against an old libc and would abort + ;; with an assertion failure when trying to load incompatible locale + ;; data. + (unsetenv "LOCPATH") + + (let* ((pipe (open-input-pipe foo)) + (str (get-string-all pipe))) + (with-directory-excursion directory + (for-each delete-file '("foo" ".foo-real"))) + (and (zero? (close-pipe pipe)) + str))))))) + (test-end) diff --git a/tests/scripts.scm b/tests/scripts.scm index 3901710953..efee271197 100644 --- a/tests/scripts.scm +++ b/tests/scripts.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015 Ludovic Courtès +;;; Copyright © 2015, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,19 +25,6 @@ (define-module (test-scripts) ;; Test the (guix scripts) module. -(define-syntax-rule (with-environment-variable variable value body ...) - "Run BODY with VARIABLE set to VALUE." - (let ((orig (getenv variable))) - (dynamic-wind - (lambda () - (setenv variable value)) - (lambda () - body ...) - (lambda () - (if orig - (setenv variable orig) - (unsetenv variable)))))) - (test-begin "scripts") -- cgit v1.2.3 From f0cc5e7e1e4c03af29c5d4855dc5962502c49147 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 16 Mar 2019 17:07:57 +0100 Subject: booloader: Add 'invoke/quiet'. * gnu/build/bootloader.scm (G_): New macro. (open-pipe-with-stderr, invoke/quiet): New procedures. * tests/build-utils.scm ("invoke/quiet, success") ("invoke/quiet, failure") ("invoke/quiet, failure, message on stderr"): New tests. * po/guix/POTFILES.in: Add bootloader.scm. --- gnu/build/bootloader.scm | 63 +++++++++++++++++++++++++++++++++++++++++++++++- po/guix/POTFILES.in | 2 ++ tests/build-utils.scm | 22 ++++++++++++++++- 3 files changed, 85 insertions(+), 2 deletions(-) (limited to 'tests') diff --git a/gnu/build/bootloader.scm b/gnu/build/bootloader.scm index d00674dd40..c5febcde1e 100644 --- a/gnu/build/bootloader.scm +++ b/gnu/build/bootloader.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Mathieu Othacehe +;;; Copyright © 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,8 +18,15 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu build bootloader) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (ice-9 binary-ports) - #:export (write-file-on-device)) + #:use-module (ice-9 popen) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 format) + #:export (write-file-on-device + invoke/quiet)) ;;; @@ -35,3 +43,56 @@ (define (write-file-on-device file size device offset) (seek output offset SEEK_SET) (put-bytevector output bv)) #:binary #t))))) + +(define-syntax-rule (G_ str) str) ;for xgettext + +(define (open-pipe-with-stderr program . args) + "Run PROGRAM with ARGS in an input pipe, but, unlike 'open-pipe*', redirect +both its standard output and standard error to the pipe. Return two value: +the pipe to read PROGRAM's data from, and the PID of the child process running +PROGRAM." + ;; 'open-pipe*' doesn't attempt to capture stderr in any way, which is why + ;; we need to roll our own. + (match (pipe) + ((input . output) + (match (primitive-fork) + (0 + (dynamic-wind + (const #t) + (lambda () + (close-port input) + (dup2 (fileno output) 1) + (dup2 (fileno output) 2) + (apply execlp program program args)) + (lambda () + (primitive-exit 127)))) + (pid + (close-port output) + (values input pid)))))) + +;; TODO: Move to (guix build utils) on the next rebuild cycle. +(define (invoke/quiet program . args) + "Invoke PROGRAM with ARGS and capture PROGRAM's standard output and standard +error. If PROGRAM succeeds, print nothing and return the unspecified value; +otherwise, raise a '&message' error condition that includes the status code +and the output of PROGRAM." + (define-values (pipe pid) + (apply open-pipe-with-stderr program args)) + + (let loop ((lines '())) + (match (read-line pipe) + ((? eof-object?) + (close-port pipe) + (match (waitpid pid) + ((_ . status) + (unless (zero? status) + (raise (condition + (&message + (message (format #f (G_ "'~a~{ ~a~}' exited with status ~a; \ +output follows:~%~%~{ ~a~%~}") + program args + (or (status:exit-val status) + status) + (reverse lines)))))))))) + (line + (loop (cons line lines)))))) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index 07b73a770a..debff5ae8e 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -72,4 +72,6 @@ guix/channels.scm guix/profiles.scm guix/git.scm guix/deprecation.scm +gnu/build/bootloader.scm nix/nix-daemon/guix-daemon.cc + diff --git a/tests/build-utils.scm b/tests/build-utils.scm index 03216f9a35..46fe8ea2c0 100644 --- a/tests/build-utils.scm +++ b/tests/build-utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2015, 2016 Ludovic Courtès +;;; Copyright © 2012, 2015, 2016, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,11 +20,14 @@ (define-module (test-build-utils) #:use-module (guix tests) #:use-module (guix build utils) + #:use-module ((gnu build bootloader) + #:select (invoke/quiet)) #:use-module ((guix utils) #:select (%current-system call-with-temporary-directory)) #:use-module (gnu packages) #:use-module (gnu packages bootstrap) #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-64) #:use-module (rnrs io ports) #:use-module (ice-9 popen)) @@ -123,5 +126,22 @@ (define-module (test-build-utils) (and (zero? (close-pipe pipe)) str))))))) +(test-assert "invoke/quiet, success" + (begin + (invoke/quiet "true") + #t)) + +(test-assert "invoke/quiet, failure" + (guard (c ((message-condition? c) + (string-contains (condition-message c) "This is an error."))) + (invoke/quiet "sh" "-c" "echo This is an error. ; false") + #f)) + +(test-assert "invoke/quiet, failure, message on stderr" + (guard (c ((message-condition? c) + (string-contains (condition-message c) + "This is another error."))) + (invoke/quiet "sh" "-c" "echo This is another error. >&2 ; false") + #f)) (test-end) -- cgit v1.2.3 From 880916ac5228b9cfd6e65ac243d17f6bd12edaf9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Mar 2019 15:50:13 +0100 Subject: guix build: Add '--with-git-url'. * guix/scripts/build.scm (%not-equal): New variable. (evaluate-git-replacement-specs): Use it instead of local variable 'not-equal'. (transform-package-source-git-url): New procedure. (%transformations): Add 'with-git-url'. (%transformation-options, show-transformation-options-help): Add '--with-git-url'. * tests/scripts-build.scm ("options->transformation, with-git-url"): New test. --- doc/guix.texi | 34 +++++++++++++++++++++++----------- guix/scripts/build.scm | 47 ++++++++++++++++++++++++++++++++++++++++------- tests/scripts-build.scm | 24 +++++++++++++++++++++++- 3 files changed, 86 insertions(+), 19 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 5bbd0ee7f0..139a09d1bc 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7780,22 +7780,18 @@ must be compatible. If @var{replacement} is somehow incompatible with @var{package}, then the resulting package may be unusable. Use with care! -@item --with-branch=@var{package}=@var{branch} +@item --with-git-url=@var{package}=@var{url} @cindex Git, using the latest commit @cindex latest commit, building -Build @var{package} from the latest commit of @var{branch}. The @code{source} -field of @var{package} must be an origin with the @code{git-fetch} method -(@pxref{origin Reference}) or a @code{git-checkout} object; the repository URL -is taken from that @code{source}. Git sub-modules of the repository are -fetched, recursively. +Build @var{package} from the latest commit of the @code{master} branch of the +Git repository at @var{url}. -For instance, the following command builds @code{guile-sqlite3} from the -latest commit of its @code{master} branch, and then builds @code{guix} (which -depends on it) and @code{cuirass} (which depends on @code{guix}) against this -specific @code{guile-sqlite3} build: +For example, the following commands builds the GNU C Library (glibc) straight +from its Git repository instead of building the currently-packaged release: @example -guix build --with-branch=guile-sqlite3=master cuirass +guix build glibc \ + --with-git-url=glibc=git://sourceware.org/git/glibc.git @end example @cindex continuous integration @@ -7809,6 +7805,22 @@ Checkouts are kept in a cache under @file{~/.cache/guix/checkouts} to speed up consecutive accesses to the same repository. You may want to clean it up once in a while to save disk space. +@item --with-branch=@var{package}=@var{branch} +Build @var{package} from the latest commit of @var{branch}. The @code{source} +field of @var{package} must be an origin with the @code{git-fetch} method +(@pxref{origin Reference}) or a @code{git-checkout} object; the repository URL +is taken from that @code{source}. Git sub-modules of the repository are +fetched, recursively. + +For instance, the following command builds @code{guile-sqlite3} from the +latest commit of its @code{master} branch, and then builds @code{guix} (which +depends on it) and @code{cuirass} (which depends on @code{guix}) against this +specific @code{guile-sqlite3} build: + +@example +guix build --with-branch=guile-sqlite3=master cuirass +@end example + @item --with-commit=@var{package}=@var{commit} This is similar to @code{--with-branch}, except that it builds from @var{commit} rather than the tip of a branch. @var{commit} must be a valid diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 6b29c470fb..5883dbfb44 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -272,16 +272,16 @@ (define (replacement-pair old new) (rewrite obj) obj)))) +(define %not-equal + (char-set-complement (char-set #\=))) + (define (evaluate-git-replacement-specs specs proc) "Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list of package pairs, where (PROC PACKAGE URL BRANCH-OR-COMMIT) returns the replacement package. Raise an error if an element of SPECS uses invalid syntax, or if a package it refers to could not be found." - (define not-equal - (char-set-complement (char-set #\=))) - (map (lambda (spec) - (match (string-tokenize spec not-equal) + (match (string-tokenize spec %not-equal) ((name branch-or-commit) (let* ((old (specification->package name)) (source (package-source old)) @@ -341,6 +341,33 @@ (define (replace old url commit) (rewrite obj) obj)))) +(define (transform-package-source-git-url replacement-specs) + "Return a procedure that, when passed a package, replaces its dependencies +according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of strings like +\"guile-json=https://gitthing.com/…\" meaning that packages are built using +a checkout of the Git repository at the given URL." + ;; FIXME: Currently this cannot be combined with '--with-branch' or + ;; '--with-commit' because they all transform "from scratch". + (define replacements + (map (lambda (spec) + (match (string-tokenize spec %not-equal) + ((name url) + (let* ((old (specification->package name)) + (new (package + (inherit old) + (source (git-checkout (url url) + (recursive? #t)))))) + (cons old new))))) + replacement-specs)) + + (define rewrite + (package-input-rewriting replacements)) + + (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 @@ -350,7 +377,8 @@ (define %transformations (with-input . ,transform-package-inputs) (with-graft . ,transform-package-inputs/graft) (with-branch . ,transform-package-source-branch) - (with-commit . ,transform-package-source-commit))) + (with-commit . ,transform-package-source-commit) + (with-git-url . ,transform-package-source-git-url))) (define %transformation-options ;; The command-line interface to the above transformations. @@ -368,7 +396,9 @@ (define %transformation-options (option '("with-branch") #t #f (parser 'with-branch)) (option '("with-commit") #t #f - (parser 'with-commit))))) + (parser 'with-commit)) + (option '("with-git-url") #t #f + (parser 'with-git-url))))) (define (show-transformation-options-help) (display (G_ " @@ -385,7 +415,10 @@ (define (show-transformation-options-help) build PACKAGE from the latest commit of BRANCH")) (display (G_ " --with-commit=PACKAGE=COMMIT - build PACKAGE from COMMIT"))) + build PACKAGE from COMMIT")) + (display (G_ " + --with-git-url=PACKAGE=URL + build PACKAGE from the repository at URL"))) (define (options->transformation opts) diff --git a/tests/scripts-build.scm b/tests/scripts-build.scm index 190426ed06..54681274b9 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 Ludovic Courtès +;;; Copyright © 2016, 2017, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,6 +23,7 @@ (define-module (test-scripts-build) #:use-module (guix scripts build) #:use-module (guix ui) #:use-module (guix utils) + #:use-module (guix git) #:use-module (gnu packages) #:use-module (gnu packages base) #:use-module (gnu packages busybox) @@ -164,4 +165,25 @@ (define-module (test-scripts-build) ((("x" dep)) (eq? (package-replacement dep) findutils))))))))))) +(test-equal "options->transformation, with-git-url" + (let ((source (git-checkout (url "https://example.org") + (recursive? #t)))) + (list source source)) + (let* ((p (dummy-package "guix.scm" + (inputs `(("foo" ,grep) + ("bar" ,(dummy-package "chbouib" + (native-inputs `(("x" ,grep))))))))) + (t (options->transformation '((with-git-url . "grep=https://example.org"))))) + (with-store store + (let ((new (t store p))) + (and (not (eq? new p)) + (match (package-inputs new) + ((("foo" dep1) ("bar" dep2)) + (and (string=? (package-full-name dep1) + (package-full-name grep)) + (string=? (package-name dep2) "chbouib") + (match (package-native-inputs dep2) + ((("x" dep3)) + (map package-source (list dep1 dep3)))))))))))) + (test-end) -- cgit v1.2.3 From f258d8862852db9779945658b3a3f2b8a2a4c217 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Mar 2019 21:39:48 +0100 Subject: packages: Add 'package-input-rewriting/spec'. * guix/packages.scm (package-input-rewriting/spec): New procedure. * tests/packages.scm ("package-input-rewriting/spec") ("package-input-rewriting/spec, partial match"): New tests. * doc/guix.texi (Defining Packages): Document it. --- doc/guix.texi | 23 +++++++++++++++++++++++ guix/packages.scm | 38 ++++++++++++++++++++++++++++++++++++++ tests/packages.scm | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 112 insertions(+) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 139a09d1bc..6124c9c24c 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5241,6 +5241,29 @@ with @var{libressl}. Then we use it to define a @dfn{variant} of the This is exactly what the @option{--with-input} command-line option does (@pxref{Package Transformation Options, @option{--with-input}}). +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. +@end deffn + +The example above could be rewritten this way: + +@example +(define libressl-instead-of-openssl + ;; Replace all the packages called "openssl" with LibreSSL. + (package-input-rewriting/spec `(("openssl" . ,(const libressl))))) +@end example + +The key difference here is that, this time, packages are matched by spec and +not by identity. In other words, any package in the graph that is called +@code{openssl} will be replaced. + A more generic procedure to rewrite a package dependency graph is @code{package-mapping}: it supports arbitrary changes to nodes in the graph. diff --git a/guix/packages.scm b/guix/packages.scm index f191327718..d20a2562c3 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -102,6 +102,7 @@ (define-module (guix packages) package-transitive-supported-systems package-mapping package-input-rewriting + package-input-rewriting/spec package-source-derivation package-derivation package-cross-derivation @@ -869,6 +870,43 @@ (define (rewrite p) (package-mapping rewrite (cut assq <> replacements))) +(define (package-input-rewriting/spec replacements) + "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." + (define table + (fold (lambda (replacement table) + (match replacement + ((spec . proc) + (let-values (((name version) + (package-name->name+version spec))) + (vhash-cons name (list version proc) table))))) + vlist-null + replacements)) + + (define (find-replacement package) + (vhash-fold* (lambda (item proc) + (or proc + (match item + ((#f proc) + proc) + ((version proc) + (and (version-prefix? version + (package-version package)) + proc))))) + #f + (package-name package) + table)) + + (define (rewrite package) + (match (find-replacement package) + (#f package) + (proc (proc package)))) + + (package-mapping rewrite find-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 diff --git a/tests/packages.scm b/tests/packages.scm index 4e4bffc48c..613b2f1221 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -981,6 +981,57 @@ (define read-at ((("x" dep)) (eq? dep findutils))))))))) +(test-assert "package-input-rewriting/spec" + (let* ((dep (dummy-package "chbouib" + (native-inputs `(("x" ,grep))))) + (p0 (dummy-package "example" + (inputs `(("foo" ,coreutils) + ("bar" ,grep) + ("baz" ,dep))))) + (rewrite (package-input-rewriting/spec + `(("coreutils" . ,(const sed)) + ("grep" . ,(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) + ((("foo" dep1) ("bar" dep2) ("baz" dep3)) + (and (string=? (package-full-name dep1) + (package-full-name sed)) + (string=? (package-full-name dep2) + (package-full-name findutils)) + (string=? (package-name dep3) "chbouib") + (eq? dep3 (rewrite dep)) ;memoization + (match (package-native-inputs dep3) + ((("x" dep)) + (string=? (package-full-name dep) + (package-full-name findutils)))))))))) + +(test-assert "package-input-rewriting/spec, partial match" + (let* ((dep (dummy-package "chbouib" + (version "1") + (native-inputs `(("x" ,grep))))) + (p0 (dummy-package "example" + (inputs `(("foo" ,coreutils) + ("bar" ,dep))))) + (rewrite (package-input-rewriting/spec + `(("chbouib@123" . ,(const sed)) ;not matched + ("grep" . ,(const findutils))))) + (p1 (rewrite p0))) + (and (not (eq? p1 p0)) + (string=? "example" (package-name p1)) + (match (package-inputs p1) + ((("foo" dep1) ("bar" dep2)) + (and (string=? (package-full-name dep1) + (package-full-name coreutils)) + (eq? dep2 (rewrite dep)) ;memoization + (match (package-native-inputs dep2) + ((("x" dep)) + (string=? (package-full-name dep) + (package-full-name findutils)))))))))) + (test-equal "package-patched-vulnerabilities" '(("CVE-2015-1234") ("CVE-2016-1234" "CVE-2018-4567") -- cgit v1.2.3 From 14328b81a224b726f39dd030886ba8d332027427 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 13 Mar 2019 10:11:54 +0100 Subject: guix build: Transformation options match packages by spec. This allows us to combine several transformations on a given package, in particular '--with-git-url' and '--with-branch'. Previously transformations would ignore each other since they would all take (specification->package SOURCE) as their replacement source, compare it by identity, which doesn't work if a previous transformation has already changed SOURCE. * guix/scripts/build.scm (evaluate-replacement-specs): Adjust to produce an alist as expected by 'package-input-rewriting/spec', with a package spec as the first element of each pair. (evaluate-git-replacement-specs): Likewise. (transform-package-inputs): Adjust accordingly and use 'package-input-rewriting/spec'. (transform-package-inputs/graft): Likewise. (transform-package-source-branch, transform-package-source-commit): Use 'package-input-rewriting/spec'. (transform-package-source-git-url): Likewise, and adjust the REPLACEMENTS alist accordingly. (options->transformation): Iterate over OPTS instead of over %TRANSFORMATIONS. Invoke transformations one by one. * tests/scripts-build.scm ("options->transformation, with-input"): Adjust test to compare packages by name rather than by identity. ("options->transformation, with-git-url + with-branch"): New test. --- doc/guix.texi | 24 +++++++------ guix/scripts/build.scm | 90 +++++++++++++++++++++++++++---------------------- tests/scripts-build.scm | 36 ++++++++++++++++++-- 3 files changed, 97 insertions(+), 53 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 6124c9c24c..a3dd344a70 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7807,16 +7807,20 @@ care! @cindex Git, using the latest commit @cindex latest commit, building Build @var{package} from the latest commit of the @code{master} branch of the -Git repository at @var{url}. +Git repository at @var{url}. Git sub-modules of the repository are fetched, +recursively. -For example, the following commands builds the GNU C Library (glibc) straight -from its Git repository instead of building the currently-packaged release: +For example, the following command builds the NumPy Python library against the +latest commit of the master branch of Python itself: @example -guix build glibc \ - --with-git-url=glibc=git://sourceware.org/git/glibc.git +guix build python-numpy \ + --with-git-url=python=https://github.com/python/cpython @end example +This option can also be combined with @code{--with-branch} or +@code{--with-commit} (see below). + @cindex continuous integration Obviously, since it uses the latest commit of the given branch, the result of such a command varies over time. Nevertheless it is a convenient way to @@ -7829,11 +7833,11 @@ consecutive accesses to the same repository. You may want to clean it up once in a while to save disk space. @item --with-branch=@var{package}=@var{branch} -Build @var{package} from the latest commit of @var{branch}. The @code{source} -field of @var{package} must be an origin with the @code{git-fetch} method -(@pxref{origin Reference}) or a @code{git-checkout} object; the repository URL -is taken from that @code{source}. Git sub-modules of the repository are -fetched, recursively. +Build @var{package} from the latest commit of @var{branch}. If the +@code{source} field of @var{package} is an origin with the @code{git-fetch} +method (@pxref{origin Reference}) or a @code{git-checkout} object, the +repository URL is taken from that @code{source}. Otherwise you have to use +@code{--with-git-url} to specify the URL of the Git repository. For instance, the following command builds @code{guile-sqlite3} from the latest commit of its @code{master} branch, and then builds @code{guix} (which diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 7b24cc8eb1..8ebcf79243 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -226,18 +226,21 @@ (define new-sources obj))))) (define (evaluate-replacement-specs specs proc) - "Parse SPECS, a list of strings like \"guile=guile@2.1\", and invoke PROC on -each package pair specified by SPECS. Return the resulting list. Raise an -error if an element of SPECS uses invalid syntax, or if a package it refers to -could not be found." + "Parse SPECS, a list of strings like \"guile=guile@2.1\" and return a list +of package spec/procedure pairs as expected by 'package-input-rewriting/spec'. +PROC is called with the package to be replaced and its replacement according +to SPECS. Raise an error if an element of SPECS uses invalid syntax, or if a +package it refers to could not be found." (define not-equal (char-set-complement (char-set #\=))) (map (lambda (spec) (match (string-tokenize spec not-equal) - ((old new) - (proc (specification->package old) - (specification->package new))) + ((spec new) + (cons spec + (let ((new (specification->package new))) + (lambda (old) + (proc old new))))) (x (leave (G_ "invalid replacement specification: ~s~%") spec)))) specs)) @@ -248,8 +251,10 @@ (define (transform-package-inputs replacement-specs) strings like \"guile=guile@2.1\" meaning that, any dependency on a package called \"guile\" must be replaced with a dependency on a version 2.1 of \"guile\"." - (let* ((replacements (evaluate-replacement-specs replacement-specs cons)) - (rewrite (package-input-rewriting replacements))) + (let* ((replacements (evaluate-replacement-specs replacement-specs + (lambda (old new) + new))) + (rewrite (package-input-rewriting/spec replacements))) (lambda (store obj) (if (package? obj) (rewrite obj) @@ -260,13 +265,12 @@ (define (transform-package-inputs/graft replacement-specs) dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of strings like \"gnutls=gnutls@3.5.4\" meaning that packages are built using the current 'gnutls' package, after which version 3.5.4 is grafted onto them." - (define (replacement-pair old new) - (cons old - (package (inherit old) (replacement new)))) + (define (set-replacement old new) + (package (inherit old) (replacement new))) (let* ((replacements (evaluate-replacement-specs replacement-specs - replacement-pair)) - (rewrite (package-input-rewriting replacements))) + set-replacement)) + (rewrite (package-input-rewriting/spec replacements))) (lambda (store obj) (if (package? obj) (rewrite obj) @@ -295,11 +299,13 @@ (define (evaluate-git-replacement-specs specs proc) syntax, or if a package it refers to could not be found." (map (lambda (spec) (match (string-tokenize spec %not-equal) - ((name branch-or-commit) - (let* ((old (specification->package name)) - (source (package-source old)) - (url (package-git-url old))) - (cons old (proc old url branch-or-commit)))) + ((spec branch-or-commit) + (define (replace old) + (let* ((source (package-source old)) + (url (package-git-url old))) + (proc old url branch-or-commit))) + + (cons spec replace)) (x (leave (G_ "invalid replacement specification: ~s~%") spec)))) specs)) @@ -318,7 +324,7 @@ (define (replace old url branch) (let* ((replacements (evaluate-git-replacement-specs replacement-specs replace)) - (rewrite (package-input-rewriting replacements))) + (rewrite (package-input-rewriting/spec replacements))) (lambda (store obj) (if (package? obj) (rewrite obj) @@ -340,7 +346,7 @@ (define (replace old url commit) (let* ((replacements (evaluate-git-replacement-specs replacement-specs replace)) - (rewrite (package-input-rewriting replacements))) + (rewrite (package-input-rewriting/spec replacements))) (lambda (store obj) (if (package? obj) (rewrite obj) @@ -351,22 +357,20 @@ (define (transform-package-source-git-url replacement-specs) according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of strings like \"guile-json=https://gitthing.com/…\" meaning that packages are built using a checkout of the Git repository at the given URL." - ;; FIXME: Currently this cannot be combined with '--with-branch' or - ;; '--with-commit' because they all transform "from scratch". (define replacements (map (lambda (spec) (match (string-tokenize spec %not-equal) - ((name url) - (let* ((old (specification->package name)) - (new (package - (inherit old) - (source (git-checkout (url url) - (recursive? #t)))))) - (cons old new))))) + ((spec url) + (cons spec + (lambda (old) + (package + (inherit old) + (source (git-checkout (url url) + (recursive? #t))))))))) replacement-specs)) (define rewrite - (package-input-rewriting replacements)) + (package-input-rewriting/spec replacements)) (lambda (store obj) (if (package? obj) @@ -430,16 +434,22 @@ (define (options->transformation opts) "Return a procedure that, when passed an object to build (package, derivation, etc.), applies the transformations specified by OPTS." (define applicable - ;; List of applicable transformations as symbol/procedure pairs. + ;; List of applicable transformations as symbol/procedure pairs in the + ;; order in which they appear on the command line. (filter-map (match-lambda - ((key . transform) - (match (filter-map (match-lambda - ((k . arg) - (and (eq? k key) arg))) - opts) - (() #f) - (args (cons key (transform args)))))) - %transformations)) + ((key . value) + (match (any (match-lambda + ((k . proc) + (and (eq? k key) proc))) + %transformations) + (#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))))))) + (reverse opts))) (lambda (store obj) (fold (match-lambda* diff --git a/tests/scripts-build.scm b/tests/scripts-build.scm index 54681274b9..4bf1e1a719 100644 --- a/tests/scripts-build.scm +++ b/tests/scripts-build.scm @@ -139,12 +139,15 @@ (define-module (test-scripts-build) (and (not (eq? new p)) (match (package-inputs new) ((("foo" dep1) ("bar" dep2) ("baz" dep3)) - (and (eq? dep1 busybox) - (eq? dep2 findutils) + (and (string=? (package-full-name dep1) + (package-full-name busybox)) + (string=? (package-full-name dep2) + (package-full-name findutils)) (string=? (package-name dep3) "chbouib") (match (package-native-inputs dep3) ((("x" dep)) - (eq? dep findutils))))))))))) + (string=? (package-full-name dep) + (package-full-name findutils)))))))))))) (test-assert "options->transformation, with-graft" (let* ((p (dummy-package "guix.scm" @@ -186,4 +189,31 @@ (define-module (test-scripts-build) ((("x" dep3)) (map package-source (list dep1 dep3)))))))))))) +(test-equal "options->transformation, with-git-url + with-branch" + ;; Combine the two options and make sure the 'with-branch' transformation + ;; comes after the 'with-git-url' transformation. + (let ((source (git-checkout (url "https://example.org") + (branch "BRANCH") + (recursive? #t)))) + (list source source)) + (let* ((p (dummy-package "guix.scm" + (inputs `(("foo" ,grep) + ("bar" ,(dummy-package "chbouib" + (native-inputs `(("x" ,grep))))))))) + (t (options->transformation + (reverse '((with-git-url + . "grep=https://example.org") + (with-branch . "grep=BRANCH")))))) + (with-store store + (let ((new (t store p))) + (and (not (eq? new p)) + (match (package-inputs new) + ((("foo" dep1) ("bar" dep2)) + (and (string=? (package-name dep1) "grep") + (string=? (package-name dep2) "chbouib") + (match (package-native-inputs dep2) + ((("x" dep3)) + (map package-source (list dep1 dep3)))))))))))) + + (test-end) -- cgit v1.2.3 From 845c44012c2a05436dc0a5316ff3c2a9e5bd725f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 13 Mar 2019 10:26:31 +0100 Subject: guix build: '--with-commit' makes recursive checkouts. This was an omission from commit 024a6bfba906742c136a47b4099f06880f1d3f15. * guix/scripts/build.scm (transform-package-source-commit): Add 'recursive?' field to SOURCE. * tests/scripts-build.scm ("options->transformation, with-branch") ("options->transformation, with-commit"): New tests. --- guix/scripts/build.scm | 3 ++- tests/scripts-build.scm | 49 +++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 51 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 8ebcf79243..20929d6110 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -342,7 +342,8 @@ (define (replace old url commit) (if (< (string-length commit) 7) commit (string-take commit 7)))) - (source (git-checkout (url url) (commit commit))))) + (source (git-checkout (url url) (commit commit) + (recursive? #t))))) (let* ((replacements (evaluate-git-replacement-specs replacement-specs replace)) diff --git a/tests/scripts-build.scm b/tests/scripts-build.scm index 4bf1e1a719..32876e956a 100644 --- a/tests/scripts-build.scm +++ b/tests/scripts-build.scm @@ -20,6 +20,7 @@ (define-module (test-scripts-build) #:use-module (guix tests) #:use-module (guix store) #:use-module (guix packages) + #:use-module (guix git-download) #:use-module (guix scripts build) #:use-module (guix ui) #:use-module (guix utils) @@ -168,6 +169,54 @@ (define-module (test-scripts-build) ((("x" dep)) (eq? (package-replacement dep) findutils))))))))))) +(test-equal "options->transformation, with-branch" + (git-checkout (url "https://example.org") + (branch "devel") + (recursive? #t)) + (let* ((p (dummy-package "guix.scm" + (inputs `(("foo" ,grep) + ("bar" ,(dummy-package "chbouib" + (source (origin + (method git-fetch) + (uri (git-reference + (url "https://example.org") + (commit "cabba9e"))) + (sha256 #f))))))))) + (t (options->transformation '((with-branch . "chbouib=devel"))))) + (with-store store + (let ((new (t store p))) + (and (not (eq? new p)) + (match (package-inputs new) + ((("foo" dep1) ("bar" dep2)) + (and (string=? (package-full-name dep1) + (package-full-name grep)) + (string=? (package-name dep2) "chbouib") + (package-source dep2))))))))) + +(test-equal "options->transformation, with-commit" + (git-checkout (url "https://example.org") + (commit "abcdef") + (recursive? #t)) + (let* ((p (dummy-package "guix.scm" + (inputs `(("foo" ,grep) + ("bar" ,(dummy-package "chbouib" + (source (origin + (method git-fetch) + (uri (git-reference + (url "https://example.org") + (commit "cabba9e"))) + (sha256 #f))))))))) + (t (options->transformation '((with-commit . "chbouib=abcdef"))))) + (with-store store + (let ((new (t store p))) + (and (not (eq? new p)) + (match (package-inputs new) + ((("foo" dep1) ("bar" dep2)) + (and (string=? (package-full-name dep1) + (package-full-name grep)) + (string=? (package-name dep2) "chbouib") + (package-source dep2))))))))) + (test-equal "options->transformation, with-git-url" (let ((source (git-checkout (url "https://example.org") (recursive? #t)))) -- cgit v1.2.3 From 2b81eac01e5828c6fce61b3cafc0f78e7a0ab891 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 23 Mar 2019 15:04:44 +0100 Subject: graph: Add the 'reverse-bag' graph. Suggested by Julien Lepiller. * guix/scripts/graph.scm (%reverse-bag-node-type): New variable. (%node-types): Add it. * tests/graph.scm ("reverse bag DAG"): New test. * doc/guix.texi (Invoking guix graph): Document it. --- doc/guix.texi | 18 +++++++++++++++++- guix/scripts/graph.scm | 19 ++++++++++++++++++- tests/graph.scm | 28 +++++++++++++++++++++++++++- 3 files changed, 62 insertions(+), 3 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 94d7a29bdf..8fa714ee54 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -9290,7 +9290,9 @@ This shows the @emph{reverse} DAG of packages. For example: guix graph --type=reverse-package ocaml @end example -...@: yields the graph of packages that depend on OCaml. +...@: yields the graph of packages that @emph{explicitly} depend on OCaml (if +you are also interested in cases where OCaml is an implicit dependency, see +@code{reverse-bag} below.) Note that for core packages this can yield huge graphs. If all you want is to know the number of packages that depend on a given package, use @@ -9324,6 +9326,20 @@ dependencies. @item bag-with-origins Similar to @code{bag}, but also showing origins and their dependencies. +@item reverse-bag +This shows the @emph{reverse} DAG of packages. Unlike @code{reverse-package}, +it also takes implicit dependencies into account. For example: + +@example +guix graph -t reverse-bag dune +@end example + +@noindent +...@: yields the graph of all packages that depend on Dune, directly or +indirectly. Since Dune is an @emph{implicit} dependency of many packages +@i{via} @code{dune-build-system}, this shows a large number of packages, +whereas @code{reverse-package} would show very few if any. + @item derivation This is the most detailed representation: It shows the DAG of derivations (@pxref{Derivations}) and plain store items. Compared to diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 8efeef3274..d0d353ff9e 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -43,6 +43,7 @@ (define-module (guix scripts graph) %bag-node-type %bag-with-origins-node-type %bag-emerged-node-type + %reverse-bag-node-type %derivation-node-type %reference-node-type %referrer-node-type @@ -219,6 +220,21 @@ (define %bag-emerged-node-type bag-node-edges-sans-bootstrap) %store-monad)))) +(define %reverse-bag-node-type + ;; Type for the reverse traversal of package nodes via the "bag" + ;; representation, which includes implicit inputs. + (let* ((packages (delay (package-closure (fold-packages cons '())))) + (back-edges (delay (run-with-store #f ;store not actually needed + (node-back-edges %bag-node-type + (force packages)))))) + (node-type + (name "reverse-bag") + (description "the reverse DAG of packages, including implicit inputs") + (convert nodes-from-package) + (identifier bag-node-identifier) + (label node-full-name) + (edges (lift1 (force back-edges) %store-monad))))) + ;;; ;;; Derivation DAG. @@ -375,6 +391,7 @@ (define %node-types %bag-node-type %bag-with-origins-node-type %bag-emerged-node-type + %reverse-bag-node-type %derivation-node-type %reference-node-type %referrer-node-type diff --git a/tests/graph.scm b/tests/graph.scm index 4799d3bd0c..c4c5096226 100644 --- a/tests/graph.scm +++ b/tests/graph.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -191,6 +191,32 @@ (define (edge->tuple source target) (string=? target (derivation-file-name g))))) edges))))))))) +(test-assert "reverse bag DAG" + (let-values (((dune bap ocaml-base) + (values (specification->package "dune") + (specification->package "bap") + (specification->package "ocaml-base"))) + ((backend nodes+edges) (make-recording-backend))) + (run-with-store %store + (export-graph (list dune) 'port + #:node-type %reverse-bag-node-type + #:backend backend)) + + (run-with-store %store + (mlet %store-monad ((dune-drv (package->derivation dune)) + (bap-drv (package->derivation bap)) + (ocaml-base-drv (package->derivation ocaml-base))) + ;; OCAML-BASE uses 'dune-build-system' so DUNE is a direct dependency. + ;; BAP is much higher in the stack but it should be there. + (let-values (((nodes edges) (nodes+edges))) + (return + (and (member `(,(derivation-file-name bap-drv) + ,(package-full-name bap)) + nodes) + (->bool (member (map derivation-file-name + (list dune-drv ocaml-base-drv)) + edges))))))))) + (test-assert "derivation DAG" (let-values (((backend nodes+edges) (make-recording-backend))) (run-with-store %store -- cgit v1.2.3