From 11996d85d3cfa31ecf969421b4dc718b617bf2ff Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Fri, 22 Feb 2013 23:00:41 +0100 Subject: Patch-shebang: Handle "#!/usr/bin/env command" * guix/build/utils.scm (patch-shebang): Handle replacement of "#!.*/env CMD ARGS" by "#!/nix/store/path/.../to/CMD ARGS". --- guix/build/utils.scm | 32 ++++++++++++++++++++++---------- 1 file changed, 22 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/build/utils.scm b/guix/build/utils.scm index 6921e31bdd..f7fb7938e5 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2013 Andreas Enge ;;; ;;; This file is part of GNU Guix. ;;; @@ -51,7 +52,7 @@ fold-port-matches remove-store-references)) - + ;;; ;;; Directories. ;;; @@ -426,7 +427,7 @@ bytes transferred and the continuation of the transfer as a thunk." (stat:mtimensec stat))) (define patch-shebang - (let ((shebang-rx (make-regexp "^[[:blank:]]*([[:graph:]]+)(.*)$"))) + (let ((shebang-rx (make-regexp "^[[:blank:]]*([[:graph:]]+)[[:blank:]]*([[:graph:]]*)(.*)$"))) (lambda* (file #:optional (path (search-path-as-string->list (getenv "PATH"))) @@ -465,16 +466,27 @@ FILE are kept unchanged." (let ((line (false-if-exception (read-line p)))) (and=> (and line (regexp-exec shebang-rx line)) (lambda (m) - (let* ((cmd (match:substring m 1)) - (bin (search-path path (basename cmd)))) + (let* ((interp (match:substring m 1)) + (arg1 (match:substring m 2)) + (rest (match:substring m 3)) + (has-env (string-suffix? "/env" interp)) + (cmd (if has-env arg1 (basename interp))) + (bin (search-path path cmd))) (if bin - (if (string=? bin cmd) + (if (string=? bin interp) #f ; nothing to do - (begin - (format (current-error-port) - "patch-shebang: ~a: changing `~a' to `~a'~%" - file cmd bin) - (patch p bin (match:substring m 2)))) + (if has-env + (begin + (format (current-error-port) + "patch-shebang: ~a: changing `~a' to `~a'~%" + file (string-append interp " " arg1) bin) + (patch p bin rest)) + (begin + (format (current-error-port) + "patch-shebang: ~a: changing `~a' to `~a'~%" + file interp bin) + (patch p bin + (string-append " " arg1 rest))))) (begin (format (current-error-port) "patch-shebang: ~a: warning: no binary for interpreter `~a' found in $PATH~%" -- cgit v1.2.3 From ca8def6e6fd9670affe8eb489c47d460e46e8061 Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Sat, 23 Feb 2013 23:27:46 +0100 Subject: Patch-shebang: Do not add space after interpreter without argument. * guix/build/utils.scm (patch-shebang): Do not add a space after a command interpreter not followed by an argument; this made two tests of coreutils fail. --- guix/build/utils.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/utils.scm b/guix/build/utils.scm index f7fb7938e5..d17346607f 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -486,7 +486,9 @@ FILE are kept unchanged." "patch-shebang: ~a: changing `~a' to `~a'~%" file interp bin) (patch p bin - (string-append " " arg1 rest))))) + (if (string-null? arg1) + "" + (string-append " " arg1 rest)))))) (begin (format (current-error-port) "patch-shebang: ~a: warning: no binary for interpreter `~a' found in $PATH~%" -- cgit v1.2.3 From 6c7b6a51a4ea8fd05b85a5227c2333d4d9026f38 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 12 Feb 2013 12:02:15 -0500 Subject: Add version-compare and version>? to utils.scm. * guix/utils.scm (version-compare, version>?): New exported procedures, based on version-string>?, which was formerly in gnu-maintenance.scm. * guix/gnu-maintenance.scm (version-string>?): Removed procedure. (latest-release): Use 'version>?' instead of 'version-string>?'. --- guix/gnu-maintenance.scm | 12 ++---------- guix/utils.scm | 20 ++++++++++++++++++++ 2 files changed, 22 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index c934694147..6475c386d3 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -28,6 +28,7 @@ #:use-module (srfi srfi-26) #:use-module (system foreign) #:use-module (guix ftp-client) + #:use-module (guix utils) #:export (official-gnu-packages releases latest-release @@ -156,21 +157,12 @@ pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). files) result))))))) -(define version-string>? - (let ((strverscmp - (let ((sym (or (dynamic-func "strverscmp" (dynamic-link)) - (error "could not find `strverscmp' (from GNU libc)")))) - (pointer->procedure int sym (list '* '*))))) - (lambda (a b) - "Return #t when B denotes a newer version than A." - (> (strverscmp (string->pointer a) (string->pointer b)) 0)))) - (define (latest-release project) "Return (\"FOO-X.Y\" . \"/bar/foo\") or #f." (let ((releases (releases project))) (and (not (null? releases)) (fold (lambda (release latest) - (if (version-string>? (car release) (car latest)) + (if (version>? (car release) (car latest)) release latest)) '("" . "") diff --git a/guix/utils.scm b/guix/utils.scm index 7ab835e7f1..d7c37e37d1 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -57,6 +57,8 @@ gnu-triplet->nix-system %current-system + version-compare + version>? package-name->name+version)) @@ -422,6 +424,24 @@ returned by `config.guess'." ;; By default, this is equal to (gnu-triplet->nix-system %host-type). (make-parameter %system)) +(define version-compare + (let ((strverscmp + (let ((sym (or (dynamic-func "strverscmp" (dynamic-link)) + (error "could not find `strverscmp' (from GNU libc)")))) + (pointer->procedure int sym (list '* '*))))) + (lambda (a b) + "Return '> when A denotes a newer version than B, +'< when A denotes a older version than B, +or '= when they denote equal versions." + (let ((result (strverscmp (string->pointer a) (string->pointer b)))) + (cond ((positive? result) '>) + ((negative? result) '<) + (else '=)))))) + +(define (version>? a b) + "Return #t when A denotes a newer version than B." + (eq? '> (version-compare a b))) + (define (package-name->name+version name) "Given NAME, a package name like \"foo-0.9.1b\", return two values: \"foo\" and \"0.9.1b\". When the version part is unavailable, NAME and -- cgit v1.2.3 From 790b8e0ebe63ae8d042327e6b1422c951166eb07 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 14 Feb 2013 00:14:29 +0100 Subject: build-system/gnu: Make the strip behavior of `static-package' configurable. * guix/build-system/gnu.scm (static-package): Add #:strip-all? keyword parameter. --- guix/build-system/gnu.scm | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index 82f5bb8490..5be4782c2f 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -111,20 +111,24 @@ flags for VARIABLE, the associated value is augmented." "A version of P linked with `-static-gcc'." (package-with-extra-configure-variable p "LDFLAGS" "-static-libgcc")) -(define* (static-package p #:optional (loc (current-source-location))) - "Return a statically-linked version of package P." +(define* (static-package p #:optional (loc (current-source-location)) + #:key (strip-all? #t)) + "Return a statically-linked version of package P. If STRIP-ALL? is true, +use `--strip-all' as the arguments to `strip'." (let ((args (package-arguments p))) (package (inherit p) (location (source-properties->location loc)) (arguments (let ((a (default-keyword-arguments args '(#:configure-flags '() - #:strip-flags #f)))) + #:strip-flags '("--strip-debug"))))) (substitute-keyword-arguments a ((#:configure-flags flags) `(cons* "--disable-shared" "LDFLAGS=-static" ,flags)) - ((#:strip-flags _) - ''("--strip-all")))))))) + ((#:strip-flags flags) + (if strip-all? + ''("--strip-all") + flags)))))))) (define %store -- cgit v1.2.3 From 5f7c5a97ba0a30b7fcdcbdf330efa4800c7bce90 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 16 Feb 2013 01:37:26 +0100 Subject: packages: Add `package-output'. * guix/packages.scm (package-output): New procedure. * tests/packages.scm ("package-output"): New test. --- guix/packages.scm | 13 +++++++++++++ tests/packages.scm | 9 ++++++++- 2 files changed, 21 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index b372f03818..51984baa3b 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -20,10 +20,12 @@ #:use-module (guix utils) #:use-module (guix store) #:use-module (guix base32) + #:use-module (guix derivations) #:use-module (guix build-system) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:re-export (%current-system) @@ -62,6 +64,7 @@ package-source-derivation package-derivation package-cross-derivation + package-output &package-error package-error? @@ -305,3 +308,13 @@ PACKAGE for SYSTEM." (define* (package-cross-derivation store package) ;; TODO #f) + +(define* (package-output store package output + #:optional (system (%current-system))) + "Return the output path of PACKAGE's OUTPUT for SYSTEM---where OUTPUT is the +symbolic output name, such as \"out\". Note that this procedure calls +`package-derivation', which is costly." + (let-values (((_ drv) + (package-derivation store package system))) + (derivation-output-path + (assoc-ref (derivation-outputs drv) output)))) diff --git a/tests/packages.scm b/tests/packages.scm index 32ee558518..f441532d22 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -71,7 +71,7 @@ ("d" ,d) ("d/x" "something.drv")) (pk 'x (package-transitive-inputs e)))))) -(test-skip (if (not %store) 3 0)) +(test-skip (if (not %store) 4 0)) (test-assert "return values" (let-values (((drv-path drv) @@ -79,6 +79,13 @@ (and (derivation-path? drv-path) (derivation? drv)))) +(test-assert "package-output" + (let* ((package (dummy-package "p")) + (drv-path (package-derivation %store package))) + (and (derivation-path? drv-path) + (string=? (derivation-path->output-path drv-path) + (package-output %store package "out"))))) + (test-assert "trivial" (let* ((p (package (inherit (dummy-package "trivial")) (build-system trivial-build-system) -- cgit v1.2.3 From 868c923f13e6ed95e1e5ad2bd32d4166842254ea Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 14 Feb 2013 04:15:25 -0500 Subject: Replace individual scripts with master 'guix' script. * scripts/guix.in: New script. * Makefile.am (bin_SCRIPTS): Add 'scripts/guix'. Remove 'guix-build', 'guix-download', 'guix-import', 'guix-package', and 'guix-gc'. (MODULES): Add 'guix/scripts/build.scm', 'guix/scripts/download.scm', 'guix/scripts/import.scm', 'guix/scripts/package.scm', and 'guix/scripts/gc.scm'. * configure.ac (AC_CONFIG_FILES): Add 'scripts/guix'. Remove 'guix-build', 'guix-download', 'guix-import', 'guix-package', and 'guix-gc'. * guix-build.in, guix-download.in, guix-gc.in, guix-import.in, guix-package.in: Remove shell script boilerplate. Move to guix-COMMAND.in to guix/scripts/COMMAND.scm. Rename module from (guix-COMMAND) to (guix scripts COMMAND). Change "guix-COMMAND" to "guix COMMAND" in usage help string. * pre-inst-env.in: Add "@abs_top_builddir@/scripts" to the front of $PATH. Export $GUIX_UNINSTALLED. * tests/guix-build.sh, tests/guix-daemon.sh, tests/guix-download.sh, tests/guix-gc.sh, tests/guix-package.sh: Use "guix COMMAND" instead of "guix-COMMAND". * doc/guix.texi: Replace all occurrences of "guix-COMMAND" with "guix COMMAND". * po/POTFILES.in: Update. --- .gitignore | 6 +- Makefile.am | 11 +- configure.ac | 9 +- doc/guix.texi | 82 +++--- guix-build.in | 317 --------------------- guix-download.in | 164 ----------- guix-gc.in | 183 ------------ guix-import.in | 137 --------- guix-package.in | 706 ---------------------------------------------- guix/scripts/build.scm | 304 ++++++++++++++++++++ guix/scripts/download.scm | 151 ++++++++++ guix/scripts/gc.scm | 165 +++++++++++ guix/scripts/import.scm | 124 ++++++++ guix/scripts/package.scm | 693 +++++++++++++++++++++++++++++++++++++++++++++ guix/ui.scm | 38 ++- po/POTFILES.in | 8 +- pre-inst-env.in | 11 +- scripts/guix.in | 56 ++++ tests/guix-build.sh | 26 +- tests/guix-daemon.sh | 6 +- tests/guix-download.sh | 12 +- tests/guix-gc.sh | 24 +- tests/guix-package.sh | 56 ++-- 23 files changed, 1654 insertions(+), 1635 deletions(-) delete mode 100644 guix-build.in delete mode 100644 guix-download.in delete mode 100644 guix-gc.in delete mode 100644 guix-import.in delete mode 100644 guix-package.in create mode 100644 guix/scripts/build.scm create mode 100644 guix/scripts/download.scm create mode 100644 guix/scripts/gc.scm create mode 100644 guix/scripts/import.scm create mode 100644 guix/scripts/package.scm create mode 100644 scripts/guix.in (limited to 'guix') diff --git a/.gitignore b/.gitignore index ecdaed2ef0..302e473fd8 100644 --- a/.gitignore +++ b/.gitignore @@ -34,7 +34,6 @@ config.cache /po/remove-potcdate.sin /po/stamp-po /po/guix.pot -/guix-build /tests/*.trs /INSTALL /m4/* @@ -44,12 +43,9 @@ config.cache /doc/guix.pdf /doc/stamp-vti /doc/version.texi -/guix-download /gnu/packages/bootstrap/x86_64-linux/guile-2.0.7.tar.xz /gnu/packages/bootstrap/i686-linux/guile-2.0.7.tar.xz -/guix-package /guix/config.scm -/guix-import /nix/nix-daemon/nix-daemon.cc /nix/config.h /nix/config.h.in @@ -64,7 +60,7 @@ stamp-h[0-9] /nix/scripts/list-runtime-roots /test-env /nix/nix-setuid-helper/nix-setuid-helper.cc -/guix-gc +/scripts/guix /doc/guix.aux /doc/guix.cp /doc/guix.cps diff --git a/Makefile.am b/Makefile.am index 7a1b6ad163..5932e1350a 100644 --- a/Makefile.am +++ b/Makefile.am @@ -18,17 +18,18 @@ # along with GNU Guix. If not, see . bin_SCRIPTS = \ - guix-build \ - guix-download \ - guix-import \ - guix-package \ - guix-gc + scripts/guix nodist_noinst_SCRIPTS = \ pre-inst-env \ test-env MODULES = \ + guix/scripts/build.scm \ + guix/scripts/download.scm \ + guix/scripts/import.scm \ + guix/scripts/package.scm \ + guix/scripts/gc.scm \ guix/base32.scm \ guix/utils.scm \ guix/derivations.scm \ diff --git a/configure.ac b/configure.ac index a9cf17ac57..dd1f843afb 100644 --- a/configure.ac +++ b/configure.ac @@ -117,14 +117,9 @@ AC_CONFIG_FILES([Makefile po/Makefile.in guix/config.scm]) -AC_CONFIG_FILES([guix-build - guix-download - guix-import - guix-package - guix-gc +AC_CONFIG_FILES([scripts/guix pre-inst-env test-env], - [chmod +x guix-build guix-download guix-import guix-package guix-gc \ - pre-inst-env test-env]) + [chmod +x scripts/guix pre-inst-env test-env]) AC_OUTPUT diff --git a/doc/guix.texi b/doc/guix.texi index 80149326c1..f84b37686a 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -13,9 +13,9 @@ @dircategory Package management @direntry * guix: (guix). Guix, the functional package manager. -* guix-package: (guix)Invoking guix-package +* guix package: (guix)Invoking guix package Managing packages with Guix. -* guix-build: (guix)Invoking guix-build +* guix build: (guix)Invoking guix build Building packages with Guix. @end direntry @@ -196,7 +196,7 @@ are all performed by a specialized process, the @dfn{Guix daemon}, on behalf of clients. Only the daemon may access the store and its associated database. Thus, any operation that manipulates the store goes through the daemon. For instance, command-line tools such as -@command{guix-package} and @command{guix-build} communicate with the +@command{guix package} and @command{guix build} communicate with the daemon (@i{via} remote procedure calls) to instruct it what to do. In a standard multi-user setup, Guix and its daemon---the @@ -302,8 +302,8 @@ Use @var{n} CPU cores to build each derivation; @code{0} means as many as available. The default value is @code{1}, but it may be overridden by clients, such -as the @code{--cores} option of @command{guix-build} (@pxref{Invoking -guix-build}). +as the @code{--cores} option of @command{guix build} (@pxref{Invoking +guix build}). The effect is to define the @code{NIX_BUILD_CORES} environment variable in the build process, which can then use it to exploit internal @@ -319,7 +319,7 @@ Produce debugging output. This is useful to debug daemon start-up issues, but then it may be overridden by clients, for example the @code{--verbosity} option of -@command{guix-build} (@pxref{Invoking guix-build}). +@command{guix build} (@pxref{Invoking guix build}). @item --chroot-directory=@var{dir} Add @var{dir} to the build chroot. @@ -384,8 +384,8 @@ management tools it provides. @menu * Features:: How Guix will make your life brighter. -* Invoking guix-package:: Package installation, removal, etc. -* Invoking guix-gc:: Running the garbage collector. +* Invoking guix package:: Package installation, removal, etc. +* Invoking guix gc:: Running the garbage collector. @end menu @node Features @@ -408,14 +408,14 @@ simply continues to point to @file{/nix/store/@dots{}-gcc-4.8.0/bin/gcc}---i.e., both versions of GCC coexist on the same system without any interference. -The @command{guix-package} command is the central tool to manage -packages (@pxref{Invoking guix-package}). It operates on those per-user +The @command{guix package} command is the central tool to manage +packages (@pxref{Invoking guix package}). It operates on those per-user profiles, and can be used @emph{with normal user privileges}. The command provides the obvious install, remove, and upgrade operations. Each invocation is actually a @emph{transaction}: either the specified operation succeeds, or nothing happens. Thus, if the -@command{guix-package} process is terminated during the transaction, +@command{guix package} process is terminated during the transaction, or if a power outage occurs during the transaction, then the user's profile remains in its previous state, and remains usable. @@ -427,7 +427,7 @@ of their profile, which was known to work well. All those packages in the package store may be @emph{garbage-collected}. Guix can determine which packages are still referenced by the user profiles, and remove those that are provably no longer referenced -(@pxref{Invoking guix-gc}). Users may also explicitly remove old +(@pxref{Invoking guix gc}). Users may also explicitly remove old generations of their profile so that the packages they refer to can be collected. @@ -447,17 +447,17 @@ details.}. When a pre-built binary for a @file{/nix/store} path is available from an external source, Guix just downloads it; otherwise, it builds the package from source, locally. -@node Invoking guix-package -@section Invoking @command{guix-package} +@node Invoking guix package +@section Invoking @command{guix package} -The @command{guix-package} command is the tool that allows users to +The @command{guix package} command is the tool that allows users to install, upgrade, and remove packages, as well as rolling back to previous configurations. It operates only on the user's own profile, and works with normal user privileges (@pxref{Features}). Its syntax is: @example -guix-package @var{options} +guix package @var{options} @end example Primarily, @var{options} specifies the operations to be performed during @@ -473,13 +473,13 @@ variable, and so on. In a multi-user setup, user profiles must be stored in a place registered as a @dfn{garbage-collector root}, which -@file{$HOME/.guix-profile} points to (@pxref{Invoking guix-gc}). That +@file{$HOME/.guix-profile} points to (@pxref{Invoking guix gc}). That directory is normally @code{@var{localstatedir}/profiles/per-user/@var{user}}, where @var{localstatedir} is the value passed to @code{configure} as @code{--localstatedir}, and @var{user} is the user name. It must be created by @code{root}, with @var{user} as the owner. When it does not -exist, @command{guix-package} emits an error about it. +exist, @command{guix package} emits an error about it. The @var{options} can be among the following: @@ -548,7 +548,7 @@ useful to distribution developers. @end table -In addition to these actions @command{guix-package} supports the +In addition to these actions @command{guix package} supports the following options to query the current state of a profile, or the availability of packages: @@ -565,7 +565,7 @@ This allows specific fields to be extracted using the @command{recsel} command, for instance: @example -$ guix-package -s malloc | recsel -p name,version +$ guix package -s malloc | recsel -p name,version name: glibc version: 2.17 @@ -599,22 +599,22 @@ source location of its definition. @end table -@node Invoking guix-gc -@section Invoking @command{guix-gc} +@node Invoking guix gc +@section Invoking @command{guix gc} @cindex garbage collector Packages that are installed but not used may be @dfn{garbage-collected}. -The @command{guix-gc} command allows users to explicitly run the garbage +The @command{guix gc} command allows users to explicitly run the garbage collector to reclaim space from the @file{/nix/store} directory. The garbage collector has a set of known @dfn{roots}: any file under @file{/nix/store} reachable from a root is considered @dfn{live} and cannot be deleted; any other file is considered @dfn{dead} and may be deleted. The set of garbage collector roots includes default user -profiles, and may be augmented with @command{guix-build --root}, for -example (@pxref{Invoking guix-build}). +profiles, and may be augmented with @command{guix build --root}, for +example (@pxref{Invoking guix build}). -The @command{guix-gc} command has three modes of operation: it can be +The @command{guix gc} command has three modes of operation: it can be used to garbage-collect any dead files (the default), to delete specific files (the @code{--delete} option), or to print garbage-collector information. The available options are listed below: @@ -737,7 +737,7 @@ The @code{sha256} field specifies the expected SHA256 hash of the file being downloaded. It is mandatory, and allows Guix to check the integrity of the file. The @code{(base32 @dots{})} form introduces the base32 representation of the hash. A convenient way to obtain this -information is with the @code{guix-download} tool. +information is with the @code{guix download} tool. @item @cindex GNU Build System @@ -795,9 +795,9 @@ Guile process launched by the daemon (@pxref{Derivations}). Once a package definition is in place@footnote{Simple package definitions like the one above may be automatically converted from the -Nixpkgs distribution using the @command{guix-import} command.}, the -package may actually be built using the @code{guix-build} command-line -tool (@pxref{Invoking guix-build}). +Nixpkgs distribution using the @command{guix import} command.}, the +package may actually be built using the @code{guix build} command-line +tool (@pxref{Invoking guix build}). Behind the scenes, a derivation corresponding to the @code{} object is first computed by the @code{package-derivation} procedure. @@ -1015,22 +1015,22 @@ space. @chapter Utilities @menu -* Invoking guix-build:: Building packages from the command line. +* Invoking guix build:: Building packages from the command line. @end menu -@node Invoking guix-build -@section Invoking @command{guix-build} +@node Invoking guix build +@section Invoking @command{guix build} -The @command{guix-build} command builds packages or derivations and +The @command{guix build} command builds packages or derivations and their dependencies, and prints the resulting store paths. Note that it does not modify the user's profile---this is the job of the -@command{guix-package} command (@pxref{Invoking guix-package}). Thus, +@command{guix package} command (@pxref{Invoking guix package}). Thus, it is mainly useful for distribution developers. The general syntax is: @example -guix-build @var{options} @var{package-or-derivation}@dots{} +guix build @var{options} @var{package-or-derivation}@dots{} @end example @var{package-or-derivation} may be either the name of a package found in @@ -1058,7 +1058,7 @@ version 1.8 of Guile. Build the packages' source derivations, rather than the packages themselves. -For instance, @code{guix-build -S gcc} returns something like +For instance, @code{guix build -S gcc} returns something like @file{/nix/store/@dots{}-gcc-4.7.2.tar.bz2}, which is GCC's source tarball. @item --system=@var{system} @@ -1106,7 +1106,7 @@ may be helpful when debugging setup issues with the build daemon. @end table -Behind the scenes, @command{guix-build} is essentially an interface to +Behind the scenes, @command{guix build} is essentially an interface to the @code{package-derivation} procedure of the @code{(guix packages)} module, and to the @code{build-derivations} procedure of the @code{(guix store)} module. @@ -1121,11 +1121,11 @@ Guix comes with a distribution of free software@footnote{The term users of that software}.} that form the basis of the GNU system. This includes core GNU packages such as GNU libc, GCC, and Binutils, as well as many GNU and non-GNU applications. The complete list of available -packages can be seen by running @command{guix-package} (@pxref{Invoking -guix-package}): +packages can be seen by running @command{guix package} (@pxref{Invoking +guix package}): @example -guix-package --list-available +guix package --list-available @end example The package definitions of the distribution may are provided by Guile diff --git a/guix-build.in b/guix-build.in deleted file mode 100644 index 35ddb00861..0000000000 --- a/guix-build.in +++ /dev/null @@ -1,317 +0,0 @@ -#!/bin/sh -# aside from this initial boilerplate, this is actually -*- scheme -*- code - -prefix="@prefix@" -datarootdir="@datarootdir@" - -GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH" -export GUILE_LOAD_COMPILED_PATH - -main='(module-ref (resolve-interface '\''(guix-build)) '\'guix-build')' -exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \ - -c "(apply $main (cdr (command-line)))" "$@" -!# -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès -;;; Copyright © 2013 Mark H Weaver -;;; -;;; This file is part of GNU Guix. -;;; -;;; 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 . - -(define-module (guix-build) - #:use-module (guix ui) - #:use-module (guix store) - #:use-module (guix derivations) - #:use-module (guix packages) - #:use-module (guix utils) - #:use-module (ice-9 format) - #:use-module (ice-9 match) - #:use-module (ice-9 vlist) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-34) - #:use-module (srfi srfi-37) - #:autoload (gnu packages) (find-packages-by-name - find-newest-available-packages) - #:export (guix-build)) - -(define %store - (make-parameter #f)) - -(define (derivations-from-package-expressions exp system source?) - "Eval EXP and return the corresponding derivation path for SYSTEM. -When SOURCE? is true, return the derivations of the package sources." - (let ((p (eval exp (current-module)))) - (if (package? p) - (if source? - (let ((source (package-source p)) - (loc (package-location p))) - (if source - (package-source-derivation (%store) source) - (leave (_ "~a: error: package `~a' has no source~%") - (location->string loc) (package-name p)))) - (package-derivation (%store) p system)) - (leave (_ "expression `~s' does not evaluate to a package~%") - exp)))) - - -;;; -;;; Command-line options. -;;; - -(define %default-options - ;; Alist of default option values. - `((system . ,(%current-system)) - (substitutes? . #t) - (verbosity . 0))) - -(define (show-help) - (display (_ "Usage: guix-build [OPTION]... PACKAGE-OR-DERIVATION... -Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) - (display (_ " - -e, --expression=EXPR build the package EXPR evaluates to")) - (display (_ " - -S, --source build the packages' source derivations")) - (display (_ " - -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) - (display (_ " - -d, --derivations return the derivation paths of the given packages")) - (display (_ " - -K, --keep-failed keep build tree of failed builds")) - (display (_ " - -n, --dry-run do not build the derivations")) - (display (_ " - --no-substitutes build instead of resorting to pre-built substitutes")) - (display (_ " - -c, --cores=N allow the use of up to N CPU cores for the build")) - (display (_ " - -r, --root=FILE make FILE a symlink to the result, and register it - as a garbage collector root")) - (display (_ " - --verbosity=LEVEL use the given verbosity LEVEL")) - (newline) - (display (_ " - -h, --help display this help and exit")) - (display (_ " - -V, --version display version information and exit")) - (newline) - (show-bug-report-information)) - -(define %options - ;; Specifications of the command-line options. - (list (option '(#\h "help") #f #f - (lambda args - (show-help) - (exit 0))) - (option '(#\V "version") #f #f - (lambda args - (show-version-and-exit "guix-build"))) - - (option '(#\S "source") #f #f - (lambda (opt name arg result) - (alist-cons 'source? #t result))) - (option '(#\s "system") #t #f - (lambda (opt name arg result) - (alist-cons 'system arg - (alist-delete 'system result eq?)))) - (option '(#\d "derivations") #f #f - (lambda (opt name arg result) - (alist-cons 'derivations-only? #t result))) - (option '(#\e "expression") #t #f - (lambda (opt name arg result) - (alist-cons 'expression - (call-with-input-string arg read) - result))) - (option '(#\K "keep-failed") #f #f - (lambda (opt name arg result) - (alist-cons 'keep-failed? #t result))) - (option '(#\c "cores") #t #f - (lambda (opt name arg result) - (let ((c (false-if-exception (string->number arg)))) - (if c - (alist-cons 'cores c result) - (leave (_ "~a: not a number~%") arg))))) - (option '(#\n "dry-run") #f #f - (lambda (opt name arg result) - (alist-cons 'dry-run? #t result))) - (option '("no-substitutes") #f #f - (lambda (opt name arg result) - (alist-cons 'substitutes? #f - (alist-delete 'substitutes? result)))) - (option '(#\r "root") #t #f - (lambda (opt name arg result) - (alist-cons 'gc-root arg result))) - (option '("verbosity") #t #f - (lambda (opt name arg result) - (let ((level (string->number arg))) - (alist-cons 'verbosity level - (alist-delete 'verbosity result))))))) - - -;;; -;;; Entry point. -;;; - -(define (guix-build . args) - (define (parse-options) - ;; Return the alist of option values. - (args-fold args %options - (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) - (lambda (arg result) - (alist-cons 'argument arg result)) - %default-options)) - - (define (register-root paths root) - ;; Register ROOT as an indirect GC root for all of PATHS. - (let* ((root (string-append (canonicalize-path (dirname root)) - "/" root))) - (catch 'system-error - (lambda () - (match paths - ((path) - (symlink path root) - (add-indirect-root (%store) root)) - ((paths ...) - (fold (lambda (path count) - (let ((root (string-append root "-" (number->string count)))) - (symlink path root) - (add-indirect-root (%store) root)) - (+ 1 count)) - 0 - paths)))) - (lambda args - (format (current-error-port) - (_ "failed to create GC root `~a': ~a~%") - root (strerror (system-error-errno args))) - (exit 1))))) - - (define newest-available-packages - (memoize find-newest-available-packages)) - - (define (find-best-packages-by-name name version) - (if version - (find-packages-by-name name version) - (match (vhash-assoc name (newest-available-packages)) - ((_ version pkgs ...) pkgs) - (#f '())))) - - (define (find-package request) - ;; Return a package matching REQUEST. REQUEST may be a package - ;; name, or a package name followed by a hyphen and a version - ;; number. If the version number is not present, return the - ;; preferred newest version. - (let-values (((name version) - (package-name->name+version request))) - (match (find-best-packages-by-name name version) - ((p) ; one match - p) - ((p x ...) ; several matches - (format (current-error-port) - (_ "warning: ambiguous package specification `~a'~%") - request) - (format (current-error-port) - (_ "warning: choosing ~a from ~a~%") - (package-full-name p) - (location->string (package-location p))) - p) - (_ ; no matches - (if version - (leave (_ "~A: package not found for version ~a~%") - name version) - (leave (_ "~A: unknown package~%") name)))))) - - (install-locale) - (textdomain "guix") - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - - (with-error-handling - (let ((opts (parse-options))) - (parameterize ((%store (open-connection))) - (let* ((src? (assoc-ref opts 'source?)) - (sys (assoc-ref opts 'system)) - (drv (filter-map (match-lambda - (('expression . exp) - (derivations-from-package-expressions exp sys - src?)) - (('argument . (? derivation-path? drv)) - drv) - (('argument . (? string? x)) - (let ((p (find-package x))) - (if src? - (let ((s (package-source p))) - (package-source-derivation - (%store) s)) - (package-derivation (%store) p sys)))) - (_ #f)) - opts)) - (req (append-map (lambda (drv-path) - (let ((d (call-with-input-file drv-path - read-derivation))) - (derivation-prerequisites-to-build (%store) d))) - drv)) - (req* (delete-duplicates - (append (remove (compose (cut valid-path? (%store) <>) - derivation-path->output-path) - drv) - (map derivation-input-path req)))) - (roots (filter-map (match-lambda - (('gc-root . root) root) - (_ #f)) - opts))) - (if (assoc-ref opts 'dry-run?) - (format (current-error-port) - (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]" - "~:[the following derivations would be built:~%~{ ~a~%~}~;~]" - (length req*)) - (null? req*) req*) - (format (current-error-port) - (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]" - "~:[the following derivations will be built:~%~{ ~a~%~}~;~]" - (length req*)) - (null? req*) req*)) - - ;; TODO: Add more options. - (set-build-options (%store) - #:keep-failed? (assoc-ref opts 'keep-failed?) - #:build-cores (or (assoc-ref opts 'cores) 0) - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:verbosity (assoc-ref opts 'verbosity)) - - (if (assoc-ref opts 'derivations-only?) - (begin - (format #t "~{~a~%~}" drv) - (for-each (cut register-root <> <>) - (map list drv) roots)) - (or (assoc-ref opts 'dry-run?) - (and (build-derivations (%store) drv) - (for-each (lambda (d) - (let ((drv (call-with-input-file d - read-derivation))) - (format #t "~{~a~%~}" - (map (match-lambda - ((out-name . out) - (derivation-path->output-path - d out-name))) - (derivation-outputs drv))))) - drv) - (for-each (cut register-root <> <>) - (map (lambda (drv) - (map cdr - (derivation-path->output-paths drv))) - drv) - roots))))))))) diff --git a/guix-download.in b/guix-download.in deleted file mode 100644 index ea62b09a7b..0000000000 --- a/guix-download.in +++ /dev/null @@ -1,164 +0,0 @@ -#!/bin/sh -# aside from this initial boilerplate, this is actually -*- scheme -*- code - -prefix="@prefix@" -datarootdir="@datarootdir@" - -GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH" -export GUILE_LOAD_COMPILED_PATH - -main='(module-ref (resolve-interface '\''(guix-download)) '\'guix-download')' -exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \ - -c "(apply $main (cdr (command-line)))" "$@" -!# -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès -;;; -;;; 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 . - -(define-module (guix-download) - #:use-module (guix ui) - #:use-module (guix store) - #:use-module (guix utils) - #:use-module (guix base32) - #:use-module ((guix download) #:select (%mirrors)) - #:use-module (guix build download) - #:use-module (web uri) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-37) - #:use-module (rnrs bytevectors) - #:use-module (rnrs io ports) - #:export (guix-download)) - -(define (call-with-temporary-output-file proc) - (let* ((template (string-copy "guix-download.XXXXXX")) - (out (mkstemp! template))) - (dynamic-wind - (lambda () - #t) - (lambda () - (proc template out)) - (lambda () - (false-if-exception (delete-file template)))))) - -(define (fetch-and-store store fetch name) - "Call FETCH for URI, and pass it the name of a file to write to; eventually, -copy data from that port to STORE, under NAME. Return the resulting -store path." - (call-with-temporary-output-file - (lambda (temp port) - (let ((result - (parameterize ((current-output-port (current-error-port))) - (fetch temp)))) - (close port) - (and result - (add-to-store store name #f "sha256" temp)))))) - -;;; -;;; Command-line options. -;;; - -(define %default-options - ;; Alist of default option values. - `((format . ,bytevector->nix-base32-string))) - -(define (show-help) - (display (_ "Usage: guix-download [OPTION]... URL -Download the file at URL, add it to the store, and print its store path -and the hash of its contents.\n")) - (format #t (_ " - -f, --format=FMT write the hash in the given format (default: `nix-base32')")) - (newline) - (display (_ " - -h, --help display this help and exit")) - (display (_ " - -V, --version display version information and exit")) - (newline) - (show-bug-report-information)) - -(define %options - ;; Specifications of the command-line options. - (list (option '(#\f "format") #t #f - (lambda (opt name arg result) - (define fmt-proc - (match arg - ("nix-base32" - bytevector->nix-base32-string) - ("base32" - bytevector->base32-string) - ((or "base16" "hex" "hexadecimal") - bytevector->base16-string) - (x - (format (current-error-port) - "unsupported hash format: ~a~%" arg)))) - - (alist-cons 'format fmt-proc - (alist-delete 'format result)))) - - (option '(#\h "help") #f #f - (lambda args - (show-help) - (exit 0))) - (option '(#\V "version") #f #f - (lambda args - (show-version-and-exit "guix-download"))))) - - -;;; -;;; Entry point. -;;; - -(define (guix-download . args) - (define (parse-options) - ;; Return the alist of option values. - (args-fold args %options - (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) - (lambda (arg result) - (alist-cons 'argument arg result)) - %default-options)) - - (install-locale) - (textdomain "guix") - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - - (let* ((opts (parse-options)) - (store (open-connection)) - (arg (assq-ref opts 'argument)) - (uri (or (string->uri arg) - (leave (_ "guix-download: ~a: failed to parse URI~%") - arg))) - (path (case (uri-scheme uri) - ((file) - (add-to-store store (basename (uri-path uri)) - #f "sha256" (uri-path uri))) - (else - (fetch-and-store store - (cut url-fetch arg <> - #:mirrors %mirrors) - (basename (uri-path uri)))))) - (hash (call-with-input-file - (or path - (leave (_ "guix-download: ~a: download failed~%") - arg)) - (compose sha256 get-bytevector-all))) - (fmt (assq-ref opts 'format))) - (format #t "~a~%~a~%" path (fmt hash)) - #t)) diff --git a/guix-gc.in b/guix-gc.in deleted file mode 100644 index 1a4a5413d9..0000000000 --- a/guix-gc.in +++ /dev/null @@ -1,183 +0,0 @@ -#!/bin/sh -# aside from this initial boilerplate, this is actually -*- scheme -*- code - -prefix="@prefix@" -datarootdir="@datarootdir@" - -GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH" -export GUILE_LOAD_COMPILED_PATH - -main='(module-ref (resolve-interface '\''(guix-gc)) '\'guix-gc')' -exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \ - -c "(apply $main (cdr (command-line)))" "$@" -!# -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès -;;; -;;; 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 . - -(define-module (guix-gc) - #:use-module (guix ui) - #:use-module (guix store) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-37) - #:export (guix-gc)) - - -;;; -;;; Command-line options. -;;; - -(define %default-options - ;; Alist of default option values. - `((action . collect-garbage))) - -(define (show-help) - (display (_ "Usage: guix-gc [OPTION]... PATHS... -Invoke the garbage collector.\n")) - (display (_ " - -C, --collect-garbage[=MIN] - collect at least MIN bytes of garbage")) - (display (_ " - -d, --delete attempt to delete PATHS")) - (display (_ " - --list-dead list dead paths")) - (display (_ " - --list-live list live paths")) - (newline) - (display (_ " - -h, --help display this help and exit")) - (display (_ " - -V, --version display version information and exit")) - (newline) - (show-bug-report-information)) - -(define (size->number str) - "Convert STR, a storage measurement representation such as \"1024\" or -\"1MiB\", to a number of bytes. Raise an error if STR could not be -interpreted." - (define unit-pos - (string-rindex str char-set:digit)) - - (define unit - (and unit-pos (substring str (+ 1 unit-pos)))) - - (let* ((numstr (if unit-pos - (substring str 0 (+ 1 unit-pos)) - str)) - (num (string->number numstr))) - (if num - (* num - (match unit - ("KiB" (expt 2 10)) - ("MiB" (expt 2 20)) - ("GiB" (expt 2 30)) - ("TiB" (expt 2 40)) - ("KB" (expt 10 3)) - ("MB" (expt 10 6)) - ("GB" (expt 10 9)) - ("TB" (expt 10 12)) - ("" 1) - (_ - (format (current-error-port) (_ "error: unknown unit: ~a~%") - unit) - (exit 1)))) - (begin - (format (current-error-port) - (_ "error: invalid number: ~a") numstr) - (exit 1))))) - -(define %options - ;; Specification of the command-line options. - (list (option '(#\h "help") #f #f - (lambda args - (show-help) - (exit 0))) - (option '(#\V "version") #f #f - (lambda args - (show-version-and-exit "guix-gc"))) - - (option '(#\C "collect-garbage") #f #t - (lambda (opt name arg result) - (let ((result (alist-cons 'action 'collect-garbage - (alist-delete 'action result)))) - (match arg - ((? string?) - (let ((amount (size->number arg))) - (if arg - (alist-cons 'min-freed amount result) - (begin - (format (current-error-port) - (_ "error: invalid amount of storage: ~a~%") - arg) - (exit 1))))) - (#f result))))) - (option '(#\d "delete") #f #f - (lambda (opt name arg result) - (alist-cons 'action 'delete - (alist-delete 'action result)))) - (option '("list-dead") #f #f - (lambda (opt name arg result) - (alist-cons 'action 'list-dead - (alist-delete 'action result)))) - (option '("list-live") #f #f - (lambda (opt name arg result) - (alist-cons 'action 'list-live - (alist-delete 'action result)))))) - - -;;; -;;; Entry point. -;;; - -(define (guix-gc . args) - (define (parse-options) - ;; Return the alist of option values. - (args-fold args %options - (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) - (lambda (arg result) - (alist-cons 'argument arg result)) - %default-options)) - - (install-locale) - (textdomain "guix") - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - - (with-error-handling - (let ((opts (parse-options)) - (store (open-connection))) - (case (assoc-ref opts 'action) - ((collect-garbage) - (let ((min-freed (assoc-ref opts 'min-freed))) - (if min-freed - (collect-garbage store min-freed) - (collect-garbage store)))) - ((delete) - (let ((paths (filter-map (match-lambda - (('argument . arg) arg) - (_ #f)) - opts))) - (delete-paths store paths))) - ((list-dead) - (for-each (cut simple-format #t "~a~%" <>) - (dead-paths store))) - ((list-live) - (for-each (cut simple-format #t "~a~%" <>) - (live-paths store))))))) diff --git a/guix-import.in b/guix-import.in deleted file mode 100644 index 97619a9a59..0000000000 --- a/guix-import.in +++ /dev/null @@ -1,137 +0,0 @@ -#!/bin/sh -# aside from this initial boilerplate, this is actually -*- scheme -*- code - -prefix="@prefix@" -datarootdir="@datarootdir@" - -GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH" -export GUILE_LOAD_COMPILED_PATH - -main='(module-ref (resolve-interface '\''(guix-import)) '\'guix-import')' -exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \ - -c "(apply $main (cdr (command-line)))" "$@" -!# -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès -;;; -;;; 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 . - -(define-module (guix-import) - #:use-module (guix ui) - #:use-module (guix snix) - #:use-module (guix utils) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-37) - #:use-module (ice-9 match) - #:use-module (ice-9 pretty-print) - #:export (guix-import)) - - -;;; -;;; Helper. -;;; - -(define (newline-rewriting-port output) - "Return an output port that rewrites strings containing the \\n escape -to an actual newline. This works around the behavior of `pretty-print' -and `write', which output these as \\n instead of actual newlines, -whereas we want the `description' field to contain actual newlines -rather than \\n." - (define (write-string str) - (let loop ((chars (string->list str))) - (match chars - (() - #t) - ((#\\ #\n rest ...) - (newline output) - (loop rest)) - ((chr rest ...) - (write-char chr output) - (loop rest))))) - - (make-soft-port (vector (cut write-char <>) - write-string - (lambda _ #t) ; flush - #f - (lambda _ #t) ; close - #f) - "w")) - - -;;; -;;; Command-line options. -;;; - -(define %default-options - '()) - -(define (show-help) - (display (_ "Usage: guix-import NIXPKGS ATTRIBUTE -Import and convert the Nix expression ATTRIBUTE of NIXPKGS.\n")) - (display (_ " - -h, --help display this help and exit")) - (display (_ " - -V, --version display version information and exit")) - (newline) - (show-bug-report-information)) - -(define %options - ;; Specification of the command-line options. - (list (option '(#\h "help") #f #f - (lambda args - (show-help) - (exit 0))) - (option '(#\V "version") #f #f - (lambda args - (show-version-and-exit "guix-import"))))) - - -;;; -;;; Entry point. -;;; - -(define (guix-import . args) - (define (parse-options) - ;; Return the alist of option values. - (args-fold args %options - (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) - (lambda (arg result) - (alist-cons 'argument arg result)) - %default-options)) - - (install-locale) - (textdomain "guix") - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - - (let* ((opts (parse-options)) - (args (filter-map (match-lambda - (('argument . value) - value) - (_ #f)) - (reverse opts)))) - (match args - ((nixpkgs attribute) - (let-values (((expr loc) - (nixpkgs->guix-package nixpkgs attribute))) - (format #t ";; converted from ~a:~a~%~%" - (location-file loc) (location-line loc)) - (pretty-print expr (newline-rewriting-port (current-output-port))))) - (_ - (leave (_ "wrong number of arguments~%")))))) diff --git a/guix-package.in b/guix-package.in deleted file mode 100644 index 584481acd5..0000000000 --- a/guix-package.in +++ /dev/null @@ -1,706 +0,0 @@ -#!/bin/sh -# aside from this initial boilerplate, this is actually -*- scheme -*- code - -prefix="@prefix@" -datarootdir="@datarootdir@" - -GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH" -export GUILE_LOAD_COMPILED_PATH - -main='(module-ref (resolve-interface '\''(guix-package)) '\'guix-package')' -exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \ - -c "(apply $main (cdr (command-line)))" "$@" -!# -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès -;;; Copyright © 2013 Nikita Karetnikov -;;; Copyright © 2013 Mark H Weaver -;;; -;;; 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 . - -(define-module (guix-package) - #:use-module (guix ui) - #:use-module (guix store) - #:use-module (guix derivations) - #:use-module (guix packages) - #:use-module (guix utils) - #:use-module (guix config) - #:use-module ((guix build utils) #:select (directory-exists? mkdir-p)) - #:use-module (ice-9 ftw) - #:use-module (ice-9 format) - #:use-module (ice-9 match) - #:use-module (ice-9 regex) - #:use-module (ice-9 vlist) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-34) - #:use-module (srfi srfi-37) - #:use-module (gnu packages) - #:use-module ((gnu packages base) #:select (guile-final)) - #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) - #:export (guix-package)) - -(define %store - (make-parameter #f)) - - -;;; -;;; User environment. -;;; - -(define %user-environment-directory - (and=> (getenv "HOME") - (cut string-append <> "/.guix-profile"))) - -(define %profile-directory - (string-append (or (getenv "NIX_STATE_DIR") %state-directory) "/profiles/" - (or (and=> (getenv "USER") - (cut string-append "per-user/" <>)) - "default"))) - -(define %current-profile - ;; Call it `guix-profile', not `profile', to allow Guix profiles to - ;; coexist with Nix profiles. - (string-append %profile-directory "/guix-profile")) - -(define (profile-manifest profile) - "Return the PROFILE's manifest." - (let ((manifest (string-append profile "/manifest"))) - (if (file-exists? manifest) - (call-with-input-file manifest read) - '(manifest (version 1) (packages ()))))) - -(define (manifest-packages manifest) - "Return the packages listed in MANIFEST." - (match manifest - (('manifest ('version 0) - ('packages ((name version output path) ...))) - (zip name version output path - (make-list (length name) '()))) - - ;; Version 1 adds a list of propagated inputs to the - ;; name/version/output/path tuples. - (('manifest ('version 1) - ('packages (packages ...))) - packages) - - (_ - (error "unsupported manifest format" manifest)))) - -(define (profile-regexp profile) - "Return a regular expression that matches PROFILE's name and number." - (make-regexp (string-append "^" (regexp-quote (basename profile)) - "-([0-9]+)"))) - -(define (profile-numbers profile) - "Return the list of generation numbers of PROFILE, or '(0) if no -former profiles were found." - (define* (scandir name #:optional (select? (const #t)) - (entry (file-system-fold enter? leaf down up skip error #f name lstat) - (lambda (files) - (sort files entry)) - (#f ; no profile directory - '(0)) - (() ; no profiles - '(0)) - ((profiles ...) ; former profiles around - (map (compose string->number - (cut match:substring <> 1) - (cute regexp-exec (profile-regexp profile) <>)) - profiles)))) - -(define (previous-profile-number profile number) - "Return the number of the generation before generation NUMBER of -PROFILE, or 0 if none exists. It could be NUMBER - 1, but it's not the -case when generations have been deleted (there are \"holes\")." - (fold (lambda (candidate highest) - (if (and (< candidate number) (> candidate highest)) - candidate - highest)) - 0 - (profile-numbers profile))) - -(define (profile-derivation store packages) - "Return a derivation that builds a profile (a user environment) with -all of PACKAGES, a list of name/version/output/path/deps tuples." - (define builder - `(begin - (use-modules (ice-9 pretty-print) - (guix build union)) - - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - - (let ((output (assoc-ref %outputs "out")) - (inputs (map cdr %build-inputs))) - (format #t "building user environment `~a' with ~a packages...~%" - output (length inputs)) - (union-build output inputs) - (call-with-output-file (string-append output "/manifest") - (lambda (p) - (pretty-print '(manifest (version 1) - (packages ,packages)) - p)))))) - - (build-expression->derivation store "user-environment" - (%current-system) - builder - (append-map (match-lambda - ((name version output path deps) - `((,name ,path) - ,@deps))) - packages) - #:modules '((guix build union)))) - -(define (profile-number profile) - "Return PROFILE's number or 0. An absolute file name must be used." - (or (and=> (false-if-exception (regexp-exec (profile-regexp profile) - (basename (readlink profile)))) - (compose string->number (cut match:substring <> 1))) - 0)) - -(define (switch-symlinks link target) - "Atomically switch LINK, a symbolic link, to point to TARGET. Works -both when LINK already exists and when it does not." - (let ((pivot (string-append link ".new"))) - (symlink target pivot) - (rename-file pivot link))) - -(define (roll-back profile) - "Roll back to the previous generation of PROFILE." - (let* ((number (profile-number profile)) - (previous-number (previous-profile-number profile number)) - (previous-profile (format #f "~a-~a-link" - profile previous-number)) - (manifest (string-append previous-profile "/manifest"))) - - (define (switch-link) - ;; Atomically switch PROFILE to the previous profile. - (format #t (_ "switching from generation ~a to ~a~%") - number previous-number) - (switch-symlinks profile previous-profile)) - - (cond ((not (file-exists? profile)) ; invalid profile - (format (current-error-port) - (_ "error: profile `~a' does not exist~%") - profile)) - ((zero? number) ; empty profile - (format (current-error-port) - (_ "nothing to do: already at the empty profile~%"))) - ((or (zero? previous-number) ; going to emptiness - (not (file-exists? previous-profile))) - (let*-values (((drv-path drv) - (profile-derivation (%store) '())) - ((prof) - (derivation-output-path - (assoc-ref (derivation-outputs drv) "out")))) - (when (not (build-derivations (%store) (list drv-path))) - (leave (_ "failed to build the empty profile~%"))) - - (switch-symlinks previous-profile prof) - (switch-link))) - (else (switch-link))))) ; anything else - -(define (find-packages-by-description rx) - "Search in SYNOPSIS and DESCRIPTION using RX. Return a list of -matching packages." - (define (same-location? p1 p2) - ;; Compare locations of two packages. - (equal? (package-location p1) (package-location p2))) - - (delete-duplicates - (sort - (fold-packages (lambda (package result) - (define matches? - (cut regexp-exec rx <>)) - - (if (or (and=> (package-synopsis package) - (compose matches? gettext)) - (and=> (package-description package) - (compose matches? gettext))) - (cons package result) - result)) - '()) - (lambda (p1 p2) - (stringname+path input) - "Convert the name/package/sub-drv tuple INPUT to a name/store-path tuple." - (let loop ((input input)) - (match input - ((name package) - (loop `(,name ,package "out"))) - ((name package sub-drv) - (let*-values (((_ drv) - (package-derivation (%store) package)) - ((out) - (derivation-output-path - (assoc-ref (derivation-outputs drv) sub-drv)))) - `(,name ,out)))))) - - -;;; -;;; Command-line options. -;;; - -(define %default-options - ;; Alist of default option values. - `((profile . ,%current-profile))) - -(define (show-help) - (display (_ "Usage: guix-package [OPTION]... PACKAGES... -Install, remove, or upgrade PACKAGES in a single transaction.\n")) - (display (_ " - -i, --install=PACKAGE install PACKAGE")) - (display (_ " - -r, --remove=PACKAGE remove PACKAGE")) - (display (_ " - -u, --upgrade=REGEXP upgrade all the installed packages matching REGEXP")) - (display (_ " - --roll-back roll back to the previous generation")) - (newline) - (display (_ " - -p, --profile=PROFILE use PROFILE instead of the user's default profile")) - (display (_ " - -n, --dry-run show what would be done without actually doing it")) - (display (_ " - --bootstrap use the bootstrap Guile to build the profile")) - (display (_ " - --verbose produce verbose output")) - (newline) - (display (_ " - -s, --search=REGEXP search in synopsis and description using REGEXP")) - (display (_ " - -I, --list-installed[=REGEXP] - list installed packages matching REGEXP")) - (display (_ " - -A, --list-available[=REGEXP] - list available packages matching REGEXP")) - (newline) - (display (_ " - -h, --help display this help and exit")) - (display (_ " - -V, --version display version information and exit")) - (newline) - (show-bug-report-information)) - -(define %options - ;; Specification of the command-line options. - (list (option '(#\h "help") #f #f - (lambda args - (show-help) - (exit 0))) - (option '(#\V "version") #f #f - (lambda args - (show-version-and-exit "guix-package"))) - - (option '(#\i "install") #t #f - (lambda (opt name arg result) - (alist-cons 'install arg result))) - (option '(#\r "remove") #t #f - (lambda (opt name arg result) - (alist-cons 'remove arg result))) - (option '(#\u "upgrade") #t #f - (lambda (opt name arg result) - (alist-cons 'upgrade arg result))) - (option '("roll-back") #f #f - (lambda (opt name arg result) - (alist-cons 'roll-back? #t result))) - (option '(#\p "profile") #t #f - (lambda (opt name arg result) - (alist-cons 'profile arg - (alist-delete 'profile result)))) - (option '(#\n "dry-run") #f #f - (lambda (opt name arg result) - (alist-cons 'dry-run? #t result))) - (option '("bootstrap") #f #f - (lambda (opt name arg result) - (alist-cons 'bootstrap? #t result))) - (option '("verbose") #f #f - (lambda (opt name arg result) - (alist-cons 'verbose? #t result))) - (option '(#\s "search") #t #f - (lambda (opt name arg result) - (cons `(query search ,(or arg "")) - result))) - (option '(#\I "list-installed") #f #t - (lambda (opt name arg result) - (cons `(query list-installed ,(or arg "")) - result))) - (option '(#\A "list-available") #f #t - (lambda (opt name arg result) - (cons `(query list-available ,(or arg "")) - result))))) - - -;;; -;;; Entry point. -;;; - -(define (guix-package . args) - (define (parse-options) - ;; Return the alist of option values. - (args-fold args %options - (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) - (lambda (arg result) - (leave (_ "~A: extraneous argument~%") arg)) - %default-options)) - - (define (guile-missing?) - ;; Return #t if %GUILE-FOR-BUILD is not available yet. - (let ((out (derivation-path->output-path (%guile-for-build)))) - (not (valid-path? (%store) out)))) - - (define (show-what-to-build drv dry-run?) - ;; Show what will/would be built in realizing the derivations listed - ;; in DRV. - (let* ((req (append-map (lambda (drv-path) - (let ((d (call-with-input-file drv-path - read-derivation))) - (derivation-prerequisites-to-build - (%store) d))) - drv)) - (req* (delete-duplicates - (append (remove (compose (cute valid-path? (%store) <>) - derivation-path->output-path) - drv) - (map derivation-input-path req))))) - (if dry-run? - (format (current-error-port) - (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]" - "~:[the following derivations would be built:~%~{ ~a~%~}~;~]" - (length req*)) - (null? req*) req*) - (format (current-error-port) - (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]" - "~:[the following derivations will be built:~%~{ ~a~%~}~;~]" - (length req*)) - (null? req*) req*)))) - - (define newest-available-packages - (memoize find-newest-available-packages)) - - (define (find-best-packages-by-name name version) - (if version - (find-packages-by-name name version) - (match (vhash-assoc name (newest-available-packages)) - ((_ version pkgs ...) pkgs) - (#f '())))) - - (define (find-package name) - ;; Find the package NAME; NAME may contain a version number and a - ;; sub-derivation name. If the version number is not present, - ;; return the preferred newest version. - (define request name) - - (define (ensure-output p sub-drv) - (if (member sub-drv (package-outputs p)) - p - (leave (_ "~a: error: package `~a' lacks output `~a'~%") - (location->string (package-location p)) - (package-full-name p) - sub-drv))) - - (let*-values (((name sub-drv) - (match (string-rindex name #\:) - (#f (values name "out")) - (colon (values (substring name 0 colon) - (substring name (+ 1 colon)))))) - ((name version) - (package-name->name+version name))) - (match (find-best-packages-by-name name version) - ((p) - (list name (package-version p) sub-drv (ensure-output p sub-drv) - (package-transitive-propagated-inputs p))) - ((p p* ...) - (format (current-error-port) - (_ "warning: ambiguous package specification `~a'~%") - request) - (format (current-error-port) - (_ "warning: choosing ~a from ~a~%") - (package-full-name p) - (location->string (package-location p))) - (list name (package-version p) sub-drv (ensure-output p sub-drv) - (package-transitive-propagated-inputs p))) - (() - (leave (_ "~a: package not found~%") request))))) - - (define (upgradeable? name current-version current-path) - ;; Return #t if there's a version of package NAME newer than - ;; CURRENT-VERSION, or if the newest available version is equal to - ;; CURRENT-VERSION but would have an output path different than - ;; CURRENT-PATH. - (match (vhash-assoc name (newest-available-packages)) - ((_ candidate-version pkg . rest) - (case (version-compare candidate-version current-version) - ((>) #t) - ((<) #f) - ((=) (let ((candidate-path (derivation-path->output-path - (package-derivation (%store) pkg)))) - (not (string=? current-path candidate-path)))))) - (#f #f))) - - (define (ensure-default-profile) - ;; Ensure the default profile symlink and directory exist. - - ;; Create ~/.guix-profile if it doesn't exist yet. - (when (and %user-environment-directory - %current-profile - (not (false-if-exception - (lstat %user-environment-directory)))) - (symlink %current-profile %user-environment-directory)) - - ;; Attempt to create /…/profiles/per-user/$USER if needed. - (unless (directory-exists? %profile-directory) - (catch 'system-error - (lambda () - (mkdir-p %profile-directory)) - (lambda args - ;; Often, we cannot create %PROFILE-DIRECTORY because its - ;; parent directory is root-owned and we're running - ;; unprivileged. - (format (current-error-port) - (_ "error: while creating directory `~a': ~a~%") - %profile-directory - (strerror (system-error-errno args))) - (format (current-error-port) - (_ "Please create the `~a' directory, with you as the owner.~%") - %profile-directory) - (exit 1))))) - - (define (process-actions opts) - ;; Process any install/remove/upgrade action from OPTS. - - (define dry-run? (assoc-ref opts 'dry-run?)) - (define verbose? (assoc-ref opts 'verbose?)) - (define profile (assoc-ref opts 'profile)) - - (define (canonicalize-deps deps) - ;; Remove duplicate entries from DEPS, a list of propagated inputs, - ;; where each input is a name/path tuple. - (define (same? d1 d2) - (match d1 - ((_ path1) - (match d2 - ((_ path2) - (string=? path1 path2)))))) - - (delete-duplicates (map input->name+path deps) same?)) - - ;; First roll back if asked to. - (if (and (assoc-ref opts 'roll-back?) (not dry-run?)) - (begin - (roll-back profile) - (process-actions (alist-delete 'roll-back? opts))) - (let* ((installed (manifest-packages (profile-manifest profile))) - (upgrade-regexps (filter-map (match-lambda - (('upgrade . regexp) - (make-regexp regexp)) - (_ #f)) - opts)) - (upgrade (if (null? upgrade-regexps) - '() - (let ((newest (find-newest-available-packages))) - (filter-map (match-lambda - ((name version output path _) - (and (any (cut regexp-exec <> name) - upgrade-regexps) - (upgradeable? name version path) - (find-package name))) - (_ #f)) - installed)))) - (install (append - upgrade - (filter-map (match-lambda - (('install . (? store-path?)) - #f) - (('install . package) - (find-package package)) - (_ #f)) - opts))) - (drv (filter-map (match-lambda - ((name version sub-drv - (? package? package) - (deps ...)) - (package-derivation (%store) package)) - (_ #f)) - install)) - (install* (append - (filter-map (match-lambda - (('install . (? store-path? path)) - (let-values (((name version) - (package-name->name+version - (store-path-package-name - path)))) - `(,name ,version #f ,path ()))) - (_ #f)) - opts) - (map (lambda (tuple drv) - (match tuple - ((name version sub-drv _ (deps ...)) - (let ((output-path - (derivation-path->output-path - drv sub-drv))) - `(,name ,version ,sub-drv ,output-path - ,(canonicalize-deps deps)))))) - install drv))) - (remove (filter-map (match-lambda - (('remove . package) - package) - (_ #f)) - opts)) - (packages (append install* - (fold (lambda (package result) - (match package - ((name _ ...) - (alist-delete name result)))) - (fold alist-delete installed remove) - install*)))) - - (when (equal? profile %current-profile) - (ensure-default-profile)) - - (show-what-to-build drv dry-run?) - - (or dry-run? - (and (build-derivations (%store) drv) - (let* ((prof-drv (profile-derivation (%store) packages)) - (prof (derivation-path->output-path prof-drv)) - (old-drv (profile-derivation - (%store) (manifest-packages - (profile-manifest profile)))) - (old-prof (derivation-path->output-path old-drv)) - (number (profile-number profile)) - - ;; Always use NUMBER + 1 for the new profile, - ;; possibly overwriting a "previous future - ;; generation". - (name (format #f "~a-~a-link" - profile (+ 1 number)))) - (if (string=? old-prof prof) - (when (or (pair? install) (pair? remove)) - (format (current-error-port) - (_ "nothing to be done~%"))) - (and (parameterize ((current-build-output-port - ;; Output something when Guile - ;; needs to be built. - (if (or verbose? (guile-missing?)) - (current-error-port) - (%make-void-port "w")))) - (build-derivations (%store) (list prof-drv))) - (begin - (switch-symlinks name prof) - (switch-symlinks profile name)))))))))) - - (define (process-query opts) - ;; Process any query specified by OPTS. Return #t when a query was - ;; actually processed, #f otherwise. - (let ((profile (assoc-ref opts 'profile))) - (match (assoc-ref opts 'query) - (('list-installed regexp) - (let* ((regexp (and regexp (make-regexp regexp))) - (manifest (profile-manifest profile)) - (installed (manifest-packages manifest))) - (for-each (match-lambda - ((name version output path _) - (when (or (not regexp) - (regexp-exec regexp name)) - (format #t "~a\t~a\t~a\t~a~%" - name (or version "?") output path)))) - installed) - #t)) - - (('list-available regexp) - (let* ((regexp (and regexp (make-regexp regexp))) - (available (fold-packages - (lambda (p r) - (let ((n (package-name p))) - (if regexp - (if (regexp-exec regexp n) - (cons p r) - r) - (cons p r)))) - '()))) - (for-each (lambda (p) - (format #t "~a\t~a\t~a\t~a~%" - (package-name p) - (package-version p) - (string-join (package-outputs p) ",") - (location->string (package-location p)))) - (sort available - (lambda (p1 p2) - (stringrecutils <> (current-output-port)) - (find-packages-by-description regexp)) - #t)) - (_ #f)))) - - (install-locale) - (textdomain "guix") - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - - (let ((opts (parse-options))) - (or (process-query opts) - (parameterize ((%store (open-connection))) - (with-error-handling - (parameterize ((%guile-for-build - (package-derivation (%store) - (if (assoc-ref opts 'bootstrap?) - %bootstrap-guile - guile-final)))) - (process-actions opts))))))) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm new file mode 100644 index 0000000000..bad04418f1 --- /dev/null +++ b/guix/scripts/build.scm @@ -0,0 +1,304 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2013 Mark H Weaver +;;; +;;; This file is part of GNU Guix. +;;; +;;; 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 . + +(define-module (guix scripts build) + #:use-module (guix ui) + #:use-module (guix store) + #:use-module (guix derivations) + #:use-module (guix packages) + #:use-module (guix utils) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 vlist) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-37) + #:autoload (gnu packages) (find-packages-by-name + find-newest-available-packages) + #:export (guix-build)) + +(define %store + (make-parameter #f)) + +(define (derivations-from-package-expressions exp system source?) + "Eval EXP and return the corresponding derivation path for SYSTEM. +When SOURCE? is true, return the derivations of the package sources." + (let ((p (eval exp (current-module)))) + (if (package? p) + (if source? + (let ((source (package-source p)) + (loc (package-location p))) + (if source + (package-source-derivation (%store) source) + (leave (_ "~a: error: package `~a' has no source~%") + (location->string loc) (package-name p)))) + (package-derivation (%store) p system)) + (leave (_ "expression `~s' does not evaluate to a package~%") + exp)))) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + ;; Alist of default option values. + `((system . ,(%current-system)) + (substitutes? . #t) + (verbosity . 0))) + +(define (show-help) + (display (_ "Usage: guix build [OPTION]... PACKAGE-OR-DERIVATION... +Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) + (display (_ " + -e, --expression=EXPR build the package EXPR evaluates to")) + (display (_ " + -S, --source build the packages' source derivations")) + (display (_ " + -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) + (display (_ " + -d, --derivations return the derivation paths of the given packages")) + (display (_ " + -K, --keep-failed keep build tree of failed builds")) + (display (_ " + -n, --dry-run do not build the derivations")) + (display (_ " + --no-substitutes build instead of resorting to pre-built substitutes")) + (display (_ " + -c, --cores=N allow the use of up to N CPU cores for the build")) + (display (_ " + -r, --root=FILE make FILE a symlink to the result, and register it + as a garbage collector root")) + (display (_ " + --verbosity=LEVEL use the given verbosity LEVEL")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specifications of the command-line options. + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix-build"))) + + (option '(#\S "source") #f #f + (lambda (opt name arg result) + (alist-cons 'source? #t result))) + (option '(#\s "system") #t #f + (lambda (opt name arg result) + (alist-cons 'system arg + (alist-delete 'system result eq?)))) + (option '(#\d "derivations") #f #f + (lambda (opt name arg result) + (alist-cons 'derivations-only? #t result))) + (option '(#\e "expression") #t #f + (lambda (opt name arg result) + (alist-cons 'expression + (call-with-input-string arg read) + result))) + (option '(#\K "keep-failed") #f #f + (lambda (opt name arg result) + (alist-cons 'keep-failed? #t result))) + (option '(#\c "cores") #t #f + (lambda (opt name arg result) + (let ((c (false-if-exception (string->number arg)))) + (if c + (alist-cons 'cores c result) + (leave (_ "~a: not a number~%") arg))))) + (option '(#\n "dry-run") #f #f + (lambda (opt name arg result) + (alist-cons 'dry-run? #t result))) + (option '("no-substitutes") #f #f + (lambda (opt name arg result) + (alist-cons 'substitutes? #f + (alist-delete 'substitutes? result)))) + (option '(#\r "root") #t #f + (lambda (opt name arg result) + (alist-cons 'gc-root arg result))) + (option '("verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))))) + + +;;; +;;; Entry point. +;;; + +(define (guix-build . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (define (register-root paths root) + ;; Register ROOT as an indirect GC root for all of PATHS. + (let* ((root (string-append (canonicalize-path (dirname root)) + "/" root))) + (catch 'system-error + (lambda () + (match paths + ((path) + (symlink path root) + (add-indirect-root (%store) root)) + ((paths ...) + (fold (lambda (path count) + (let ((root (string-append root "-" (number->string count)))) + (symlink path root) + (add-indirect-root (%store) root)) + (+ 1 count)) + 0 + paths)))) + (lambda args + (format (current-error-port) + (_ "failed to create GC root `~a': ~a~%") + root (strerror (system-error-errno args))) + (exit 1))))) + + (define newest-available-packages + (memoize find-newest-available-packages)) + + (define (find-best-packages-by-name name version) + (if version + (find-packages-by-name name version) + (match (vhash-assoc name (newest-available-packages)) + ((_ version pkgs ...) pkgs) + (#f '())))) + + (define (find-package request) + ;; Return a package matching REQUEST. REQUEST may be a package + ;; name, or a package name followed by a hyphen and a version + ;; number. If the version number is not present, return the + ;; preferred newest version. + (let-values (((name version) + (package-name->name+version request))) + (match (find-best-packages-by-name name version) + ((p) ; one match + p) + ((p x ...) ; several matches + (format (current-error-port) + (_ "warning: ambiguous package specification `~a'~%") + request) + (format (current-error-port) + (_ "warning: choosing ~a from ~a~%") + (package-full-name p) + (location->string (package-location p))) + p) + (_ ; no matches + (if version + (leave (_ "~A: package not found for version ~a~%") + name version) + (leave (_ "~A: unknown package~%") name)))))) + + (install-locale) + (textdomain "guix") + (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-error-port) _IOLBF) + + (with-error-handling + (let ((opts (parse-options))) + (parameterize ((%store (open-connection))) + (let* ((src? (assoc-ref opts 'source?)) + (sys (assoc-ref opts 'system)) + (drv (filter-map (match-lambda + (('expression . exp) + (derivations-from-package-expressions exp sys + src?)) + (('argument . (? derivation-path? drv)) + drv) + (('argument . (? string? x)) + (let ((p (find-package x))) + (if src? + (let ((s (package-source p))) + (package-source-derivation + (%store) s)) + (package-derivation (%store) p sys)))) + (_ #f)) + opts)) + (req (append-map (lambda (drv-path) + (let ((d (call-with-input-file drv-path + read-derivation))) + (derivation-prerequisites-to-build (%store) d))) + drv)) + (req* (delete-duplicates + (append (remove (compose (cut valid-path? (%store) <>) + derivation-path->output-path) + drv) + (map derivation-input-path req)))) + (roots (filter-map (match-lambda + (('gc-root . root) root) + (_ #f)) + opts))) + (if (assoc-ref opts 'dry-run?) + (format (current-error-port) + (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]" + "~:[the following derivations would be built:~%~{ ~a~%~}~;~]" + (length req*)) + (null? req*) req*) + (format (current-error-port) + (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]" + "~:[the following derivations will be built:~%~{ ~a~%~}~;~]" + (length req*)) + (null? req*) req*)) + + ;; TODO: Add more options. + (set-build-options (%store) + #:keep-failed? (assoc-ref opts 'keep-failed?) + #:build-cores (or (assoc-ref opts 'cores) 0) + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:verbosity (assoc-ref opts 'verbosity)) + + (if (assoc-ref opts 'derivations-only?) + (begin + (format #t "~{~a~%~}" drv) + (for-each (cut register-root <> <>) + (map list drv) roots)) + (or (assoc-ref opts 'dry-run?) + (and (build-derivations (%store) drv) + (for-each (lambda (d) + (let ((drv (call-with-input-file d + read-derivation))) + (format #t "~{~a~%~}" + (map (match-lambda + ((out-name . out) + (derivation-path->output-path + d out-name))) + (derivation-outputs drv))))) + drv) + (for-each (cut register-root <> <>) + (map (lambda (drv) + (map cdr + (derivation-path->output-paths drv))) + drv) + roots))))))))) diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm new file mode 100644 index 0000000000..1098e6714b --- /dev/null +++ b/guix/scripts/download.scm @@ -0,0 +1,151 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix scripts download) + #:use-module (guix ui) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix base32) + #:use-module ((guix download) #:select (%mirrors)) + #:use-module (guix build download) + #:use-module (web uri) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:export (guix-download)) + +(define (call-with-temporary-output-file proc) + (let* ((template (string-copy "guix-download.XXXXXX")) + (out (mkstemp! template))) + (dynamic-wind + (lambda () + #t) + (lambda () + (proc template out)) + (lambda () + (false-if-exception (delete-file template)))))) + +(define (fetch-and-store store fetch name) + "Call FETCH for URI, and pass it the name of a file to write to; eventually, +copy data from that port to STORE, under NAME. Return the resulting +store path." + (call-with-temporary-output-file + (lambda (temp port) + (let ((result + (parameterize ((current-output-port (current-error-port))) + (fetch temp)))) + (close port) + (and result + (add-to-store store name #f "sha256" temp)))))) + +;;; +;;; Command-line options. +;;; + +(define %default-options + ;; Alist of default option values. + `((format . ,bytevector->nix-base32-string))) + +(define (show-help) + (display (_ "Usage: guix download [OPTION]... URL +Download the file at URL, add it to the store, and print its store path +and the hash of its contents.\n")) + (format #t (_ " + -f, --format=FMT write the hash in the given format (default: `nix-base32')")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specifications of the command-line options. + (list (option '(#\f "format") #t #f + (lambda (opt name arg result) + (define fmt-proc + (match arg + ("nix-base32" + bytevector->nix-base32-string) + ("base32" + bytevector->base32-string) + ((or "base16" "hex" "hexadecimal") + bytevector->base16-string) + (x + (format (current-error-port) + "unsupported hash format: ~a~%" arg)))) + + (alist-cons 'format fmt-proc + (alist-delete 'format result)))) + + (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix-download"))))) + + +;;; +;;; Entry point. +;;; + +(define (guix-download . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (install-locale) + (textdomain "guix") + (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-error-port) _IOLBF) + + (let* ((opts (parse-options)) + (store (open-connection)) + (arg (assq-ref opts 'argument)) + (uri (or (string->uri arg) + (leave (_ "guix-download: ~a: failed to parse URI~%") + arg))) + (path (case (uri-scheme uri) + ((file) + (add-to-store store (basename (uri-path uri)) + #f "sha256" (uri-path uri))) + (else + (fetch-and-store store + (cut url-fetch arg <> + #:mirrors %mirrors) + (basename (uri-path uri)))))) + (hash (call-with-input-file + (or path + (leave (_ "guix-download: ~a: download failed~%") + arg)) + (compose sha256 get-bytevector-all))) + (fmt (assq-ref opts 'format))) + (format #t "~a~%~a~%" path (fmt hash)) + #t)) diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm new file mode 100644 index 0000000000..8e2587186e --- /dev/null +++ b/guix/scripts/gc.scm @@ -0,0 +1,165 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix scripts gc) + #:use-module (guix ui) + #:use-module (guix store) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:export (guix-gc)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + ;; Alist of default option values. + `((action . collect-garbage))) + +(define (show-help) + (display (_ "Usage: guix gc [OPTION]... PATHS... +Invoke the garbage collector.\n")) + (display (_ " + -C, --collect-garbage[=MIN] + collect at least MIN bytes of garbage")) + (display (_ " + -d, --delete attempt to delete PATHS")) + (display (_ " + --list-dead list dead paths")) + (display (_ " + --list-live list live paths")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define (size->number str) + "Convert STR, a storage measurement representation such as \"1024\" or +\"1MiB\", to a number of bytes. Raise an error if STR could not be +interpreted." + (define unit-pos + (string-rindex str char-set:digit)) + + (define unit + (and unit-pos (substring str (+ 1 unit-pos)))) + + (let* ((numstr (if unit-pos + (substring str 0 (+ 1 unit-pos)) + str)) + (num (string->number numstr))) + (if num + (* num + (match unit + ("KiB" (expt 2 10)) + ("MiB" (expt 2 20)) + ("GiB" (expt 2 30)) + ("TiB" (expt 2 40)) + ("KB" (expt 10 3)) + ("MB" (expt 10 6)) + ("GB" (expt 10 9)) + ("TB" (expt 10 12)) + ("" 1) + (_ + (format (current-error-port) (_ "error: unknown unit: ~a~%") + unit) + (exit 1)))) + (begin + (format (current-error-port) + (_ "error: invalid number: ~a") numstr) + (exit 1))))) + +(define %options + ;; Specification of the command-line options. + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix-gc"))) + + (option '(#\C "collect-garbage") #f #t + (lambda (opt name arg result) + (let ((result (alist-cons 'action 'collect-garbage + (alist-delete 'action result)))) + (match arg + ((? string?) + (let ((amount (size->number arg))) + (if arg + (alist-cons 'min-freed amount result) + (begin + (format (current-error-port) + (_ "error: invalid amount of storage: ~a~%") + arg) + (exit 1))))) + (#f result))))) + (option '(#\d "delete") #f #f + (lambda (opt name arg result) + (alist-cons 'action 'delete + (alist-delete 'action result)))) + (option '("list-dead") #f #f + (lambda (opt name arg result) + (alist-cons 'action 'list-dead + (alist-delete 'action result)))) + (option '("list-live") #f #f + (lambda (opt name arg result) + (alist-cons 'action 'list-live + (alist-delete 'action result)))))) + + +;;; +;;; Entry point. +;;; + +(define (guix-gc . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (with-error-handling + (let ((opts (parse-options)) + (store (open-connection))) + (case (assoc-ref opts 'action) + ((collect-garbage) + (let ((min-freed (assoc-ref opts 'min-freed))) + (if min-freed + (collect-garbage store min-freed) + (collect-garbage store)))) + ((delete) + (let ((paths (filter-map (match-lambda + (('argument . arg) arg) + (_ #f)) + opts))) + (delete-paths store paths))) + ((list-dead) + (for-each (cut simple-format #t "~a~%" <>) + (dead-paths store))) + ((list-live) + (for-each (cut simple-format #t "~a~%" <>) + (live-paths store))))))) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm new file mode 100644 index 0000000000..0bc6926c66 --- /dev/null +++ b/guix/scripts/import.scm @@ -0,0 +1,124 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix scripts import) + #:use-module (guix ui) + #:use-module (guix snix) + #:use-module (guix utils) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) + #:export (guix-import)) + + +;;; +;;; Helper. +;;; + +(define (newline-rewriting-port output) + "Return an output port that rewrites strings containing the \\n escape +to an actual newline. This works around the behavior of `pretty-print' +and `write', which output these as \\n instead of actual newlines, +whereas we want the `description' field to contain actual newlines +rather than \\n." + (define (write-string str) + (let loop ((chars (string->list str))) + (match chars + (() + #t) + ((#\\ #\n rest ...) + (newline output) + (loop rest)) + ((chr rest ...) + (write-char chr output) + (loop rest))))) + + (make-soft-port (vector (cut write-char <>) + write-string + (lambda _ #t) ; flush + #f + (lambda _ #t) ; close + #f) + "w")) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (_ "Usage: guix import NIXPKGS ATTRIBUTE +Import and convert the Nix expression ATTRIBUTE of NIXPKGS.\n")) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix-import"))))) + + +;;; +;;; Entry point. +;;; + +(define (guix-import . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (install-locale) + (textdomain "guix") + (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-error-port) _IOLBF) + + (let* ((opts (parse-options)) + (args (filter-map (match-lambda + (('argument . value) + value) + (_ #f)) + (reverse opts)))) + (match args + ((nixpkgs attribute) + (let-values (((expr loc) + (nixpkgs->guix-package nixpkgs attribute))) + (format #t ";; converted from ~a:~a~%~%" + (location-file loc) (location-line loc)) + (pretty-print expr (newline-rewriting-port (current-output-port))))) + (_ + (leave (_ "wrong number of arguments~%")))))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm new file mode 100644 index 0000000000..4935837d33 --- /dev/null +++ b/guix/scripts/package.scm @@ -0,0 +1,693 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2013 Nikita Karetnikov +;;; Copyright © 2013 Mark H Weaver +;;; +;;; 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 . + +(define-module (guix scripts package) + #:use-module (guix ui) + #:use-module (guix store) + #:use-module (guix derivations) + #:use-module (guix packages) + #:use-module (guix utils) + #:use-module (guix config) + #:use-module ((guix build utils) #:select (directory-exists? mkdir-p)) + #:use-module (ice-9 ftw) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 vlist) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-37) + #:use-module (gnu packages) + #:use-module ((gnu packages base) #:select (guile-final)) + #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) + #:export (guix-package)) + +(define %store + (make-parameter #f)) + + +;;; +;;; User environment. +;;; + +(define %user-environment-directory + (and=> (getenv "HOME") + (cut string-append <> "/.guix-profile"))) + +(define %profile-directory + (string-append (or (getenv "NIX_STATE_DIR") %state-directory) "/profiles/" + (or (and=> (getenv "USER") + (cut string-append "per-user/" <>)) + "default"))) + +(define %current-profile + ;; Call it `guix-profile', not `profile', to allow Guix profiles to + ;; coexist with Nix profiles. + (string-append %profile-directory "/guix-profile")) + +(define (profile-manifest profile) + "Return the PROFILE's manifest." + (let ((manifest (string-append profile "/manifest"))) + (if (file-exists? manifest) + (call-with-input-file manifest read) + '(manifest (version 1) (packages ()))))) + +(define (manifest-packages manifest) + "Return the packages listed in MANIFEST." + (match manifest + (('manifest ('version 0) + ('packages ((name version output path) ...))) + (zip name version output path + (make-list (length name) '()))) + + ;; Version 1 adds a list of propagated inputs to the + ;; name/version/output/path tuples. + (('manifest ('version 1) + ('packages (packages ...))) + packages) + + (_ + (error "unsupported manifest format" manifest)))) + +(define (profile-regexp profile) + "Return a regular expression that matches PROFILE's name and number." + (make-regexp (string-append "^" (regexp-quote (basename profile)) + "-([0-9]+)"))) + +(define (profile-numbers profile) + "Return the list of generation numbers of PROFILE, or '(0) if no +former profiles were found." + (define* (scandir name #:optional (select? (const #t)) + (entry (file-system-fold enter? leaf down up skip error #f name lstat) + (lambda (files) + (sort files entry)) + (#f ; no profile directory + '(0)) + (() ; no profiles + '(0)) + ((profiles ...) ; former profiles around + (map (compose string->number + (cut match:substring <> 1) + (cute regexp-exec (profile-regexp profile) <>)) + profiles)))) + +(define (previous-profile-number profile number) + "Return the number of the generation before generation NUMBER of +PROFILE, or 0 if none exists. It could be NUMBER - 1, but it's not the +case when generations have been deleted (there are \"holes\")." + (fold (lambda (candidate highest) + (if (and (< candidate number) (> candidate highest)) + candidate + highest)) + 0 + (profile-numbers profile))) + +(define (profile-derivation store packages) + "Return a derivation that builds a profile (a user environment) with +all of PACKAGES, a list of name/version/output/path/deps tuples." + (define builder + `(begin + (use-modules (ice-9 pretty-print) + (guix build union)) + + (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-error-port) _IOLBF) + + (let ((output (assoc-ref %outputs "out")) + (inputs (map cdr %build-inputs))) + (format #t "building user environment `~a' with ~a packages...~%" + output (length inputs)) + (union-build output inputs) + (call-with-output-file (string-append output "/manifest") + (lambda (p) + (pretty-print '(manifest (version 1) + (packages ,packages)) + p)))))) + + (build-expression->derivation store "user-environment" + (%current-system) + builder + (append-map (match-lambda + ((name version output path deps) + `((,name ,path) + ,@deps))) + packages) + #:modules '((guix build union)))) + +(define (profile-number profile) + "Return PROFILE's number or 0. An absolute file name must be used." + (or (and=> (false-if-exception (regexp-exec (profile-regexp profile) + (basename (readlink profile)))) + (compose string->number (cut match:substring <> 1))) + 0)) + +(define (switch-symlinks link target) + "Atomically switch LINK, a symbolic link, to point to TARGET. Works +both when LINK already exists and when it does not." + (let ((pivot (string-append link ".new"))) + (symlink target pivot) + (rename-file pivot link))) + +(define (roll-back profile) + "Roll back to the previous generation of PROFILE." + (let* ((number (profile-number profile)) + (previous-number (previous-profile-number profile number)) + (previous-profile (format #f "~a-~a-link" + profile previous-number)) + (manifest (string-append previous-profile "/manifest"))) + + (define (switch-link) + ;; Atomically switch PROFILE to the previous profile. + (format #t (_ "switching from generation ~a to ~a~%") + number previous-number) + (switch-symlinks profile previous-profile)) + + (cond ((not (file-exists? profile)) ; invalid profile + (format (current-error-port) + (_ "error: profile `~a' does not exist~%") + profile)) + ((zero? number) ; empty profile + (format (current-error-port) + (_ "nothing to do: already at the empty profile~%"))) + ((or (zero? previous-number) ; going to emptiness + (not (file-exists? previous-profile))) + (let*-values (((drv-path drv) + (profile-derivation (%store) '())) + ((prof) + (derivation-output-path + (assoc-ref (derivation-outputs drv) "out")))) + (when (not (build-derivations (%store) (list drv-path))) + (leave (_ "failed to build the empty profile~%"))) + + (switch-symlinks previous-profile prof) + (switch-link))) + (else (switch-link))))) ; anything else + +(define (find-packages-by-description rx) + "Search in SYNOPSIS and DESCRIPTION using RX. Return a list of +matching packages." + (define (same-location? p1 p2) + ;; Compare locations of two packages. + (equal? (package-location p1) (package-location p2))) + + (delete-duplicates + (sort + (fold-packages (lambda (package result) + (define matches? + (cut regexp-exec rx <>)) + + (if (or (and=> (package-synopsis package) + (compose matches? gettext)) + (and=> (package-description package) + (compose matches? gettext))) + (cons package result) + result)) + '()) + (lambda (p1 p2) + (stringname+path input) + "Convert the name/package/sub-drv tuple INPUT to a name/store-path tuple." + (let loop ((input input)) + (match input + ((name package) + (loop `(,name ,package "out"))) + ((name package sub-drv) + (let*-values (((_ drv) + (package-derivation (%store) package)) + ((out) + (derivation-output-path + (assoc-ref (derivation-outputs drv) sub-drv)))) + `(,name ,out)))))) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + ;; Alist of default option values. + `((profile . ,%current-profile))) + +(define (show-help) + (display (_ "Usage: guix package [OPTION]... PACKAGES... +Install, remove, or upgrade PACKAGES in a single transaction.\n")) + (display (_ " + -i, --install=PACKAGE install PACKAGE")) + (display (_ " + -r, --remove=PACKAGE remove PACKAGE")) + (display (_ " + -u, --upgrade=REGEXP upgrade all the installed packages matching REGEXP")) + (display (_ " + --roll-back roll back to the previous generation")) + (newline) + (display (_ " + -p, --profile=PROFILE use PROFILE instead of the user's default profile")) + (display (_ " + -n, --dry-run show what would be done without actually doing it")) + (display (_ " + --bootstrap use the bootstrap Guile to build the profile")) + (display (_ " + --verbose produce verbose output")) + (newline) + (display (_ " + -s, --search=REGEXP search in synopsis and description using REGEXP")) + (display (_ " + -I, --list-installed[=REGEXP] + list installed packages matching REGEXP")) + (display (_ " + -A, --list-available[=REGEXP] + list available packages matching REGEXP")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix-package"))) + + (option '(#\i "install") #t #f + (lambda (opt name arg result) + (alist-cons 'install arg result))) + (option '(#\r "remove") #t #f + (lambda (opt name arg result) + (alist-cons 'remove arg result))) + (option '(#\u "upgrade") #t #f + (lambda (opt name arg result) + (alist-cons 'upgrade arg result))) + (option '("roll-back") #f #f + (lambda (opt name arg result) + (alist-cons 'roll-back? #t result))) + (option '(#\p "profile") #t #f + (lambda (opt name arg result) + (alist-cons 'profile arg + (alist-delete 'profile result)))) + (option '(#\n "dry-run") #f #f + (lambda (opt name arg result) + (alist-cons 'dry-run? #t result))) + (option '("bootstrap") #f #f + (lambda (opt name arg result) + (alist-cons 'bootstrap? #t result))) + (option '("verbose") #f #f + (lambda (opt name arg result) + (alist-cons 'verbose? #t result))) + (option '(#\s "search") #t #f + (lambda (opt name arg result) + (cons `(query search ,(or arg "")) + result))) + (option '(#\I "list-installed") #f #t + (lambda (opt name arg result) + (cons `(query list-installed ,(or arg "")) + result))) + (option '(#\A "list-available") #f #t + (lambda (opt name arg result) + (cons `(query list-available ,(or arg "")) + result))))) + + +;;; +;;; Entry point. +;;; + +(define (guix-package . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (leave (_ "~A: extraneous argument~%") arg)) + %default-options)) + + (define (guile-missing?) + ;; Return #t if %GUILE-FOR-BUILD is not available yet. + (let ((out (derivation-path->output-path (%guile-for-build)))) + (not (valid-path? (%store) out)))) + + (define (show-what-to-build drv dry-run?) + ;; Show what will/would be built in realizing the derivations listed + ;; in DRV. + (let* ((req (append-map (lambda (drv-path) + (let ((d (call-with-input-file drv-path + read-derivation))) + (derivation-prerequisites-to-build + (%store) d))) + drv)) + (req* (delete-duplicates + (append (remove (compose (cute valid-path? (%store) <>) + derivation-path->output-path) + drv) + (map derivation-input-path req))))) + (if dry-run? + (format (current-error-port) + (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]" + "~:[the following derivations would be built:~%~{ ~a~%~}~;~]" + (length req*)) + (null? req*) req*) + (format (current-error-port) + (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]" + "~:[the following derivations will be built:~%~{ ~a~%~}~;~]" + (length req*)) + (null? req*) req*)))) + + (define newest-available-packages + (memoize find-newest-available-packages)) + + (define (find-best-packages-by-name name version) + (if version + (find-packages-by-name name version) + (match (vhash-assoc name (newest-available-packages)) + ((_ version pkgs ...) pkgs) + (#f '())))) + + (define (find-package name) + ;; Find the package NAME; NAME may contain a version number and a + ;; sub-derivation name. If the version number is not present, + ;; return the preferred newest version. + (define request name) + + (define (ensure-output p sub-drv) + (if (member sub-drv (package-outputs p)) + p + (leave (_ "~a: error: package `~a' lacks output `~a'~%") + (location->string (package-location p)) + (package-full-name p) + sub-drv))) + + (let*-values (((name sub-drv) + (match (string-rindex name #\:) + (#f (values name "out")) + (colon (values (substring name 0 colon) + (substring name (+ 1 colon)))))) + ((name version) + (package-name->name+version name))) + (match (find-best-packages-by-name name version) + ((p) + (list name (package-version p) sub-drv (ensure-output p sub-drv) + (package-transitive-propagated-inputs p))) + ((p p* ...) + (format (current-error-port) + (_ "warning: ambiguous package specification `~a'~%") + request) + (format (current-error-port) + (_ "warning: choosing ~a from ~a~%") + (package-full-name p) + (location->string (package-location p))) + (list name (package-version p) sub-drv (ensure-output p sub-drv) + (package-transitive-propagated-inputs p))) + (() + (leave (_ "~a: package not found~%") request))))) + + (define (upgradeable? name current-version current-path) + ;; Return #t if there's a version of package NAME newer than + ;; CURRENT-VERSION, or if the newest available version is equal to + ;; CURRENT-VERSION but would have an output path different than + ;; CURRENT-PATH. + (match (vhash-assoc name (newest-available-packages)) + ((_ candidate-version pkg . rest) + (case (version-compare candidate-version current-version) + ((>) #t) + ((<) #f) + ((=) (let ((candidate-path (derivation-path->output-path + (package-derivation (%store) pkg)))) + (not (string=? current-path candidate-path)))))) + (#f #f))) + + (define (ensure-default-profile) + ;; Ensure the default profile symlink and directory exist. + + ;; Create ~/.guix-profile if it doesn't exist yet. + (when (and %user-environment-directory + %current-profile + (not (false-if-exception + (lstat %user-environment-directory)))) + (symlink %current-profile %user-environment-directory)) + + ;; Attempt to create /…/profiles/per-user/$USER if needed. + (unless (directory-exists? %profile-directory) + (catch 'system-error + (lambda () + (mkdir-p %profile-directory)) + (lambda args + ;; Often, we cannot create %PROFILE-DIRECTORY because its + ;; parent directory is root-owned and we're running + ;; unprivileged. + (format (current-error-port) + (_ "error: while creating directory `~a': ~a~%") + %profile-directory + (strerror (system-error-errno args))) + (format (current-error-port) + (_ "Please create the `~a' directory, with you as the owner.~%") + %profile-directory) + (exit 1))))) + + (define (process-actions opts) + ;; Process any install/remove/upgrade action from OPTS. + + (define dry-run? (assoc-ref opts 'dry-run?)) + (define verbose? (assoc-ref opts 'verbose?)) + (define profile (assoc-ref opts 'profile)) + + (define (canonicalize-deps deps) + ;; Remove duplicate entries from DEPS, a list of propagated inputs, + ;; where each input is a name/path tuple. + (define (same? d1 d2) + (match d1 + ((_ path1) + (match d2 + ((_ path2) + (string=? path1 path2)))))) + + (delete-duplicates (map input->name+path deps) same?)) + + ;; First roll back if asked to. + (if (and (assoc-ref opts 'roll-back?) (not dry-run?)) + (begin + (roll-back profile) + (process-actions (alist-delete 'roll-back? opts))) + (let* ((installed (manifest-packages (profile-manifest profile))) + (upgrade-regexps (filter-map (match-lambda + (('upgrade . regexp) + (make-regexp regexp)) + (_ #f)) + opts)) + (upgrade (if (null? upgrade-regexps) + '() + (let ((newest (find-newest-available-packages))) + (filter-map (match-lambda + ((name version output path _) + (and (any (cut regexp-exec <> name) + upgrade-regexps) + (upgradeable? name version path) + (find-package name))) + (_ #f)) + installed)))) + (install (append + upgrade + (filter-map (match-lambda + (('install . (? store-path?)) + #f) + (('install . package) + (find-package package)) + (_ #f)) + opts))) + (drv (filter-map (match-lambda + ((name version sub-drv + (? package? package) + (deps ...)) + (package-derivation (%store) package)) + (_ #f)) + install)) + (install* (append + (filter-map (match-lambda + (('install . (? store-path? path)) + (let-values (((name version) + (package-name->name+version + (store-path-package-name + path)))) + `(,name ,version #f ,path ()))) + (_ #f)) + opts) + (map (lambda (tuple drv) + (match tuple + ((name version sub-drv _ (deps ...)) + (let ((output-path + (derivation-path->output-path + drv sub-drv))) + `(,name ,version ,sub-drv ,output-path + ,(canonicalize-deps deps)))))) + install drv))) + (remove (filter-map (match-lambda + (('remove . package) + package) + (_ #f)) + opts)) + (packages (append install* + (fold (lambda (package result) + (match package + ((name _ ...) + (alist-delete name result)))) + (fold alist-delete installed remove) + install*)))) + + (when (equal? profile %current-profile) + (ensure-default-profile)) + + (show-what-to-build drv dry-run?) + + (or dry-run? + (and (build-derivations (%store) drv) + (let* ((prof-drv (profile-derivation (%store) packages)) + (prof (derivation-path->output-path prof-drv)) + (old-drv (profile-derivation + (%store) (manifest-packages + (profile-manifest profile)))) + (old-prof (derivation-path->output-path old-drv)) + (number (profile-number profile)) + + ;; Always use NUMBER + 1 for the new profile, + ;; possibly overwriting a "previous future + ;; generation". + (name (format #f "~a-~a-link" + profile (+ 1 number)))) + (if (string=? old-prof prof) + (when (or (pair? install) (pair? remove)) + (format (current-error-port) + (_ "nothing to be done~%"))) + (and (parameterize ((current-build-output-port + ;; Output something when Guile + ;; needs to be built. + (if (or verbose? (guile-missing?)) + (current-error-port) + (%make-void-port "w")))) + (build-derivations (%store) (list prof-drv))) + (begin + (switch-symlinks name prof) + (switch-symlinks profile name)))))))))) + + (define (process-query opts) + ;; Process any query specified by OPTS. Return #t when a query was + ;; actually processed, #f otherwise. + (let ((profile (assoc-ref opts 'profile))) + (match (assoc-ref opts 'query) + (('list-installed regexp) + (let* ((regexp (and regexp (make-regexp regexp))) + (manifest (profile-manifest profile)) + (installed (manifest-packages manifest))) + (for-each (match-lambda + ((name version output path _) + (when (or (not regexp) + (regexp-exec regexp name)) + (format #t "~a\t~a\t~a\t~a~%" + name (or version "?") output path)))) + installed) + #t)) + + (('list-available regexp) + (let* ((regexp (and regexp (make-regexp regexp))) + (available (fold-packages + (lambda (p r) + (let ((n (package-name p))) + (if regexp + (if (regexp-exec regexp n) + (cons p r) + r) + (cons p r)))) + '()))) + (for-each (lambda (p) + (format #t "~a\t~a\t~a\t~a~%" + (package-name p) + (package-version p) + (string-join (package-outputs p) ",") + (location->string (package-location p)))) + (sort available + (lambda (p1 p2) + (stringrecutils <> (current-output-port)) + (find-packages-by-description regexp)) + #t)) + (_ #f)))) + + (install-locale) + (textdomain "guix") + (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-error-port) _IOLBF) + + (let ((opts (parse-options))) + (or (process-query opts) + (parameterize ((%store (open-connection))) + (with-error-handling + (parameterize ((%guile-for-build + (package-derivation (%store) + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + guile-final)))) + (process-actions opts))))))) diff --git a/guix/ui.scm b/guix/ui.scm index 4aa93de3b4..644a3070f6 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2013 Mark H Weaver ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,6 +31,7 @@ #:export (_ N_ install-locale + initialize-guix leave show-version-and-exit show-bug-report-information @@ -38,7 +40,9 @@ location->string fill-paragraph string->recutils - package->recutils)) + package->recutils + run-guix-command + guix-main)) ;;; Commentary: ;;; @@ -62,6 +66,12 @@ (_ "warning: failed to install locale: ~a~%") (strerror (system-error-errno args)))))) +(define (initialize-guix) + (install-locale) + (textdomain "guix") + (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-error-port) _IOLBF)) + (define-syntax-rule (leave fmt args ...) "Format FMT and ARGS to the error port and exit." (begin @@ -210,4 +220,30 @@ WIDTH columns." (and=> (package-description p) description->recutils)) (newline port)) +(define (show-guix-usage) + ;; TODO: Dynamically generate a summary of available commands. + (format (current-error-port) + (_ "Usage: guix COMMAND ARGS...~%"))) + +(define (run-guix-command command . args) + ;; TODO: Gracefully report errors + (let* ((module (resolve-interface `(guix scripts ,command))) + (command-main (module-ref module + (symbol-append 'guix- command)))) + (apply command-main args))) + +(define (guix-main arg0 . args) + (initialize-guix) + (let () + (define (option? str) (string-prefix? "-" str)) + (match args + (() (show-guix-usage) (exit 1)) + (("--help") (show-guix-usage)) + (("--version") (show-version-and-exit "guix")) + (((? option? arg1) args ...) (show-guix-usage) (exit 1)) + ((command args ...) + (apply run-guix-command + (string->symbol command) + args))))) + ;;; ui.scm ends here diff --git a/po/POTFILES.in b/po/POTFILES.in index 049a1c707e..5c0f131c06 100644 --- a/po/POTFILES.in +++ b/po/POTFILES.in @@ -4,8 +4,8 @@ gnu/packages/base.scm gnu/packages/guile.scm gnu/packages/lout.scm gnu/packages/recutils.scm +guix/scripts/build.scm +guix/scripts/download.scm +guix/scripts/package.scm +guix/scripts/gc.scm guix/ui.scm -guix-build.in -guix-download.in -guix-package.in -guix-gc.in diff --git a/pre-inst-env.in b/pre-inst-env.in index 1dc63cd90c..4e079c8d41 100644 --- a/pre-inst-env.in +++ b/pre-inst-env.in @@ -27,9 +27,9 @@ GUILE_LOAD_COMPILED_PATH="@abs_top_builddir@${GUILE_LOAD_COMPILED_PATH:+:}$GUILE GUILE_LOAD_PATH="@abs_top_builddir@:@abs_top_srcdir@${GUILE_LOAD_PATH:+:}:$GUILE_LOAD_PATH" export GUILE_LOAD_COMPILED_PATH GUILE_LOAD_PATH -# Define $PATH so that `guix-build' and friends are easily found. +# Define $PATH so that `guix' and friends are easily found. -PATH="@abs_top_builddir@:$PATH" +PATH="@abs_top_builddir@/scripts:@abs_top_builddir@:$PATH" export PATH # Daemon helpers. @@ -43,7 +43,12 @@ export NIX_ROOT_FINDER NIX_SETUID_HELPER # auto-compilation. NIX_HASH="@NIX_HASH@" - export NIX_HASH +# Define $GUIX_UNINSTALLED to prevent `guix' from +# prepending @guilemoduledir@ to the Guile load paths. + +GUIX_UNINSTALLED=1 +export GUIX_UNINSTALLED + exec "$@" diff --git a/scripts/guix.in b/scripts/guix.in new file mode 100644 index 0000000000..2fdde7d13a --- /dev/null +++ b/scripts/guix.in @@ -0,0 +1,56 @@ +#!@GUILE@ -s +-*- scheme -*- +!# +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013 Mark H Weaver +;;; +;;; 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 . + +;; IMPORTANT: We must avoid loading any modules from Guix here, +;; because we need to adjust the guile load paths first. +;; It's okay to import modules from core Guile though. +(use-modules (ice-9 regex)) + +(let () + (define-syntax-rule (push! elt v) (set! v (cons elt v))) + + (define config-lookup + (let ((config '(("prefix" . "@prefix@") + ("datarootdir" . "@datarootdir@") + ("guilemoduledir" . "@guilemoduledir@"))) + (var-ref-regexp (make-regexp "\\$\\{([a-z]+)\\}"))) + (define (expand-var-ref match) + (lookup (match:substring match 1))) + (define (expand str) + (regexp-substitute/global #f var-ref-regexp str + 'pre expand-var-ref 'post)) + (define (lookup name) + (expand (assoc-ref config name))) + lookup)) + + (define (maybe-augment-load-paths!) + (unless (getenv "GUIX_UNINSTALLED") + (let ((module-dir (config-lookup "guilemoduledir"))) + (push! module-dir %load-path) + (push! module-dir %load-compiled-path)))) + + (define (run-guix-main) + (let ((guix-main (module-ref (resolve-interface '(guix ui)) + 'guix-main))) + (apply guix-main (command-line)))) + + (maybe-augment-load-paths!) + (run-guix-main)) diff --git a/tests/guix-build.sh b/tests/guix-build.sh index 5718b07d0c..721a7c6769 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -17,44 +17,44 @@ # along with GNU Guix. If not, see . # -# Test the `guix-build' command-line utility. +# Test the `guix build' command-line utility. # -guix-build --version +guix build --version # Should fail. -if guix-build -e +; +if guix build -e +; then false; else true; fi # Should fail because this is a source-less package. -if guix-build -e '(@ (gnu packages bootstrap) %bootstrap-glibc)' -S +if guix build -e '(@ (gnu packages bootstrap) %bootstrap-glibc)' -S then false; else true; fi # Should pass. -guix-build -e '(@@ (gnu packages base) %bootstrap-guile)' | \ +guix build -e '(@@ (gnu packages base) %bootstrap-guile)' | \ grep -e '-guile-' -guix-build hello -d | \ +guix build hello -d | \ grep -e '-hello-[0-9\.]\+\.drv$' # Should fail because the name/version combination could not be found. -if guix-build hello-0.0.1 -n; then false; else true; fi +if guix build hello-0.0.1 -n; then false; else true; fi # Keep a symlink to the result, registered as a root. result="t-result-$$" -guix-build -r "$result" \ +guix build -r "$result" \ -e '(@@ (gnu packages base) %bootstrap-guile)' test -x "$result/bin/guile" # Should fail, because $result already exists. -if guix-build -r "$result" -e '(@@ (gnu packages base) %bootstrap-guile)' +if guix build -r "$result" -e '(@@ (gnu packages base) %bootstrap-guile)' then false; else true; fi rm -f "$result" # Parsing package names and versions. -guix-build -n time # PASS -guix-build -n time-1.7 # PASS, version found -if guix-build -n time-3.2; # FAIL, version not found +guix build -n time # PASS +guix build -n time-1.7 # 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 +if guix build -n something-that-will-never-exist; # FAIL then false; else true; fi diff --git a/tests/guix-daemon.sh b/tests/guix-daemon.sh index 0d39ff4c24..698516490b 100644 --- a/tests/guix-daemon.sh +++ b/tests/guix-daemon.sh @@ -23,7 +23,7 @@ set -e guix-daemon --version -guix-build --version +guix build --version -guix-build -e '(@ (gnu packages bootstrap) %bootstrap-guile)' -guix-build coreutils -n +guix build -e '(@ (gnu packages bootstrap) %bootstrap-guile)' +guix build coreutils -n diff --git a/tests/guix-download.sh b/tests/guix-download.sh index f0ea731430..7af6f181f6 100644 --- a/tests/guix-download.sh +++ b/tests/guix-download.sh @@ -17,20 +17,20 @@ # along with GNU Guix. If not, see . # -# Test the `guix-download' command-line utility. +# Test the `guix download' command-line utility. # -guix-download --version +guix download --version # Make sure it fails here. -if guix-download http://does.not/exist +if guix download http://does.not/exist then false; else true; fi -if guix-download unknown://some/where; +if guix download unknown://some/where; then false; else true; fi -if guix-download not/a/uri; +if guix download not/a/uri; then false; else true; fi # This one should succeed. -guix-download "file://$abs_top_srcdir/README" +guix download "file://$abs_top_srcdir/README" diff --git a/tests/guix-gc.sh b/tests/guix-gc.sh index 805300eeec..a90d085ab2 100644 --- a/tests/guix-gc.sh +++ b/tests/guix-gc.sh @@ -17,38 +17,38 @@ # along with GNU Guix. If not, see . # -# Test the `guix-gc' command-line utility. +# Test the `guix gc' command-line utility. # -guix-gc --version +guix gc --version trap "rm -f guix-gc-root" EXIT rm -f guix-gc-root # Add then reclaim a .drv file. -drv="`guix-build idutils -d`" +drv="`guix build idutils -d`" test -f "$drv" -guix-gc --list-dead | grep "$drv" -guix-gc --delete "$drv" +guix gc --list-dead | grep "$drv" +guix gc --delete "$drv" ! test -f "$drv" # Add a .drv, register it as a root. -drv="`guix-build --root=guix-gc-root lsh -d`" +drv="`guix build --root=guix-gc-root lsh -d`" test -f "$drv" && test -L guix-gc-root -guix-gc --list-live | grep "$drv" -if guix-gc --delete "$drv"; +guix gc --list-live | grep "$drv" +if guix gc --delete "$drv"; then false; else true; fi rm guix-gc-root -guix-gc --list-dead | grep "$drv" -guix-gc --delete "$drv" +guix gc --list-dead | grep "$drv" +guix gc --delete "$drv" ! test -f "$drv" # Try a random collection. -guix-gc -C 1KiB +guix gc -C 1KiB # Check trivial error cases. -if guix-gc --delete /dev/null; +if guix gc --delete /dev/null; then false; else true; fi diff --git a/tests/guix-package.sh b/tests/guix-package.sh index 617318b796..cf8bc5c7e8 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -18,10 +18,10 @@ # along with GNU Guix. If not, see . # -# Test the `guix-package' command-line utility. +# Test the `guix package' command-line utility. # -guix-package --version +guix package --version readlink_base () { @@ -33,12 +33,12 @@ rm -f "$profile" trap 'rm "$profile" "$profile-"[0-9]* ; rm -rf t-home-'"$$" EXIT -guix-package --bootstrap -p "$profile" -i guile-bootstrap +guix package --bootstrap -p "$profile" -i guile-bootstrap test -L "$profile" && test -L "$profile-1-link" test -f "$profile/bin/guile" # Installing the same package a second time does nothing. -guix-package --bootstrap -p "$profile" -i guile-bootstrap +guix package --bootstrap -p "$profile" -i guile-bootstrap test -L "$profile" && test -L "$profile-1-link" ! test -f "$profile-2-link" test -f "$profile/bin/guile" @@ -46,8 +46,8 @@ test -f "$profile/bin/guile" # Check whether we have network access. if guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null then - boot_make="`guix-build -e '(@@ (gnu packages base) gnu-make-boot0)'`" - guix-package --bootstrap -p "$profile" -i "$boot_make" + boot_make="`guix build -e '(@@ (gnu packages base) gnu-make-boot0)'`" + guix package --bootstrap -p "$profile" -i "$boot_make" test -L "$profile-2-link" test -f "$profile/bin/make" && test -f "$profile/bin/guile" @@ -55,7 +55,7 @@ then # Check whether `--list-installed' works. # XXX: Change the tests when `--install' properly extracts the package # name and version string. - installed="`guix-package -p "$profile" --list-installed | cut -f1 | xargs echo | sort`" + installed="`guix package -p "$profile" --list-installed | cut -f1 | xargs echo | sort`" case "x$installed" in "guile-bootstrap make-boot0") true;; @@ -65,68 +65,68 @@ then false;; esac - test "`guix-package -p "$profile" -I 'g.*e' | cut -f1`" = "guile-bootstrap" + test "`guix package -p "$profile" -I 'g.*e' | cut -f1`" = "guile-bootstrap" # Search. - test "`guix-package -s "GNU Hello" | grep ^name:`" = "name: hello" - test "`guix-package -s "n0t4r341p4ck4g3"`" = "" + test "`guix package -s "GNU Hello" | grep ^name:`" = "name: hello" + test "`guix package -s "n0t4r341p4ck4g3"`" = "" # Remove a package. - guix-package --bootstrap -p "$profile" -r "guile-bootstrap" + guix package --bootstrap -p "$profile" -r "guile-bootstrap" test -L "$profile-3-link" test -f "$profile/bin/make" && ! test -f "$profile/bin/guile" # Roll back. - guix-package --roll-back -p "$profile" + guix package --roll-back -p "$profile" test "`readlink_base "$profile"`" = "$profile-2-link" test -x "$profile/bin/guile" && test -x "$profile/bin/make" - guix-package --roll-back -p "$profile" + guix package --roll-back -p "$profile" test "`readlink_base "$profile"`" = "$profile-1-link" test -x "$profile/bin/guile" && ! test -x "$profile/bin/make" # Move to the empty profile. for i in `seq 1 3` do - guix-package --bootstrap --roll-back -p "$profile" + guix package --bootstrap --roll-back -p "$profile" ! test -f "$profile/bin" ! test -f "$profile/lib" test "`readlink_base "$profile"`" = "$profile-0-link" done # Reinstall after roll-back to the empty profile. - guix-package --bootstrap -p "$profile" -i "$boot_make" + guix package --bootstrap -p "$profile" -i "$boot_make" test "`readlink_base "$profile"`" = "$profile-1-link" test -x "$profile/bin/guile" && ! test -x "$profile/bin/make" # Roll-back to generation 0, and install---all at once. - guix-package --bootstrap -p "$profile" --roll-back -i guile-bootstrap + guix package --bootstrap -p "$profile" --roll-back -i guile-bootstrap test "`readlink_base "$profile"`" = "$profile-1-link" test -x "$profile/bin/guile" && ! test -x "$profile/bin/make" # Install Make. - guix-package --bootstrap -p "$profile" -i "$boot_make" + guix package --bootstrap -p "$profile" -i "$boot_make" test "`readlink_base "$profile"`" = "$profile-2-link" test -x "$profile/bin/guile" && test -x "$profile/bin/make" # Make a "hole" in the list of generations, and make sure we can # roll back "over" it. rm "$profile-1-link" - guix-package --bootstrap -p "$profile" --roll-back + guix package --bootstrap -p "$profile" --roll-back test "`readlink_base "$profile"`" = "$profile-0-link" fi # Make sure the `:' syntax works. -guix-package --bootstrap -i "binutils:lib" -p "$profile" -n +guix package --bootstrap -i "binutils:lib" -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; +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"; +if guix package --bootstrap -i "guile-bootstrap:does-not-exist" -p "$profile"; then false; else true; fi # Check whether `--list-available' returns something sensible. -guix-package -A 'gui.*e' | grep guile +guix package -A 'gui.*e' | grep guile # # Try with the default profile. @@ -139,17 +139,17 @@ export HOME mkdir -p "$HOME" -guix-package --bootstrap -i guile-bootstrap +guix package --bootstrap -i guile-bootstrap test -L "$HOME/.guix-profile" test -f "$HOME/.guix-profile/bin/guile" if guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null then - guix-package --bootstrap -i "$boot_make" + guix package --bootstrap -i "$boot_make" test -f "$HOME/.guix-profile/bin/make" first_environment="`cd $HOME/.guix-profile ; pwd`" - guix-package --bootstrap --roll-back + guix package --bootstrap --roll-back test -f "$HOME/.guix-profile/bin/guile" ! test -f "$HOME/.guix-profile/bin/make" test "`cd $HOME/.guix-profile ; pwd`" = "$first_environment" @@ -159,12 +159,12 @@ fi default_profile="`readlink "$HOME/.guix-profile"`" for i in `seq 1 3` do - guix-package --bootstrap --roll-back + guix package --bootstrap --roll-back ! test -f "$HOME/.guix-profile/bin" ! test -f "$HOME/.guix-profile/lib" test "`readlink "$default_profile"`" = "$default_profile-0-link" done # Extraneous argument. -if guix-package install foo-bar; +if guix package install foo-bar; then false; else true; fi -- cgit v1.2.3 From c07512179ef50cc50067844ec7ab15a228c70ac9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 17 Feb 2013 15:38:02 +0100 Subject: scripts: Remove initialization now redundant with `initialize-guix'. * guix/scripts/build.scm (guix-build): Remove calls to `install-locale', `textdomain', etc., now redundant with `initialize-guix'. * guix/scripts/download.scm (guix-download): Likewise. * guix/scripts/import.scm (guix-import): Likewise. * guix/scripts/package.scm (guix-package): Likewise. * guix/ui.scm: Remove export of `install-locale' and `initialize-guix'. (initialize-guix): Add docstring. --- guix/scripts/build.scm | 5 ----- guix/scripts/download.scm | 5 ----- guix/scripts/import.scm | 5 ----- guix/scripts/package.scm | 5 ----- guix/ui.scm | 3 +-- 5 files changed, 1 insertion(+), 22 deletions(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index bad04418f1..3e241ca9da 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -221,11 +221,6 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) name version) (leave (_ "~A: unknown package~%") name)))))) - (install-locale) - (textdomain "guix") - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - (with-error-handling (let ((opts (parse-options))) (parameterize ((%store (open-connection))) diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 1098e6714b..790cf9fc2f 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -121,11 +121,6 @@ and the hash of its contents.\n")) (alist-cons 'argument arg result)) %default-options)) - (install-locale) - (textdomain "guix") - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - (let* ((opts (parse-options)) (store (open-connection)) (arg (assq-ref opts 'argument)) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 0bc6926c66..f0aaa80aa0 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -102,11 +102,6 @@ Import and convert the Nix expression ATTRIBUTE of NIXPKGS.\n")) (alist-cons 'argument arg result)) %default-options)) - (install-locale) - (textdomain "guix") - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - (let* ((opts (parse-options)) (args (filter-map (match-lambda (('argument . value) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 4935837d33..559be50824 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -676,11 +676,6 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) #t)) (_ #f)))) - (install-locale) - (textdomain "guix") - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - (let ((opts (parse-options))) (or (process-query opts) (parameterize ((%store (open-connection))) diff --git a/guix/ui.scm b/guix/ui.scm index 644a3070f6..af8b238ce1 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -30,8 +30,6 @@ #:use-module (ice-9 match) #:export (_ N_ - install-locale - initialize-guix leave show-version-and-exit show-bug-report-information @@ -67,6 +65,7 @@ (strerror (system-error-errno args)))))) (define (initialize-guix) + "Perform the usual initialization for stand-alone Guix commands." (install-locale) (textdomain "guix") (setvbuf (current-output-port) _IOLBF) -- cgit v1.2.3 From dc3f1809cf4637fcf30d9c1789fa0eb96aefd0f5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 17 Feb 2013 16:25:30 +0100 Subject: scripts: Remove hyphen in the command name shown by `--version'. * guix/scripts/build.scm (%options): Remove hyphen from the name passed to `show-version-and-exit'. * guix/scripts/download.scm (%options): Likewise. * guix/scripts/gc.scm (%options): Likewise. * guix/scripts/import.scm (%options): Likewise. * guix/scripts/package.scm (%options): Likewise. --- guix/scripts/build.scm | 2 +- guix/scripts/download.scm | 2 +- guix/scripts/gc.scm | 2 +- guix/scripts/import.scm | 2 +- guix/scripts/package.scm | 2 +- 5 files changed, 5 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 3e241ca9da..7863fb881b 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -105,7 +105,7 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (exit 0))) (option '(#\V "version") #f #f (lambda args - (show-version-and-exit "guix-build"))) + (show-version-and-exit "guix build"))) (option '(#\S "source") #f #f (lambda (opt name arg result) diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 790cf9fc2f..10370e59af 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -104,7 +104,7 @@ and the hash of its contents.\n")) (exit 0))) (option '(#\V "version") #f #f (lambda args - (show-version-and-exit "guix-download"))))) + (show-version-and-exit "guix download"))))) ;;; diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 8e2587186e..f2d2e17d4b 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -97,7 +97,7 @@ interpreted." (exit 0))) (option '(#\V "version") #f #f (lambda args - (show-version-and-exit "guix-gc"))) + (show-version-and-exit "guix gc"))) (option '(#\C "collect-garbage") #f #t (lambda (opt name arg result) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index f0aaa80aa0..0b95afced1 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -85,7 +85,7 @@ Import and convert the Nix expression ATTRIBUTE of NIXPKGS.\n")) (exit 0))) (option '(#\V "version") #f #f (lambda args - (show-version-and-exit "guix-import"))))) + (show-version-and-exit "guix import"))))) ;;; diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 559be50824..23786fb7d8 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -327,7 +327,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (exit 0))) (option '(#\V "version") #f #f (lambda args - (show-version-and-exit "guix-package"))) + (show-version-and-exit "guix package"))) (option '(#\i "install") #t #f (lambda (opt name arg result) -- cgit v1.2.3 From 05c0ac721e9411b1ac34f15a910b90bdf64b839a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 18 Feb 2013 21:53:59 +0100 Subject: store: Add the `%daemon-socket-file' parameter. * guix/store.scm (%daemon-socket-file): New variable. (open-connection): Use it as the default value for FILE. --- guix/store.scm | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 6a3f036a8c..3627d5be04 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -31,7 +31,9 @@ #:use-module (ice-9 rdelim) #:use-module (ice-9 ftw) #:use-module (ice-9 regex) - #:export (nix-server? + #:export (%daemon-socket-file + + nix-server? nix-server-major-version nix-server-minor-version nix-server-socket @@ -143,6 +145,12 @@ (string-append (or (getenv "NIX_STATE_DIR") %state-directory) "/daemon-socket/socket")) +(define %daemon-socket-file + ;; File name of the socket the daemon listens too. + (make-parameter (or (getenv "GUIX_DAEMON_SOCKET") + %default-socket-path))) + + ;; serialize.cc @@ -365,7 +373,7 @@ (message nix-protocol-error-message) (status nix-protocol-error-status)) -(define* (open-connection #:optional (file %default-socket-path) +(define* (open-connection #:optional (file (%daemon-socket-file)) #:key (reserve-space? #t)) "Connect to the daemon over the Unix-domain socket at FILE. When RESERVE-SPACE? is true, instruct it to reserve a little bit of extra -- cgit v1.2.3 From e95da445761bf95ee1f251d3be79f05c1379a6fa Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 20 Feb 2013 21:08:09 +0100 Subject: derivations: Add a search path parameter for module derivations. * guix/derivations.scm (imported-modules, compiled-modules): Add a `module-path' parameter. Use it instead of %LOAD-PATH. --- guix/derivations.scm | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index 60d57afa12..18a637ae5a 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -558,9 +558,10 @@ system, imported, and appears under FINAL-PATH in the resulting store path." (define* (imported-modules store modules #:key (name "module-import") (system (%current-system)) - (guile (%guile-for-build))) + (guile (%guile-for-build)) + (module-path %load-path)) "Return a derivation that contains the source files of MODULES, a list of -module names such as `(ice-9 q)'. All of MODULES must be in the current +module names such as `(ice-9 q)'. All of MODULES must be in the MODULE-PATH search path." ;; TODO: Determine the closure of MODULES, build the `.go' files, ;; canonicalize the source files through read/write, etc. @@ -568,7 +569,7 @@ search path." (let ((f (string-append (string-join (map symbol->string m) "/") ".scm"))) - (cons f (search-path %load-path f)))) + (cons f (search-path module-path f)))) modules))) (imported-files store files #:name name #:system system #:guile guile))) @@ -576,13 +577,15 @@ search path." (define* (compiled-modules store modules #:key (name "module-import-compiled") (system (%current-system)) - (guile (%guile-for-build))) + (guile (%guile-for-build)) + (module-path %load-path)) "Return a derivation that builds a tree containing the `.go' files corresponding to MODULES. All the MODULES are built in a context where they can refer to each other." (let* ((module-drv (imported-modules store modules #:system system - #:guile guile)) + #:guile guile + #:module-path module-path)) (module-dir (derivation-path->output-path module-drv)) (files (map (lambda (m) (let ((f (string-join (map symbol->string m) -- cgit v1.2.3 From cc68ccc5b08fff76d33c7062db35bdb646ed7ece Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 20 Feb 2013 22:59:35 +0100 Subject: download: Adjust to `http-get*' deprecation. * guix/build/download.scm (http-fetch): Adjust to use #:streaming? when using Guile 2.0.8+. --- guix/build/download.scm | 25 +++++++++++++++++-------- 1 file changed, 17 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index cda715993e..6c2e8235d0 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -178,17 +178,26 @@ which is not available during bootstrap." (define (http-fetch uri file) "Fetch data from URI and write it to FILE. Return FILE on success." + (define post-2.0.7? + (or (string>? (major-version) "2") + (string>? (minor-version) "0") + (string>? (micro-version) "7") + (string>? (version) "2.0.7"))) + (let*-values (((connection) (open-connection-for-uri uri)) ((resp bv-or-port) - ;; XXX: `http-get*' was introduced in 2.0.7. We know - ;; we're using it within the chroot, but - ;; `guix-download' might be using a different version. - ;; So keep this compatibility hack for now. - (if (module-defined? (resolve-interface '(web client)) - 'http-get*) - (http-get* uri #:port connection #:decode-body? #f) - (http-get uri #:port connection #:decode-body? #f))) + ;; XXX: `http-get*' was introduced in 2.0.7, and replaced by + ;; #:streaming? in 2.0.8. We know we're using it within the + ;; chroot, but `guix-download' might be using a different + ;; version. So keep this compatibility hack for now. + (if post-2.0.7? + (http-get uri #:port connection #:decode-body? #f + #:streaming? #t) + (if (module-defined? (resolve-interface '(web client)) + 'http-get*) + (http-get* uri #:port connection #:decode-body? #f) + (http-get uri #:port connection #:decode-body? #f)))) ((code) (response-code resp)) ((size) -- cgit v1.2.3 From bdeee95a214eedfde979958f62cee466c28e638f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 20 Feb 2013 23:03:24 +0100 Subject: ui: Add temporary file handling and atomic symlink switch. * guix/scripts/download.scm (call-with-temporary-output-file): Move to ui.scm. * guix/scripts/package.scm (switch-symlinks): Likewise. * guix/ui.scm (call-with-temporary-output-file, switch-symlinks): New procedures. --- guix/scripts/download.scm | 11 ----------- guix/scripts/package.scm | 7 ------- guix/ui.scm | 24 ++++++++++++++++++++++++ 3 files changed, 24 insertions(+), 18 deletions(-) (limited to 'guix') diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 10370e59af..3dc227fdcd 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -33,17 +33,6 @@ #:use-module (rnrs io ports) #:export (guix-download)) -(define (call-with-temporary-output-file proc) - (let* ((template (string-copy "guix-download.XXXXXX")) - (out (mkstemp! template))) - (dynamic-wind - (lambda () - #t) - (lambda () - (proc template out)) - (lambda () - (false-if-exception (delete-file template)))))) - (define (fetch-and-store store fetch name) "Call FETCH for URI, and pass it the name of a file to write to; eventually, copy data from that port to STORE, under NAME. Return the resulting diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 23786fb7d8..38e8ae1150 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -192,13 +192,6 @@ all of PACKAGES, a list of name/version/output/path/deps tuples." (compose string->number (cut match:substring <> 1))) 0)) -(define (switch-symlinks link target) - "Atomically switch LINK, a symbolic link, to point to TARGET. Works -both when LINK already exists and when it does not." - (let ((pivot (string-append link ".new"))) - (symlink target pivot) - (rename-file pivot link))) - (define (roll-back profile) "Roll back to the previous generation of PROFILE." (let* ((number (profile-number profile)) diff --git a/guix/ui.scm b/guix/ui.scm index af8b238ce1..9c27dd8b3a 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -36,6 +36,8 @@ call-with-error-handling with-error-handling location->string + call-with-temporary-output-file + switch-symlinks fill-paragraph string->recutils package->recutils @@ -125,6 +127,28 @@ General help using GNU software: ")) (($ file line column) (format #f "~a:~a:~a" file line column)))) +(define (call-with-temporary-output-file proc) + "Call PROC with a name of a temporary file and open output port to that +file; close the file and delete it when leaving the dynamic extent of this +call." + (let* ((template (string-copy "guix-file.XXXXXX")) + (out (mkstemp! template))) + (dynamic-wind + (lambda () + #t) + (lambda () + (proc template out)) + (lambda () + (false-if-exception (close out)) + (false-if-exception (delete-file template)))))) + +(define (switch-symlinks link target) + "Atomically switch LINK, a symbolic link, to point to TARGET. Works +both when LINK already exists and when it does not." + (let ((pivot (string-append link ".new"))) + (symlink target pivot) + (rename-file pivot link))) + (define* (fill-paragraph str width #:optional (column 0)) "Fill STR such that each line contains at most WIDTH characters, assuming that the first character is at COLUMN. -- cgit v1.2.3 From 7650e148f69832e6b89b93c549278b1bbf89946a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 20 Feb 2013 23:41:24 +0100 Subject: ui: Factorize `show-what-to-build'. * guix/scripts/package.scm (guix-package)[show-what-to-build]: Move to.. * guix/ui.scm (show-what-to-build): ... here. Add a `store' parameter'. Adjust callers. * guix/scripts/build.scm (guix-build): Use it. Remove `req' and `req*' variables. --- guix/scripts/build.scm | 23 ++--------------------- guix/scripts/package.scm | 28 +--------------------------- guix/ui.scm | 29 +++++++++++++++++++++++++++++ 3 files changed, 32 insertions(+), 48 deletions(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 7863fb881b..fbd22a9e29 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -241,31 +241,12 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (package-derivation (%store) p sys)))) (_ #f)) opts)) - (req (append-map (lambda (drv-path) - (let ((d (call-with-input-file drv-path - read-derivation))) - (derivation-prerequisites-to-build (%store) d))) - drv)) - (req* (delete-duplicates - (append (remove (compose (cut valid-path? (%store) <>) - derivation-path->output-path) - drv) - (map derivation-input-path req)))) (roots (filter-map (match-lambda (('gc-root . root) root) (_ #f)) opts))) - (if (assoc-ref opts 'dry-run?) - (format (current-error-port) - (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]" - "~:[the following derivations would be built:~%~{ ~a~%~}~;~]" - (length req*)) - (null? req*) req*) - (format (current-error-port) - (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]" - "~:[the following derivations will be built:~%~{ ~a~%~}~;~]" - (length req*)) - (null? req*) req*)) + + (show-what-to-build (%store) drv (assoc-ref opts 'dry-run?)) ;; TODO: Add more options. (set-build-options (%store) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 38e8ae1150..1f9355ff22 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -380,32 +380,6 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (let ((out (derivation-path->output-path (%guile-for-build)))) (not (valid-path? (%store) out)))) - (define (show-what-to-build drv dry-run?) - ;; Show what will/would be built in realizing the derivations listed - ;; in DRV. - (let* ((req (append-map (lambda (drv-path) - (let ((d (call-with-input-file drv-path - read-derivation))) - (derivation-prerequisites-to-build - (%store) d))) - drv)) - (req* (delete-duplicates - (append (remove (compose (cute valid-path? (%store) <>) - derivation-path->output-path) - drv) - (map derivation-input-path req))))) - (if dry-run? - (format (current-error-port) - (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]" - "~:[the following derivations would be built:~%~{ ~a~%~}~;~]" - (length req*)) - (null? req*) req*) - (format (current-error-port) - (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]" - "~:[the following derivations will be built:~%~{ ~a~%~}~;~]" - (length req*)) - (null? req*) req*)))) - (define newest-available-packages (memoize find-newest-available-packages)) @@ -589,7 +563,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (when (equal? profile %current-profile) (ensure-default-profile)) - (show-what-to-build drv dry-run?) + (show-what-to-build (%store) drv dry-run?) (or dry-run? (and (build-derivations (%store) drv) diff --git a/guix/ui.scm b/guix/ui.scm index 9c27dd8b3a..2b75504573 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -22,17 +22,20 @@ #:use-module (guix store) #:use-module (guix config) #:use-module (guix packages) + #:use-module (guix derivations) #:use-module ((guix licenses) #:select (license? license-name)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (ice-9 match) + #:use-module (ice-9 format) #:export (_ N_ leave show-version-and-exit show-bug-report-information + show-what-to-build call-with-error-handling with-error-handling location->string @@ -112,6 +115,32 @@ General help using GNU software: ")) (nix-protocol-error-message c)))) (thunk))) +(define* (show-what-to-build store drv #:optional dry-run?) + "Show what will or would (depending on DRY-RUN?) be built in realizing the +derivations listed in DRV." + (let* ((req (append-map (lambda (drv-path) + (let ((d (call-with-input-file drv-path + read-derivation))) + (derivation-prerequisites-to-build + store d))) + drv)) + (req* (delete-duplicates + (append (remove (compose (cute valid-path? store <>) + derivation-path->output-path) + drv) + (map derivation-input-path req))))) + (if dry-run? + (format (current-error-port) + (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]" + "~:[the following derivations would be built:~%~{ ~a~%~}~;~]" + (length req*)) + (null? req*) req*) + (format (current-error-port) + (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]" + "~:[the following derivations will be built:~%~{ ~a~%~}~;~]" + (length req*)) + (null? req*) req*)))) + (define-syntax with-error-handling (syntax-rules () "Run BODY within a user-friendly error condition handler." -- cgit v1.2.3 From 69ce1ffc7d5f12266e3a4cde605ca76a65c297b4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 20 Feb 2013 23:46:38 +0100 Subject: Add "guix pull". * guix/scripts/pull.scm: New file. * Makefile.am (MODULES): Add it. * doc/guix.texi (Invoking guix pull): New node. (Invoking guix package): Add cross-ref to it. * guix/ui.scm (config-directory): New procedure. * scripts/guix.in: When `GUIX_UNINSTALLED' is undefined, add $XDG_CONFIG_HOME/guix/latest to the search path. * po/POTFILES.in: Add guix/scripts/pull.scm. --- Makefile.am | 1 + doc/guix.texi | 33 ++++++++ guix/scripts/pull.scm | 222 ++++++++++++++++++++++++++++++++++++++++++++++++++ guix/ui.scm | 21 +++++ po/POTFILES.in | 1 + scripts/guix.in | 12 ++- 6 files changed, 288 insertions(+), 2 deletions(-) create mode 100644 guix/scripts/pull.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index cabbe21cdd..bed4d06ec0 100644 --- a/Makefile.am +++ b/Makefile.am @@ -30,6 +30,7 @@ MODULES = \ guix/scripts/import.scm \ guix/scripts/package.scm \ guix/scripts/gc.scm \ + guix/scripts/pull.scm \ guix/base32.scm \ guix/utils.scm \ guix/derivations.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 9245bd00f5..6a9ebab1f6 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -393,6 +393,7 @@ management tools it provides. * Features:: How Guix will make your life brighter. * Invoking guix package:: Package installation, removal, etc. * Invoking guix gc:: Running the garbage collector. +* Invoking guix pull:: Fetching the latest Guix and distribution. @end menu @node Features @@ -521,6 +522,11 @@ Remove @var{package}. @itemx -u @var{regexp} Upgrade all the installed packages matching @var{regexp}. +Note that this upgrades package to the latest version of packages found +in the distribution currently installed. To update your distribution, +you should regularly run @command{guix pull} (@pxref{Invoking guix +pull}). + @item --roll-back Roll back to the previous @dfn{generation} of the profile---i.e., undo the last transaction. @@ -654,6 +660,33 @@ Show the list of live store files and directories. @end table +@node Invoking guix pull +@section Invoking @command{guix pull} + +Packages are installed or upgraded to the latest version available in +the distribution currently available on your local machine. To update +that distribution, along with the Guix tools, you must run @command{guix +pull}: the command downloads the latest Guix source code and package +descriptions, and deploys it. + +On completion, @command{guix package} will use packages and package +versions from this just-retrieved copy of Guix. Not only that, but all +the Guix commands and Scheme modules will also be taken from that latest +version. New @command{guix} sub-commands added by the update also +become available. + +The @command{guix pull} command is usually invoked with no arguments, +but it supports the following options: + +@table @code +@item --verbose +Produce verbose output, writing build logs to the standard error output. + +@item --bootstrap +Use the bootstrap Guile to build the latest Guix. This option is only +useful to Guix developers. +@end table + @c ********************************************************************* @node Programming Interface @chapter Programming Interface diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm new file mode 100644 index 0000000000..f12133fff7 --- /dev/null +++ b/guix/scripts/pull.scm @@ -0,0 +1,222 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix scripts pull) + #:use-module (guix ui) + #:use-module (guix store) + #:use-module (guix config) + #:use-module (guix packages) + #:use-module (guix derivations) + #:use-module (guix build download) + #:use-module (gnu packages base) + #:use-module ((gnu packages bootstrap) + #:select (%bootstrap-guile)) + #:use-module (gnu packages compression) + #:use-module (gnu packages gnupg) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:export (guix-pull)) + +(define %snapshot-url + "http://hydra.gnu.org/job/guix/master/tarball/latest/download" + ;;"http://git.savannah.gnu.org/cgit/guix.git/snapshot/guix-master.tar.gz" + ) + +(define (download-and-store store) + "Download the latest Guix tarball, add it to STORE, and return its store +path." + ;; FIXME: Authenticate the downloaded file! + ;; FIXME: Optimize data transfers using rsync, Git, bsdiff, or GNUnet's DHT. + (call-with-temporary-output-file + (lambda (temp port) + (let ((result + (parameterize ((current-output-port (current-error-port))) + (url-fetch %snapshot-url temp)))) + (close port) + (and result + (add-to-store store "guix-latest.tar.gz" #f "sha256" temp)))))) + +(define (unpack store tarball) + "Return a derivation that unpacks TARBALL into STORE and compiles Scheme +files." + (define builder + `(begin + (use-modules (guix build utils) + (system base compile) + (ice-9 ftw) + (ice-9 match)) + + (let ((out (assoc-ref %outputs "out")) + (tar (assoc-ref %build-inputs "tar")) + (gzip (assoc-ref %build-inputs "gzip")) + (gcrypt (assoc-ref %build-inputs "gcrypt")) + (tarball (assoc-ref %build-inputs "tarball"))) + (setenv "PATH" (string-append tar "/bin:" gzip "/bin")) + + (system* "tar" "xvf" tarball) + (match (scandir "." (lambda (name) + (and (not (member name '("." ".."))) + (file-is-directory? name)))) + ((dir) + (chdir dir)) + (x + (error "tarball did not produce a single source directory" x))) + + (format #t "copying and compiling Guix to `~a'...~%" out) + + ;; Copy everything under guix/ and gnu/ plus guix.scm. + (file-system-fold (lambda (dir stat result) ; enter? + (or (string-prefix? "./guix" dir) + (string-prefix? "./gnu" dir) + (string=? "." dir))) + (lambda (file stat result) ; leaf + (when (or (not (string=? (dirname file) ".")) + (string=? (basename file) "guix.scm")) + (let ((target (string-drop file 1))) + (copy-file file + (string-append out target))))) + (lambda (dir stat result) ; down + (mkdir (string-append out + (string-drop dir 1)))) + (const #t) ; up + (const #t) ; skip + (lambda (file stat errno result) + (error "cannot access file" + file (strerror errno))) + #f + "." + lstat) + + ;; Add a fake (guix config) module to allow the other modules to be + ;; compiled. The user's (guix config) is the one that will be used. + (copy-file "guix/config.scm.in" + (string-append out "/guix/config.scm")) + (substitute* (string-append out "/guix/config.scm") + (("@LIBGCRYPT@") + (string-append gcrypt "/lib/libgcrypt"))) + + ;; Augment the search path so Scheme code can be compiled. + (set! %load-path (cons out %load-path)) + (set! %load-compiled-path (cons out %load-compiled-path)) + + ;; Compile the .scm files. + (for-each (lambda (file) + (when (string-suffix? ".scm" file) + (let ((go (string-append (string-drop-right file 4) + ".go"))) + (compile-file file + #:output-file go + #:opts %auto-compilation-options)))) + (find-files out "\\.scm")) + + ;; Remove the "fake" (guix config). + (delete-file (string-append out "/guix/config.scm")) + (delete-file (string-append out "/guix/config.go"))))) + + (build-expression->derivation store "guix-latest" (%current-system) + builder + `(("tar" ,(package-derivation store tar)) + ("gzip" ,(package-derivation store gzip)) + ("gcrypt" ,(package-derivation store + libgcrypt)) + ("tarball" ,tarball)) + #:modules '((guix build utils)))) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + ;; Alist of default option values. + '()) + +(define (show-help) + (display (_ "Usage: guix pull [OPTION]... +Download and deploy the latest version of Guix.\n")) + (display (_ " + --verbose produce verbose output")) + (display (_ " + --bootstrap use the bootstrap Guile to build the new Guix")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specifications of the command-line options. + (list (option '("verbose") #f #f + (lambda (opt name arg result) + (alist-cons 'verbose? #t result))) + (option '("bootstrap") #f #f + (lambda (opt name arg result) + (alist-cons 'bootstrap? #t result))) + + (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix pull"))))) + +(define (guix-pull . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (leave (_ "~A: unexpected argument~%") arg)) + %default-options)) + + (let ((opts (parse-options)) + (store (open-connection))) + (with-error-handling + (let ((tarball (download-and-store store))) + (unless tarball + (leave (_ "failed to download up-to-date source, exiting\n"))) + (parameterize ((%guile-for-build + (package-derivation store + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + guile-final))) + (current-build-output-port + (if (assoc-ref opts 'verbose?) + (current-error-port) + (%make-void-port "w")))) + (let*-values (((config-dir) + (config-directory)) + ((source drv) + (unpack store tarball)) + ((source-dir) + (derivation-output-path + (assoc-ref (derivation-outputs drv) "out")))) + (show-what-to-build store (list source)) + (if (build-derivations store (list source)) + (let ((latest (string-append config-dir "/latest"))) + (add-indirect-root store latest) + (switch-symlinks latest source-dir) + (format #t + (_ "updated ~a successfully deployed under `~a'~%") + %guix-package-name latest) + #t)))))))) diff --git a/guix/ui.scm b/guix/ui.scm index 2b75504573..7d1ea2bcbd 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -41,6 +41,7 @@ location->string call-with-temporary-output-file switch-symlinks + config-directory fill-paragraph string->recutils package->recutils @@ -178,6 +179,26 @@ both when LINK already exists and when it does not." (symlink target pivot) (rename-file pivot link))) +(define (config-directory) + "Return the name of the configuration directory, after making sure that it +exists. Honor the XDG specs, +." + (let ((dir (and=> (or (getenv "XDG_CONFIG_HOME") + (and=> (getenv "HOME") + (cut string-append <> "/.config"))) + (cut string-append <> "/guix")))) + (catch 'system-error + (lambda () + (mkdir dir) + dir) + (lambda args + (match (system-error-errno args) + ((or EEXIST 0) + dir) + (err + (leave (_ "failed to create configuration directory `~a': ~a~%") + dir (strerror err)))))))) + (define* (fill-paragraph str width #:optional (column 0)) "Fill STR such that each line contains at most WIDTH characters, assuming that the first character is at COLUMN. diff --git a/po/POTFILES.in b/po/POTFILES.in index 5c0f131c06..bdb894db20 100644 --- a/po/POTFILES.in +++ b/po/POTFILES.in @@ -8,4 +8,5 @@ guix/scripts/build.scm guix/scripts/download.scm guix/scripts/package.scm guix/scripts/gc.scm +guix/scripts/pull.scm guix/ui.scm diff --git a/scripts/guix.in b/scripts/guix.in index 2fdde7d13a..1315789a9c 100644 --- a/scripts/guix.in +++ b/scripts/guix.in @@ -22,7 +22,8 @@ ;; IMPORTANT: We must avoid loading any modules from Guix here, ;; because we need to adjust the guile load paths first. ;; It's okay to import modules from core Guile though. -(use-modules (ice-9 regex)) +(use-modules (ice-9 regex) + (srfi srfi-26)) (let () (define-syntax-rule (push! elt v) (set! v (cons elt v))) @@ -45,7 +46,14 @@ (unless (getenv "GUIX_UNINSTALLED") (let ((module-dir (config-lookup "guilemoduledir"))) (push! module-dir %load-path) - (push! module-dir %load-compiled-path)))) + (push! module-dir %load-compiled-path)) + (let ((updates-dir (and=> (or (getenv "XDG_CONFIG_HOME") + (and=> (getenv "HOME") + (cut string-append <> "/.config"))) + (cut string-append <> "/guix/latest")))) + (when (file-exists? updates-dir) + (push! updates-dir %load-path) + (push! updates-dir %load-compiled-path))))) (define (run-guix-main) (let ((guix-main (module-ref (resolve-interface '(guix ui)) -- cgit v1.2.3 From a1c14677564b90a67eec5865dd63345a35cafd42 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 22 Feb 2013 20:01:29 +0100 Subject: pull: Build (guix build download) first, because of the (gnutls) autoload. * guix/scripts/pull.scm (unpack): Build (guix build download) first, as done in 855a8ad71def2ebc594ed32c57bda0ca4e13d91c. Reported by Andreas Enge . --- guix/scripts/pull.scm | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index f12133fff7..42ff525524 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -123,7 +123,12 @@ files." (compile-file file #:output-file go #:opts %auto-compilation-options)))) - (find-files out "\\.scm")) + + ;; XXX: Because of the autoload hack in (guix build + ;; download), we must build it first to avoid errors since + ;; (gnutls) is unavailable. + (cons (string-append out "/guix/build/download.scm") + (find-files out "\\.scm"))) ;; Remove the "fake" (guix config). (delete-file (string-append out "/guix/config.scm")) -- cgit v1.2.3 From da9bf2efc56266d8717496c303a6d4b16de94b63 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 22 Feb 2013 21:08:06 +0100 Subject: pull: Distinguish "already up to date" from "updated". * guix/ui.scm (show-what-to-build): Return (length req*). * guix/scripts/pull.scm (guix-pull): Print an "already up to date" message when there's nothing to build. --- guix/scripts/pull.scm | 20 ++++++++++++-------- guix/ui.scm | 6 ++++-- 2 files changed, 16 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 42ff525524..942bf501c5 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -216,12 +216,16 @@ Download and deploy the latest version of Guix.\n")) ((source-dir) (derivation-output-path (assoc-ref (derivation-outputs drv) "out")))) - (show-what-to-build store (list source)) - (if (build-derivations store (list source)) - (let ((latest (string-append config-dir "/latest"))) - (add-indirect-root store latest) - (switch-symlinks latest source-dir) - (format #t - (_ "updated ~a successfully deployed under `~a'~%") - %guix-package-name latest) + (if (show-what-to-build store (list source)) + (if (build-derivations store (list source)) + (let ((latest (string-append config-dir "/latest"))) + (add-indirect-root store latest) + (switch-symlinks latest source-dir) + (format #t + (_ "updated ~a successfully deployed under `~a'~%") + %guix-package-name latest) + #t) + (leave (_ "failed to update Guix, check the build log~%"))) + (begin + (display (_ "Guix already up to date\n")) #t)))))))) diff --git a/guix/ui.scm b/guix/ui.scm index 7d1ea2bcbd..7e0c61b4f8 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -118,7 +118,8 @@ General help using GNU software: ")) (define* (show-what-to-build store drv #:optional dry-run?) "Show what will or would (depending on DRY-RUN?) be built in realizing the -derivations listed in DRV." +derivations listed in DRV. Return #t if there's something to build, #f +otherwise." (let* ((req (append-map (lambda (drv-path) (let ((d (call-with-input-file drv-path read-derivation))) @@ -140,7 +141,8 @@ derivations listed in DRV." (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]" "~:[the following derivations will be built:~%~{ ~a~%~}~;~]" (length req*)) - (null? req*) req*)))) + (null? req*) req*)) + (pair? req*))) (define-syntax with-error-handling (syntax-rules () -- cgit v1.2.3 From 8689a1908a8353b80ed1fcbb81feddc5eb799f24 Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Mon, 4 Mar 2013 10:14:34 +0100 Subject: guix: build: Add "share/pkgconfig" to PKG_CONFIG_PATH, as used by xorg. * guix/build/gnu-build-system.scm (set-paths): Add "share/pkgconfig" to PKG_CONFIG_PATH. --- guix/build/gnu-build-system.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index b7b9fdac95..8fc6f86507 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -73,7 +73,8 @@ ;; FIXME: Eventually move this to the `search-paths' field of the ;; `pkg-config' package. (set-path-environment-variable "PKG_CONFIG_PATH" - '("lib/pkgconfig" "lib64/pkgconfig") + '("lib/pkgconfig" "lib64/pkgconfig" + "share/pkgconfig") (relevant-input-directories "PKG_CONFIG_PATH")) ;; Dump the environment variables as a shell script, for handy debugging. -- cgit v1.2.3 From e65df6a63a49666edb4e57a68369b8e2ef02f1a0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 5 Mar 2013 18:53:53 +0100 Subject: utils: Add `delete-file-recursively'. * guix/build/utils.scm (delete-file-recursively): New procedure. --- guix/build/utils.scm | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) (limited to 'guix') diff --git a/guix/build/utils.scm b/guix/build/utils.scm index d17346607f..7b49e9f4c7 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -32,6 +32,7 @@ with-directory-excursion mkdir-p copy-recursively + delete-file-recursively find-files set-path-environment-variable @@ -147,6 +148,26 @@ return values of applying PROC to the port." #t source)) +(define (delete-file-recursively dir) + "Delete DIR recursively, like `rm -rf', without following symlinks. Report +but ignore errors." + (file-system-fold (const #t) ; enter? + (lambda (file stat result) ; leaf + (delete-file file)) + (const #t) ; down + (lambda (dir stat result) ; up + (rmdir dir)) + (const #t) ; skip + (lambda (file stat errno result) + (format (current-error-port) + "warning: failed to delete ~a: ~a~%" + file (strerror errno))) + #t + dir + + ;; Don't follow symlinks. + lstat)) + (define (find-files dir regexp) "Return the list of files under DIR whose basename matches REGEXP." (define file-rx -- cgit v1.2.3 From 12761f48eaa4801beb3b49aa94f2e8891869d186 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 5 Mar 2013 19:03:39 +0100 Subject: utils: Add a #:follow-symlinks? parameter to `copy-recursively'. * guix/build/utils.scm (copy-recursively): Turn `log' into a keyword parameter. Add the `follow-symlinks?' parameter and honor it. --- guix/build/utils.scm | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/build/utils.scm b/guix/build/utils.scm index 7b49e9f4c7..ef215e60bb 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -122,8 +122,11 @@ return values of applying PROC to the port." (() #t)))) (define* (copy-recursively source destination - #:optional (log (current-output-port))) - "Copy SOURCE directory to DESTINATION." + #:key + (log (current-output-port)) + (follow-symlinks? #f)) + "Copy SOURCE directory to DESTINATION. Follow symlinks if FOLLOW-SYMLINKS? +is true; otherwise, just preserve them. Write verbose output to the LOG port." (define strip-source (let ((len (string-length source))) (lambda (file) @@ -134,7 +137,12 @@ return values of applying PROC to the port." (let ((dest (string-append destination (strip-source file)))) (format log "`~a' -> `~a'~%" file dest) - (copy-file file dest))) + (case (stat:type stat) + ((symlink) + (let ((target (readlink file))) + (symlink target dest))) + (else + (copy-file file dest))))) (lambda (dir stat result) ; down (mkdir-p (string-append destination (strip-source dir)))) @@ -146,7 +154,11 @@ return values of applying PROC to the port." file (strerror errno)) #f) #t - source)) + source + + (if follow-symlinks? + stat + lstat))) (define (delete-file-recursively dir) "Delete DIR recursively, like `rm -rf', without following symlinks. Report -- cgit v1.2.3 From 0820a58b3ca29910efcf39b7f0fcdcbaf2a1364a Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Sun, 3 Mar 2013 19:50:26 +0100 Subject: gnu: xorg: Fix http mirror and uncomment xcb packages. * guix/download.scm (%mirrors): Fix main http mirror address. * gnu/packages/xorg.scm (libpthread-stubs, libxcb, xcb-proto): Uncomment and add licenses. --- gnu/packages/xorg.scm | 141 ++++++++++++++++++++++++-------------------------- guix/download.scm | 3 +- 2 files changed, 70 insertions(+), 74 deletions(-) (limited to 'guix') diff --git a/gnu/packages/xorg.scm b/gnu/packages/xorg.scm index ee6771b34d..ebabcab437 100644 --- a/gnu/packages/xorg.scm +++ b/gnu/packages/xorg.scm @@ -1341,27 +1341,26 @@ (license license:x11))) -;; file referenced, but not present on servers -;; (define-public libpthread-stubs -;; (package -;; (name "libpthread-stubs") -;; (version "0.3") -;; (source -;; (origin -;; (method url-fetch) -;; (uri (string-append -;; "mirror://xorg/X11R7.7/src/everything/libpthread-stubs-" -;; version -;; ".tar.bz2")) -;; (sha256 -;; (base32 -;; "16bjv3in19l84hbri41iayvvg4ls9gv1ma0x0qlbmwy67i7dbdim")))) -;; (build-system gnu-build-system) -;; (inputs `(("pkg-config" ,pkg-config))) -;; (home-page #f) -;; (synopsis #f) -;; (description #f) -;; (license license:???))) +(define-public libpthread-stubs + (package + (name "libpthread-stubs") + (version "0.3") + (source + (origin + (method url-fetch) + (uri (string-append + "mirror://xorg/X11R7.7/src/everything/libpthread-stubs-" + version + ".tar.bz2")) + (sha256 + (base32 + "16bjv3in19l84hbri41iayvvg4ls9gv1ma0x0qlbmwy67i7dbdim")))) + (build-system gnu-build-system) + (inputs `(("pkg-config" ,pkg-config))) + (home-page #f) + (synopsis #f) + (description #f) + (license license:x11))) (define-public libsm @@ -1492,35 +1491,34 @@ (license license:x11))) -;; file referenced, but not present on servers -;; (define-public libxcb -;; (package -;; (name "libxcb") -;; (version "1.8.1") -;; (source -;; (origin -;; (method url-fetch) -;; (uri (string-append -;; "mirror://xorg/X11R7.7/src/everything/libxcb-" -;; version -;; ".tar.bz2")) -;; (sha256 -;; (base32 -;; "15icn78x610dvvgnji6b3pyn8nd88lz68hq0w73pcadf78mycmw8")))) -;; (build-system gnu-build-system) -;; (inputs -;; `(("xproto" ,xproto) -;; ("libxdmcp" ,libxdmcp) -;; ("xcb-proto" ,xcb-proto) -;; ("libxau" ,libxau) -;; ("libpthread-stubs" ,libpthread-stubs) -;; ("libxslt" ,libxslt) -;; ("pkg-config" ,pkg-config) -;; ("python" ,python))) -;; (home-page #f) -;; (synopsis #f) -;; (description #f) -;; (license license:???))) +(define-public libxcb + (package + (name "libxcb") + (version "1.8.1") + (source + (origin + (method url-fetch) + (uri (string-append + "mirror://xorg/X11R7.7/src/everything/libxcb-" + version + ".tar.bz2")) + (sha256 + (base32 + "03gspxcdl8r7jwbwg7fyp4cc6zic9z91amp4g5z0wwahx48nix6j")))) + (build-system gnu-build-system) + (inputs + `(("xproto" ,xproto) + ("libxdmcp" ,libxdmcp) + ("xcb-proto" ,xcb-proto) + ("libxau" ,libxau) + ("libpthread-stubs" ,libpthread-stubs) + ("libxslt" ,libxslt) + ("pkg-config" ,pkg-config) + ("python" ,python))) + (home-page #f) + (synopsis #f) + (description #f) + (license license:x11))) (define-public libxcomposite @@ -2590,28 +2588,27 @@ (license license:x11))) -;; file referenced, but not present on servers -;; (define-public xcb-proto -;; (package -;; (name "xcb-proto") -;; (version "1.7.1") -;; (source -;; (origin -;; (method url-fetch) -;; (uri (string-append -;; "mirror://xorg/X11R7.7/src/everything/xcb-proto-" -;; version -;; ".tar.bz2")) -;; (sha256 -;; (base32 -;; "1c11652h9sjynw3scm1pn5z3a6ci888pq7hij8q5n8qrl33icg93")))) -;; (build-system gnu-build-system) -;; (inputs -;; `(("pkg-config" ,pkg-config) ("python" ,python))) -;; (home-page #f) -;; (synopsis #f) -;; (description #f) -;; (license license:x11))) +(define-public xcb-proto + (package + (name "xcb-proto") + (version "1.7.1") + (source + (origin + (method url-fetch) + (uri (string-append + "mirror://xorg/X11R7.7/src/everything/xcb-proto-" + version + ".tar.bz2")) + (sha256 + (base32 + "0ds4qg6slidrzyz6q9ckq0a19hn6blzpnvciy4brh741gn49jpdd")))) + (build-system gnu-build-system) + (inputs + `(("pkg-config" ,pkg-config) ("python" ,python))) + (home-page #f) + (synopsis #f) + (description #f) + (license license:x11))) (define-public xcmiscproto diff --git a/guix/download.scm b/guix/download.scm index b6bf6a0822..fa89058702 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -101,8 +101,7 @@ "http://mirrors.ircam.fr/pub/apache/" "http://apache-mirror.rbc.ru/pub/apache/") (xorg ; from http://www.x.org/wiki/Releases/Download - "http://xorg.freedesktop.org/releases/" ; main mirrors - "http://www.x.org/pub/" + "http://www.x.org/releases/" ; main mirrors "ftp://mirror.csclub.uwaterloo.ca/x.org/" ; North America "ftp://xorg.mirrors.pair.com/" "http://mirror.csclub.uwaterloo.ca/x.org/" -- cgit v1.2.3 From 30db6af1de2066430ac59cec7dbf0105c3230ff0 Mon Sep 17 00:00:00 2001 From: Nikita Karetnikov Date: Sun, 3 Mar 2013 23:20:28 +0000 Subject: utils: Add 'wrap-program'. * guix/build/utils.scm (wrap-program): New procedure. --- guix/build/utils.scm | 68 +++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 67 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/utils.scm b/guix/build/utils.scm index ef215e60bb..356dd46b52 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013 Ludovic Courtès ;;; Copyright © 2013 Andreas Enge +;;; Copyright © 2013 Nikita Karetnikov ;;; ;;; This file is part of GNU Guix. ;;; @@ -51,7 +52,8 @@ patch-shebang patch-makefile-SHELL fold-port-matches - remove-store-references)) + remove-store-references + wrap-program)) ;;; @@ -652,6 +654,70 @@ known as `nuke-refs' in Nixpkgs." (put-u8 out (char->integer char)) result)))))) +(define* (wrap-program prog #:rest vars) + "Rename PROG to .PROG-real and make PROG a wrapper. VARS should look like +this: + + '(VARIABLE DELIMITER POSITION LIST-OF-DIRECTORIES) + +where DELIMITER is optional. ':' will be used if DELIMITER is not given. + +For example, this command: + + (wrap-program \"foo\" + '(\"PATH\" \":\" = (\"/nix/.../bar/bin\")) + '(\"CERT_PATH\" suffix (\"/nix/.../baz/certs\" + \"/qux/certs\"))) + +will copy 'foo' to '.foo-real' and create the file 'foo' with the following +contents: + + #!location/of/bin/bash + export PATH=\"/nix/.../bar/bin\" + export CERT_PATH=\"$CERT_PATH${CERT_PATH:+:}/nix/.../baz/certs:/qux/certs\" + exec location/of/.foo-real + +This is useful for scripts that expect particular programs to be in $PATH, for +programs that expect particular shared libraries to be in $LD_LIBRARY_PATH, or +modules in $GUILE_LOAD_PATH, etc." + (let ((prog-real (string-append "." prog "-real")) + (prog-tmp (string-append "." prog "-tmp"))) + (define (export-variable lst) + ;; Return a string that exports an environment variable. + (match lst + ((var sep '= rest) + (format #f "export ~a=\"~a\"" + var (string-join rest sep))) + ((var sep 'prefix rest) + (format #f "export ~a=\"~a${~a~a+~a}$~a\"" + var (string-join rest sep) var sep sep var)) + ((var sep 'suffix rest) + (format #f "export ~a=\"$~a${~a~a+~a}~a\"" + var var var sep sep (string-join rest sep))) + ((var '= rest) + (format #f "export ~a=\"~a\"" + var (string-join rest ":"))) + ((var 'prefix rest) + (format #f "export ~a=\"~a${~a:+:}$~a\"" + var (string-join rest ":") var var)) + ((var 'suffix rest) + (format #f "export ~a=\"$~a${~a:+:}~a\"" + var var var (string-join rest ":"))))) + + (copy-file prog prog-real) + + (with-output-to-file prog-tmp + (lambda () + (format #t + "#!~a~%~a~%exec ~a~%" + (which "bash") + (string-join (map export-variable vars) + "\n") + (canonicalize-path prog-real)))) + + (chmod prog-tmp #o755) + (rename-file prog-tmp prog))) + ;;; Local Variables: ;;; eval: (put 'call-with-output-file/atomic 'scheme-indent-function 1) ;;; eval: (put 'with-throw-handler 'scheme-indent-function 1) -- cgit v1.2.3 From a96748bb46c6da65c7d66cb6d4f0d6f19febda27 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 30 Mar 2013 11:31:50 +0100 Subject: build-system/gnu: Remove #:path-exclusions parameter. * guix/build/gnu-build-system.scm (set-paths): Remove `path-exclusions' parameter. Replace `relevant-input-directories' by `input-directories'. * guix/build-system/gnu.scm (gnu-build): Remove `path-exclusions' parameter; don't pass it in BUILDER. * guix/build-system/cmake.scm (cmake-build): Likewise. --- guix/build-system/cmake.scm | 2 -- guix/build-system/gnu.scm | 2 -- guix/build/gnu-build-system.scm | 26 +++++++++----------------- 3 files changed, 9 insertions(+), 21 deletions(-) (limited to 'guix') diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm index 2a9db80cf8..9794f4d057 100644 --- a/guix/build-system/cmake.scm +++ b/guix/build-system/cmake.scm @@ -42,7 +42,6 @@ (patches ''()) (patch-flags ''("--batch" "-p1")) (cmake (@ (gnu packages cmake) cmake)) (out-of-source? #f) - (path-exclusions ''()) (tests? #t) (test-target "test") (parallel-build? #t) (parallel-tests? #f) @@ -77,7 +76,6 @@ provides a 'CMakeLists.txt' file as its build system." #:configure-flags ,configure-flags #:make-flags ,make-flags #:out-of-source? ,out-of-source? - #:path-exclusions ,path-exclusions #:tests? ,tests? #:test-target ,test-target #:parallel-build? ,parallel-build? diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index 8049e7510f..f4d0fa4f7c 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -163,7 +163,6 @@ System: GCC, GNU Make, Bash, Coreutils, etc." (make-flags ''()) (patches ''()) (patch-flags ''("--batch" "-p1")) (out-of-source? #f) - (path-exclusions ''()) (tests? #t) (test-target "check") (parallel-build? #t) (parallel-tests? #t) @@ -205,7 +204,6 @@ which could lead to gratuitous input divergence." #:configure-flags ,configure-flags #:make-flags ,make-flags #:out-of-source? ,out-of-source? - #:path-exclusions ,path-exclusions #:tests? ,tests? #:test-target ,test-target #:parallel-build? ,parallel-build? diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index 8fc6f86507..891c30df8f 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -48,34 +48,26 @@ #f dir)) -(define* (set-paths #:key inputs (path-exclusions '()) +(define* (set-paths #:key inputs #:allow-other-keys) - (define (relevant-input-directories env-var) - ;; Return the subset of INPUTS that should be considered when setting - ;; ENV-VAR. - (match (assoc-ref path-exclusions env-var) - (#f - (map cdr inputs)) - ((excluded ...) - (filter-map (match-lambda - ((name . dir) - (and (not (member name excluded)) - dir))) - inputs)))) + (define input-directories + (match inputs + (((_ . dir) ...) + dir))) (set-path-environment-variable "PATH" '("bin") - (relevant-input-directories "PATH")) + input-directories) (set-path-environment-variable "CPATH" '("include") - (relevant-input-directories "CPATH")) + input-directories) (set-path-environment-variable "LIBRARY_PATH" '("lib" "lib64") - (relevant-input-directories "LIBRARY_PATH")) + input-directories) ;; FIXME: Eventually move this to the `search-paths' field of the ;; `pkg-config' package. (set-path-environment-variable "PKG_CONFIG_PATH" '("lib/pkgconfig" "lib64/pkgconfig" "share/pkgconfig") - (relevant-input-directories "PKG_CONFIG_PATH")) + input-directories) ;; Dump the environment variables as a shell script, for handy debugging. (system "export > environment-variables")) -- cgit v1.2.3 From a18eda2747fa2eb962e3288066d2b1a679589ed3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 30 Mar 2013 22:56:38 +0100 Subject: packages: Add `native-search-paths' field and honor it. * guix/packages.scm (): New record type. (search-path-specification->sexp): New procedure. ()[native-search-paths]: New field. (package-derivation): Accumulate the search paths, and pass them as #:search-paths toe BUILDER. * guix/build-system/gnu.scm (gnu-build): Add #:search-paths. Compute `implicit-search-paths'. Pass #:search-paths in BUILDER. * guix/build-system/perl.scm (perl-build): Add #:search-paths, pass it to BUILDER with the search paths of PERL. * guix/build-system/cmake.scm (cmake-build): Add #:search-paths, pass it to BUILDER. * guix/build-system/trivial.scm (trivial-build): Add #:search-paths, ignore it. * guix/build/gnu-build-system.scm (set-paths): Add #:search-paths. Remove explicit settings of CPATH, LIBRARY_PATH, and PKG_CONFIG_PATH. Instead, walk SEARCH-PATHS and call `set-path-environment-variable' for them. * guix/build/perl-build-system.scm (perl-build): Remove PERL5LIB setting. * tests/packages.scm ("search paths"): New test. * gnu/packages/bootstrap.scm (%bootstrap-guile)[raw]: Add #:search-paths. (%bootstrap-gcc): Add `native-search-paths' field. * gnu/packages/perl.scm (perl): Likewise. * gnu/packages/pkg-config.scm (pkg-config): Likewise. * gnu/packages/glib.scm (intltool): Remove `arguments'. * gnu/packages/avahi.scm (avahi): Remove #:phases. --- gnu/packages/avahi.scm | 14 +----------- gnu/packages/bootstrap.scm | 10 +++++++- gnu/packages/gcc.scm | 8 +++++++ gnu/packages/glib.scm | 12 ---------- gnu/packages/perl.scm | 3 +++ gnu/packages/pkg-config.scm | 5 ++++ guix/build-system/cmake.scm | 3 +++ guix/build-system/gnu.scm | 25 +++++++++++++++++--- guix/build-system/perl.scm | 7 ++++++ guix/build-system/trivial.scm | 6 +++-- guix/build/gnu-build-system.scm | 20 +++++++--------- guix/build/perl-build-system.scm | 4 ---- guix/packages.scm | 49 ++++++++++++++++++++++++++++++++-------- tests/packages.scm | 36 +++++++++++++++++++++++++++++ 14 files changed, 145 insertions(+), 57 deletions(-) (limited to 'guix') diff --git a/gnu/packages/avahi.scm b/gnu/packages/avahi.scm index f7ce908351..fbdc0e2834 100644 --- a/gnu/packages/avahi.scm +++ b/gnu/packages/avahi.scm @@ -48,19 +48,7 @@ "--disable-xmltoman" "--enable-tests" "--disable-qt3" "--disable-qt4" - "--disable-gtk" "--disable-gtk3") - #:phases (alist-cons-before - 'configure 'set-perl-path - (lambda* (#:key inputs #:allow-other-keys) - ;; FIXME: Remove this phase when proper support for search - ;; paths is available. - (let ((xml-parser (assoc-ref inputs - "intltool/perl-xml-parser"))) - (setenv "PERL5LIB" - (string-append xml-parser - "/lib/perl5/site_perl")) - #t)) - %standard-phases))) + "--disable-gtk" "--disable-gtk3"))) (inputs `(("expat" ,expat) ("glib" ,glib) diff --git a/gnu/packages/bootstrap.scm b/gnu/packages/bootstrap.scm index 82a8db614f..eaad45a741 100644 --- a/gnu/packages/bootstrap.scm +++ b/gnu/packages/bootstrap.scm @@ -154,7 +154,8 @@ check whether everything is alright." (let ((raw (build-system (name "raw") (description "Raw build system with direct store access") - (build (lambda* (store name source inputs #:key outputs system) + (build (lambda* (store name source inputs + #:key outputs system search-paths) (define (->store file) (add-to-store store file #t "sha256" (or (search-bootstrap-binary file @@ -352,6 +353,13 @@ exec ~a/bin/.gcc-wrapped -B~a/lib \ ("i686-linux" (base32 "06wqs0xxnpw3hn0xjb4c9cs0899p1xwkcysa2rvzhvpra0c5vsg2"))))))))) + (native-search-paths + (list (search-path-specification + (variable "CPATH") + (directories '("include"))) + (search-path-specification + (variable "LIBRARY_PATH") + (directories '("lib" "lib64"))))) (synopsis "Bootstrap binaries of the GNU Compiler Collection") (description #f) (home-page #f) diff --git a/gnu/packages/gcc.scm b/gnu/packages/gcc.scm index a26dc24a4f..878d246c36 100644 --- a/gnu/packages/gcc.scm +++ b/gnu/packages/gcc.scm @@ -131,6 +131,14 @@ "install")))) %standard-phases))))) + (native-search-paths + (list (search-path-specification + (variable "CPATH") + (directories '("include"))) + (search-path-specification + (variable "LIBRARY_PATH") + (directories '("lib" "lib64"))))) + (properties `((gcc-libc . ,(assoc-ref inputs "libc")))) (synopsis "The GNU Compiler Collection") (description diff --git a/gnu/packages/glib.scm b/gnu/packages/glib.scm index fdcc9bdc31..7ff9ede22b 100644 --- a/gnu/packages/glib.scm +++ b/gnu/packages/glib.scm @@ -142,18 +142,6 @@ dynamic loading, and an object system.") (base32 "0r1vkvy5xzqk01yl6a0xlrry39bra24alkrx6279b77hc62my7jd")))) (build-system gnu-build-system) - (arguments - '(#:phases (alist-cons-before - 'configure 'set-perl-path - (lambda* (#:key inputs #:allow-other-keys) - ;; FIXME: Remove this phase when proper support for search - ;; paths is available. - (let ((xml-parser (assoc-ref inputs "perl-xml-parser"))) - (setenv "PERL5LIB" - (string-append xml-parser - "/lib/perl5/site_perl")) - #t)) - %standard-phases))) (native-inputs `(("pkg-config" ,pkg-config))) (propagated-inputs `(("gettext" ,guix:gettext) diff --git a/gnu/packages/perl.scm b/gnu/packages/perl.scm index 624d228059..c677a1b7e2 100644 --- a/gnu/packages/perl.scm +++ b/gnu/packages/perl.scm @@ -63,6 +63,9 @@ (string-append "-Dloclibpth=" libc "/lib"))))) %standard-phases))) (inputs `(("patch/no-sys-dirs" ,(search-patch "perl-no-sys-dirs.patch")))) + (native-search-paths (list (search-path-specification + (variable "PERL5LIB") + (directories '("lib/perl5/site_perl"))))) (synopsis "Implementation of the Perl programming language") (description "Perl 5 is a highly capable, feature-rich programming language with over diff --git a/gnu/packages/pkg-config.scm b/gnu/packages/pkg-config.scm index 0910a410ee..294163b474 100644 --- a/gnu/packages/pkg-config.scm +++ b/gnu/packages/pkg-config.scm @@ -36,6 +36,11 @@ "05wc5nwkqz7saj2v33ydmz1y6jdg659dll4jjh91n41m63gx0qsg")))) (build-system gnu-build-system) (arguments `(#:configure-flags '("--with-internal-glib"))) + (native-search-paths + (list (search-path-specification + (variable "PKG_CONFIG_PATH") + (directories '("lib/pkgconfig" "lib64/pkgconfig" + "share/pkgconfig"))))) (home-page "http://www.freedesktop.org/wiki/Software/pkg-config") (license gpl2+) (synopsis "a helper tool used when compiling applications and diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm index 9794f4d057..4e993f3961 100644 --- a/guix/build-system/cmake.scm +++ b/guix/build-system/cmake.scm @@ -38,6 +38,7 @@ (define* (cmake-build store name source inputs #:key (guile #f) (outputs '("out")) (configure-flags ''()) + (search-paths '()) (make-flags ''()) (patches ''()) (patch-flags ''("--batch" "-p1")) (cmake (@ (gnu packages cmake) cmake)) @@ -70,6 +71,8 @@ provides a 'CMakeLists.txt' file as its build system." #:system ,system #:outputs %outputs #:inputs %build-inputs + #:search-paths ',(map search-path-specification->sexp + search-paths) #:patches ,patches #:patch-flags ,patch-flags #:phases ,phases diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index f4d0fa4f7c..d5ad1e3e01 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -159,7 +159,9 @@ System: GCC, GNU Make, Bash, Coreutils, etc." (define* (gnu-build store name source inputs #:key (guile #f) - (outputs '("out")) (configure-flags ''()) + (outputs '("out")) + (search-paths '()) + (configure-flags ''()) (make-flags ''()) (patches ''()) (patch-flags ''("--batch" "-p1")) (out-of-source? #f) @@ -189,6 +191,21 @@ the builder's environment, from the host. Note that we distinguish between both, because for Guile's own modules like (ice-9 foo), we want to use GUILE's own version of it, rather than import the user's one, which could lead to gratuitous input divergence." + (define implicit-inputs + (and implicit-inputs? + (parameterize ((%store store)) + (standard-inputs system)))) + + (define implicit-search-paths + (if implicit-inputs? + (append-map (match-lambda + ((_ (? package? p) _ ...) + (package-native-search-paths p)) + (_ + '())) + implicit-inputs) + '())) + (define builder `(begin (use-modules ,@modules) @@ -198,6 +215,9 @@ which could lead to gratuitous input divergence." #:system ,system #:outputs %outputs #:inputs %build-inputs + #:search-paths ',(map search-path-specification->sexp + (append implicit-search-paths + search-paths)) #:patches ,patches #:patch-flags ,patch-flags #:phases ,phases @@ -231,8 +251,7 @@ which could lead to gratuitous input divergence." '()) ,@inputs ,@(if implicit-inputs? - (parameterize ((%store store)) - (standard-inputs system)) + implicit-inputs '())) #:outputs outputs #:modules imported-modules diff --git a/guix/build-system/perl.scm b/guix/build-system/perl.scm index 537c29e799..c97698e225 100644 --- a/guix/build-system/perl.scm +++ b/guix/build-system/perl.scm @@ -38,6 +38,7 @@ (define* (perl-build store name source inputs #:key (perl (@ (gnu packages perl) perl)) + (search-paths '()) (tests? #t) (make-maker-flags ''()) (phases '(@ (guix build perl-build-system) @@ -53,6 +54,9 @@ (guix build utils)))) "Build SOURCE using PERL, and with INPUTS. This assumes that SOURCE provides a `Makefile.PL' file as its build system." + (define perl-search-paths + (package-native-search-paths perl)) + (define builder `(begin (use-modules ,@modules) @@ -60,6 +64,9 @@ provides a `Makefile.PL' file as its build system." #:source ,(if (and source (derivation-path? source)) (derivation-path->output-path source) source) + #:search-paths ',(map search-path-specification->sexp + (append perl-search-paths + search-paths)) #:make-maker-flags ,make-maker-flags #:system ,system #:test-target "test" diff --git a/guix/build-system/trivial.scm b/guix/build-system/trivial.scm index e5bbeaa91d..2eb15aa2e0 100644 --- a/guix/build-system/trivial.scm +++ b/guix/build-system/trivial.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012 Ludovic Courtès +;;; Copyright © 2012, 2013 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,7 +26,9 @@ #:export (trivial-build-system)) (define* (trivial-build store name source inputs - #:key outputs guile system builder (modules '())) + #:key + outputs guile system builder (modules '()) + search-paths) "Run build expression BUILDER, an expression, for SYSTEM. SOURCE is ignored." (define guile-for-build diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index 891c30df8f..94a7d6bca8 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -48,26 +48,22 @@ #f dir)) -(define* (set-paths #:key inputs +(define* (set-paths #:key inputs (search-paths '()) #:allow-other-keys) (define input-directories (match inputs (((_ . dir) ...) dir))) - (set-path-environment-variable "PATH" '("bin") - input-directories) - (set-path-environment-variable "CPATH" '("include") - input-directories) - (set-path-environment-variable "LIBRARY_PATH" '("lib" "lib64") + (set-path-environment-variable "PATH" '("bin" "sbin") input-directories) - ;; FIXME: Eventually move this to the `search-paths' field of the - ;; `pkg-config' package. - (set-path-environment-variable "PKG_CONFIG_PATH" - '("lib/pkgconfig" "lib64/pkgconfig" - "share/pkgconfig") - input-directories) + (for-each (match-lambda + ((env-var (directories ...) separator) + (set-path-environment-variable env-var directories + input-directories + #:separator separator))) + search-paths) ;; Dump the environment variables as a shell script, for handy debugging. (system "export > environment-variables")) diff --git a/guix/build/perl-build-system.scm b/guix/build/perl-build-system.scm index d625ef3ed6..793b6aacb5 100644 --- a/guix/build/perl-build-system.scm +++ b/guix/build/perl-build-system.scm @@ -50,10 +50,6 @@ (define* (perl-build #:key inputs (phases %standard-phases) #:allow-other-keys #:rest args) "Build the given Perl package, applying all of PHASES in order." - (set-path-environment-variable "PERL5LIB" '("lib/perl5/site_perl") - (match inputs - (((_ . path) ...) - path))) (apply gnu:gnu-build #:inputs inputs #:phases phases args)) diff --git a/guix/packages.scm b/guix/packages.scm index 81f09d638e..3a6a07bbcc 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -37,6 +37,11 @@ origin-file-name base32 + + search-path-specification + search-path-specification? + search-path-specification->sexp + package package? package-name @@ -49,6 +54,7 @@ package-native-inputs package-propagated-inputs package-outputs + package-native-search-paths package-search-paths package-synopsis package-description @@ -104,8 +110,22 @@ representation." ((_ str) #'(nix-base32-string->bytevector str))))) -;; A package. +;; The specification of a search path. +(define-record-type* + search-path-specification make-search-path-specification + search-path-specification? + (variable search-path-specification-variable) + (directories search-path-specification-directories) + (separator search-path-specification-separator (default ":"))) + +(define (search-path-specification->sexp spec) + "Return an sexp representing SPEC, a . The sexp +corresponds to the arguments expected by `set-path-environment-variable'." + (match spec + (($ variable directories separator) + `(,variable ,directories ,separator)))) +;; A package. (define-record-type* package make-package package? @@ -128,10 +148,13 @@ representation." (outputs package-outputs ; list of strings (default '("out"))) - (search-paths package-search-paths ; list of (ENV-VAR (DIRS ...)) - (default '())) ; tuples; see - ; `set-path-environment-variable' - ; (aka. "setup-hook") + + ; lists of + ; , + ; for native and cross + ; inputs + (native-search-paths package-native-search-paths (default '())) + (search-paths package-search-paths (default '())) (synopsis package-synopsis) ; one-line description (description package-description) ; one or two paragraphs @@ -292,16 +315,22 @@ PACKAGE for SYSTEM." (($ name version source (= build-system-builder builder) args inputs propagated-inputs native-inputs self-native-input? outputs) - ;; TODO: For `search-paths', add a builder prologue that calls - ;; `set-path-environment-variable'. - (let ((inputs (map expand-input - (package-transitive-inputs package)))) + (let* ((inputs (package-transitive-inputs package)) + (input-drvs (map expand-input inputs)) + (paths (delete-duplicates + (append-map (match-lambda + ((_ (? package? p) _ ...) + (package-native-search-paths + p)) + (_ '())) + inputs)))) (apply builder store (package-full-name package) (and source (package-source-derivation store source system)) - inputs + input-drvs + #:search-paths paths #:outputs outputs #:system system (args)))))))) diff --git a/tests/packages.scm b/tests/packages.scm index c5d9d280ed..2d16f8a03f 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -22,6 +22,7 @@ #:use-module (guix utils) #:use-module (guix derivations) #:use-module (guix packages) + #:use-module (guix build-system) #:use-module (guix build-system trivial) #:use-module (guix build-system gnu) #:use-module (gnu packages) @@ -138,6 +139,41 @@ (let ((p (pk 'drv d (derivation-path->output-path d)))) (eq? 'hello (call-with-input-file p read)))))) +(test-assert "search paths" + (let* ((p (make-prompt-tag "return-search-paths")) + (s (build-system + (name "raw") + (description "Raw build system with direct store access") + (build (lambda* (store name source inputs + #:key outputs system search-paths) + search-paths)))) + (x (list (search-path-specification + (variable "GUILE_LOAD_PATH") + (directories '("share/guile/site/2.0"))) + (search-path-specification + (variable "GUILE_LOAD_COMPILED_PATH") + (directories '("share/guile/site/2.0"))))) + (a (package (inherit (dummy-package "guile")) + (build-system s) + (native-search-paths x))) + (b (package (inherit (dummy-package "guile-foo")) + (build-system s) + (inputs `(("guile" ,a))))) + (c (package (inherit (dummy-package "guile-bar")) + (build-system s) + (inputs `(("guile" ,a) + ("guile-foo" ,b)))))) + (let-syntax ((collect (syntax-rules () + ((_ body ...) + (call-with-prompt p + (lambda () + body ...) + (lambda (k search-paths) + search-paths)))))) + (and (null? (collect (package-derivation %store a))) + (equal? x (collect (package-derivation %store b))) + (equal? x (collect (package-derivation %store c))))))) + (unless (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)) (test-skip 1)) (test-assert "GNU Make, bootstrap" -- cgit v1.2.3 From 068cdcd07c59ab8228c7c5580f6fd162069e3999 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 9 Apr 2013 19:01:21 +0200 Subject: build-system/gnu: Fix search path computation with implicit inputs. Reported by Andreas Enge . * guix/build-system/gnu.scm (standard-packages): New procedure. (standard-inputs): Use it instead of resolving things locally. (gnu-build)[implicit-search-paths]: Map over (standard-packages), not over STANDARD-INPUTS. --- guix/build-system/gnu.scm | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index d5ad1e3e01..3b3d99b313 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -135,6 +135,14 @@ use `--strip-all' as the arguments to `strip'." ;; Store passed to STANDARD-INPUTS. (make-parameter #f)) +(define (standard-packages) + "Return the list of (NAME PACKAGE OUTPUT) or (NAME PACKAGE) tuples of +standard packages used as implicit inputs of the GNU build system." + + ;; Resolve (gnu packages base) lazily to hide circular dependency. + (let ((distro (resolve-module '(gnu packages base)))) + (module-ref distro '%final-inputs))) + (define standard-inputs (memoize (lambda (system) @@ -148,9 +156,7 @@ System: GCC, GNU Make, Bash, Coreutils, etc." (z (error "invalid standard input" z))) - ;; Resolve (gnu packages base) lazily to hide circular dependency. - (let* ((distro (resolve-module '(gnu packages base))) - (inputs (module-ref distro '%final-inputs))) + (let ((inputs (standard-packages))) (append inputs (append-map (match-lambda ((name package _ ...) @@ -203,7 +209,7 @@ which could lead to gratuitous input divergence." (package-native-search-paths p)) (_ '())) - implicit-inputs) + (standard-packages)) '())) (define builder -- cgit v1.2.3 From bdf06d8922e62f725f94560c1aa1f00e3392b624 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 31 Mar 2013 12:46:28 +0200 Subject: pull: Switch to the cgit URL. * guix/scripts/pull.scm (%snapshot-url): Switch to the cgit URL, given that the Hydra one is not currently available. --- guix/scripts/pull.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index bc72dc4088..c5facd84d5 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -34,8 +34,8 @@ #:export (guix-pull)) (define %snapshot-url - "http://hydra.gnu.org/job/guix/master/tarball/latest/download" - ;;"http://git.savannah.gnu.org/cgit/guix.git/snapshot/guix-master.tar.gz" + ;; "http://hydra.gnu.org/job/guix/master/tarball/latest/download" + "http://git.savannah.gnu.org/cgit/guix.git/snapshot/guix-master.tar.gz" ) (define (download-and-store store) -- cgit v1.2.3 From 5477e0342f477bafc0fd23d7ea85288fdd3a0fb7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 1 Apr 2013 00:41:55 +0200 Subject: gnu-maintenance: Adjust `http-fetch' to the various Guile versions. * guix/gnu-maintenance.scm (http-fetch): Try #:streaming? #t, or 'http-get*', or 'http-get' as a last resort. Check whether DATA is #f, a string, or an input port. --- guix/gnu-maintenance.scm | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 979678d076..89e7f25589 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -66,12 +66,18 @@ (define (http-fetch uri) "Return an input port containing the textual data at URI, a string." (let*-values (((resp data) - (http-get (string->uri uri))) + (let ((uri (string->uri uri))) + ;; Try hard to use the API du jour to get an input port. + (if (version>? "2.0.7" (version)) + (if (defined? 'http-get*) + (http-get* uri) + (http-get uri)) ; old Guile, returns a string + (http-get uri #:streaming? #t)))) ; 2.0.8 or later ((code) (response-code resp))) (case code ((200) - (cond ((string<=? (version) "2.0.5") + (cond ((not data) (begin ;; XXX: Guile 2.0.5 and earlier did not support chunked transfer ;; encoding, which is required when fetching %PACKAGE-LIST-URL @@ -85,9 +91,10 @@ (response-transfer-encoding resp)) (error "download failed; use a newer Guile" uri resp))) - ((string<=? (version) "2.0.7") + ((string? data) ; old `http-get' returns a string (open-input-string data)) - (else data))) + (else ; input port + data))) (else (error "download failed" uri code (response-reason-phrase resp)))))) -- cgit v1.2.3 From afb49942e032000ba03ae879a7a1d29803aac094 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 1 Apr 2013 16:08:31 +0200 Subject: store: Add `store-path-hash-part'. * guix/store.scm (store-path-hash-part): New procedure. * tests/store.scm ("store-path-hash-part", "store-path-hash-part #f"): New tests. --- guix/store.scm | 12 +++++++++++- tests/store.scm | 12 ++++++++++++ 2 files changed, 23 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 4d078c5899..3bb2656bb6 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -83,7 +83,8 @@ %store-prefix store-path? derivation-path? - store-path-package-name)) + store-path-package-name + store-path-hash-part)) (define %protocol-version #x10c) @@ -751,3 +752,12 @@ collected, and the number of bytes freed." (and=> (regexp-exec store-path-rx path) (cut match:substring <> 1))) + +(define (store-path-hash-part path) + "Return the hash part of PATH as a base32 string, or #f if PATH is not a +syntactically valid store path." + (let ((path-rx (make-regexp + (string-append"^" (regexp-quote (%store-prefix)) + "/([0-9a-df-np-sv-z]{32})-[^/]+$")))) + (and=> (regexp-exec path-rx path) + (cut match:substring <> 1)))) diff --git a/tests/store.scm b/tests/store.scm index c2de99e160..d6e1aa54e3 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -48,6 +48,18 @@ (test-begin "store") +(test-equal "store-path-hash-part" + "283gqy39v3g9dxjy26rynl0zls82fmcg" + (store-path-hash-part + (string-append (%store-prefix) + "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7"))) + +(test-equal "store-path-hash-part #f" + #f + (store-path-hash-part + (string-append (%store-prefix) + "/foo/bar/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7"))) + (test-skip (if %store 0 10)) (test-assert "dead-paths" -- cgit v1.2.3 From 419fffa2e84bdcfee13572e1b346a7487926113d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 2 Apr 2013 10:44:20 +0200 Subject: Add preliminary binary substituter. * guix/scripts/substitute-binary.scm: New file. * Makefile.am (MODULES): Add it. * nix/scripts/substitute-binary.in: New file. * config-daemon.ac: Produce nix/scripts/substitute-binary. * daemon.am (nodist_pkglibexec_SCRIPTS): Add nix/scripts/substitute-binary. * guix/store.scm (substitutable-path-info): Use the `query-substitutable-path-infos' RPC. * nix/nix-daemon/guix-daemon.cc (main): Honor `NIX_SUBSTITUTERS'. * pre-inst-env.in: Set `NIX_SUBSTITUTERS'. * test-env.in: Leave `NIX_SUBSTITUTERS' unchanged. Set `GUIX_BINARY_SUBSTITUTE_URL, and create $NIX_STATE_DIR/substituter-data. Run `guix-daemon' within `./pre-inst-env'. * tests/store.scm ("substitute query"): New test. --- .gitignore | 1 + Makefile.am | 1 + config-daemon.ac | 5 +- daemon.am | 3 +- guix/scripts/substitute-binary.scm | 232 +++++++++++++++++++++++++++++++++++++ guix/store.scm | 2 +- nix/nix-daemon/guix-daemon.cc | 12 +- nix/scripts/substitute-binary.in | 11 ++ pre-inst-env.in | 3 +- test-env.in | 17 ++- tests/store.scm | 39 +++++++ 11 files changed, 313 insertions(+), 13 deletions(-) create mode 100755 guix/scripts/substitute-binary.scm create mode 100644 nix/scripts/substitute-binary.in (limited to 'guix') diff --git a/.gitignore b/.gitignore index 302e473fd8..f2b1f1cd39 100644 --- a/.gitignore +++ b/.gitignore @@ -72,3 +72,4 @@ stamp-h[0-9] /doc/guix.tp /doc/guix.vr /doc/guix.vrs +/nix/scripts/substitute-binary diff --git a/Makefile.am b/Makefile.am index 722b3b79fe..8b3057fd0b 100644 --- a/Makefile.am +++ b/Makefile.am @@ -31,6 +31,7 @@ MODULES = \ guix/scripts/package.scm \ guix/scripts/gc.scm \ guix/scripts/pull.scm \ + guix/scripts/substitute-binary.scm \ guix/base32.scm \ guix/utils.scm \ guix/derivations.scm \ diff --git a/config-daemon.ac b/config-daemon.ac index f48741dfda..eed1e23f9e 100644 --- a/config-daemon.ac +++ b/config-daemon.ac @@ -93,8 +93,9 @@ if test "x$guix_build_daemon" = "xyes"; then AC_MSG_RESULT([$GUIX_TEST_ROOT]) AC_SUBST([GUIX_TEST_ROOT]) - AC_CONFIG_FILES([nix/scripts/list-runtime-roots], - [chmod +x nix/scripts/list-runtime-roots]) + AC_CONFIG_FILES([nix/scripts/list-runtime-roots + nix/scripts/substitute-binary], + [chmod +x nix/scripts/list-runtime-roots nix/scripts/substitute-binary]) fi AM_CONDITIONAL([BUILD_DAEMON], [test "x$guix_build_daemon" = "xyes"]) diff --git a/daemon.am b/daemon.am index 4f2314b773..069700b1b6 100644 --- a/daemon.am +++ b/daemon.am @@ -159,7 +159,8 @@ nix/libstore/schema.sql.hh: nix/libstore/schema.sql (write (get-string-all in) out)))))" nodist_pkglibexec_SCRIPTS = \ - nix/scripts/list-runtime-roots + nix/scripts/list-runtime-roots \ + nix/scripts/substitute-binary EXTRA_DIST += \ nix/sync-with-upstream \ diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm new file mode 100755 index 0000000000..6e886b6c96 --- /dev/null +++ b/guix/scripts/substitute-binary.scm @@ -0,0 +1,232 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix scripts substitute-binary) + #:use-module (guix ui) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (ice-9 match) + #:use-module (ice-9 threads) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (web uri) + #:use-module (web client) + #:use-module (web response) + #:export (guix-substitute-binary)) + +;;; Comment: +;;; +;;; This is the "binary substituter". It is invoked by the daemon do check +;;; for the existence of available "substitutes" (pre-built binaries), and to +;;; actually use them as a substitute to building things locally. +;;; +;;; If possible, substitute a binary for the requested store path, using a Nix +;;; "binary cache". This program implements the Nix "substituter" protocol. +;;; +;;; Code: + +(define (fields->alist port) + "Read recutils-style record from PORT and return them as a list of key/value +pairs." + (define field-rx + (make-regexp "^([[:graph:]]+): (.*)$")) + + (let loop ((line (read-line port)) + (result '())) + (cond ((eof-object? line) + (reverse result)) + ((regexp-exec field-rx line) + => + (lambda (match) + (loop (read-line port) + (alist-cons (match:substring match 1) + (match:substring match 2) + result)))) + (else + (error "unmatched line" line))))) + +(define (alist->record alist make keys) + "Apply MAKE to the values associated with KEYS in ALIST." + (let ((args (map (cut assoc-ref alist <>) keys))) + (apply make args))) + +(define (fetch uri) + (case (uri-scheme uri) + ((file) + (open-input-file (uri-path uri))) + ((http) + (let*-values (((resp port) + ;; XXX: `http-get*' was introduced in 2.0.7, and deprecated + ;; in 2.0.8 (!). Assume it is available here. + (if (version>? "2.0.7" (version)) + (http-get* uri #:decode-body? #f) + (http-get uri #:streaming? #t))) + ((code) + (response-code resp)) + ((size) + (response-content-length resp))) + (case code + ((200) ; OK + port) + ((301 ; moved permanently + 302) ; found (redirection) + (let ((uri (response-location resp))) + (format #t "following redirection to `~a'...~%" + (uri->string uri)) + (fetch uri))) + (else + (error "download failed" (uri->string uri) + code (response-reason-phrase resp)))))))) + +(define-record-type + (%make-cache url store-directory wants-mass-query?) + cache? + (url cache-url) + (store-directory cache-store-directory) + (wants-mass-query? cache-wants-mass-query?)) + +(define (open-cache url) + "Open the binary cache at URL. Return a object on success, or #f on +failure." + (define (download-cache-info url) + ;; Download the `nix-cache-info' from URL, and return its contents as an + ;; list of key/value pairs. + (and=> (false-if-exception (fetch (string->uri url))) + fields->alist)) + + (and=> (download-cache-info (string-append url "/nix-cache-info")) + (lambda (properties) + (alist->record properties + (cut %make-cache url <...>) + '("StoreDir" "WantMassQuery"))))) + +(define-record-type + (%make-narinfo path url compression file-hash file-size nar-hash nar-size + references deriver system) + narinfo? + (path narinfo-path) + (url narinfo-url) + (compression narinfo-compression) + (file-hash narinfo-file-hash) + (file-size narinfo-file-size) + (nar-hash narinfo-hash) + (nar-size narinfo-size) + (references narinfo-references) + (deriver narinfo-deriver) + (system narinfo-system)) + +(define (make-narinfo path url compression file-hash file-size nar-hash nar-size + references deriver system) + "Return a new object." + (%make-narinfo path url compression file-hash + (and=> file-size string->number) + nar-hash + (and=> nar-size string->number) + (string-tokenize references) + (match deriver + ((or #f "") #f) + (_ deriver)) + system)) + +(define (fetch-narinfo cache path) + "Return the record for PATH, or #f if CACHE does not hold PATH." + (define (download url) + ;; Download the `nix-cache-info' from URL, and return its contents as an + ;; list of key/value pairs. + (and=> (false-if-exception (fetch (string->uri url))) + fields->alist)) + + (and=> (download (string-append (cache-url cache) "/" + (store-path-hash-part path) + ".narinfo")) + (lambda (properties) + (alist->record properties make-narinfo + '("StorePath" "URL" "Compression" + "FileHash" "FileSize" "NarHash" "NarSize" + "References" "Deriver" "System"))))) + +(define %cache-url + (or (getenv "GUIX_BINARY_SUBSTITUTE_URL") + "http://hydra.gnu.org")) + + +;;; +;;; Entry point. +;;; + +(define (guix-substitute-binary . args) + "Implement the build daemon's substituter protocol." + (match args + (("--query") + (let ((cache (open-cache %cache-url))) + (let loop ((command (read-line))) + (or (eof-object? command) + (begin + (match (string-tokenize command) + (("have" paths ..1) + ;; Return the subset of PATHS available in CACHE. + (let ((substitutable + (if cache + (par-map (cut fetch-narinfo cache <>) + paths) + '()))) + (for-each (lambda (narinfo) + (when narinfo + (display (narinfo-path narinfo)) + (newline))) + substitutable))) + (("info" paths ..1) + ;; Reply info about PATHS if it's in CACHE. + (let ((substitutable + (if cache + (par-map (cut fetch-narinfo cache <>) + paths) + '()))) + (for-each (lambda (narinfo) + (format #t "~a\n~a\n~a\n" + (narinfo-path narinfo) + (or (and=> (narinfo-deriver narinfo) + (cute string-append + (%store-prefix) "/" + <>)) + "") + (length (narinfo-references narinfo))) + (for-each (cute format #t "~a/~a~%" + (%store-prefix) <>) + (narinfo-references narinfo)) + (format #t "~a\n~a\n" + (or (narinfo-file-size narinfo) 0) + (or (narinfo-size narinfo) 0)) + (newline)) + substitutable))) + (wtf + (error "unknown `--query' command" wtf))) + (loop (read-line))))))) + (("--substitute" store-path destination) + ;; Download PATH and add it to the store. + ;; TODO: Implement. + (format (current-error-port) "substitution not implemented yet~%") + #f) + (("--version") + (show-version-and-exit "guix substitute-binary")))) + +;;; substitute-binary.scm ends here diff --git a/guix/store.scm b/guix/store.scm index 3bb2656bb6..de9785c835 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -662,7 +662,7 @@ file name. Return #t on success." store-path-list)) (define substitutable-path-info - (operation (query-substitutable-paths (store-path-list paths)) + (operation (query-substitutable-path-infos (store-path-list paths)) "Return information about the subset of PATHS that is substitutable. For each substitutable path, a `substitutable?' object is returned." diff --git a/nix/nix-daemon/guix-daemon.cc b/nix/nix-daemon/guix-daemon.cc index 1611840bd4..0e2f36150b 100644 --- a/nix/nix-daemon/guix-daemon.cc +++ b/nix/nix-daemon/guix-daemon.cc @@ -200,9 +200,17 @@ main (int argc, char *argv[]) { settings.processEnvironment (); - /* FIXME: Disable substitutes until we have something that works. */ - settings.useSubstitutes = false; + /* Use our substituter by default. */ settings.substituters.clear (); + string subs = getEnv ("NIX_SUBSTITUTERS", "default"); + if (subs == "default") + /* XXX: No substituters until we have something that works. */ + settings.substituters.clear (); + // settings.substituters.push_back (settings.nixLibexecDir + // + "/guix/substitute-binary"); + else + settings.substituters = tokenizeString (subs, ":"); + argp_parse (&argp, argc, argv, 0, 0, 0); diff --git a/nix/scripts/substitute-binary.in b/nix/scripts/substitute-binary.in new file mode 100644 index 0000000000..48d7bb8ff1 --- /dev/null +++ b/nix/scripts/substitute-binary.in @@ -0,0 +1,11 @@ +#!@SHELL@ +# A shorthand for "guix substitute-binary", for use by the daemon. + +if test "x$GUIX_UNINSTALLED" = "x" +then + prefix="@prefix@" + exec_prefix="@exec_prefix@" + exec "@bindir@/guix" substitute-binary "$@" +else + exec guix substitute-binary "$@" +fi diff --git a/pre-inst-env.in b/pre-inst-env.in index 4e079c8d41..5e7758cd7c 100644 --- a/pre-inst-env.in +++ b/pre-inst-env.in @@ -35,8 +35,9 @@ export PATH # Daemon helpers. NIX_ROOT_FINDER="@abs_top_builddir@/nix/scripts/list-runtime-roots" +NIX_SUBSTITUTERS="@abs_top_builddir@/nix/scripts/substitute-binary" NIX_SETUID_HELPER="@abs_top_builddir@/nix-setuid-helper" -export NIX_ROOT_FINDER NIX_SETUID_HELPER +export NIX_ROOT_FINDER NIX_SETUID_HELPER NIX_SUBSTITUTERS # The following variables need only be defined when compiling Guix # modules, but we define them to be on the safe side in case of diff --git a/test-env.in b/test-env.in index 491a45c7b4..9a6257197c 100644 --- a/test-env.in +++ b/test-env.in @@ -1,7 +1,7 @@ #!/bin/sh # GNU Guix --- Functional package management for GNU -# Copyright © 2012 Ludovic Courtès +# Copyright © 2012, 2013 Ludovic Courtès # # This file is part of GNU Guix. # @@ -26,7 +26,6 @@ if [ -x "@abs_top_builddir@/guix-daemon" ] then - NIX_SUBSTITUTERS="" # don't resort to substituters NIX_SETUID_HELPER="@abs_top_builddir@/nix-setuid-helper" # normally unused NIX_IGNORE_SYMLINK_STORE=1 # in case the store is a symlink NIX_STORE_DIR="@GUIX_TEST_ROOT@/store" @@ -39,18 +38,24 @@ then # that the directory name must be chosen so that the socket's file # name is less than 108-char long (the size of `sun_path' in glibc). # Currently, in Nix builds, we're at ~106 chars... - NIX_STATE_DIR="@GUIX_TEST_ROOT@/var/$$" # allow for parallel tests + NIX_STATE_DIR="@GUIX_TEST_ROOT@/var/$$" - export NIX_SUBSTITUTERS NIX_IGNORE_SYMLINK_STORE NIX_STORE_DIR \ + # A place to store data of the substituter. + GUIX_BINARY_SUBSTITUTE_URL="file://$NIX_STATE_DIR/substituter-data" + rm -rf "$NIX_STATE_DIR/substituter-data" + mkdir -p "$NIX_STATE_DIR/substituter-data" + + export NIX_IGNORE_SYMLINK_STORE NIX_STORE_DIR \ NIX_LOCALSTATE_DIR NIX_LOG_DIR NIX_STATE_DIR NIX_DB_DIR \ - NIX_ROOT_FINDER NIX_SETUID_HELPER + NIX_ROOT_FINDER NIX_SETUID_HELPER GUIX_BINARY_SUBSTITUTE_URL # Do that because store.scm calls `canonicalize-path' on it. mkdir -p "$NIX_STORE_DIR" # Launch the daemon without chroot support because is may be # unavailable, for instance if we're not running as root. - "@abs_top_builddir@/guix-daemon" --disable-chroot & + "@abs_top_builddir@/pre-inst-env" \ + "@abs_top_builddir@/guix-daemon" --disable-chroot & daemon_pid=$! trap "kill $daemon_pid ; rm -rf $NIX_STATE_DIR" EXIT diff --git a/tests/store.scm b/tests/store.scm index d6e1aa54e3..c75b99c6a9 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -26,6 +26,7 @@ #:use-module (gnu packages) #:use-module (gnu packages bootstrap) #:use-module (ice-9 match) + #:use-module (web uri) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-64)) @@ -128,6 +129,44 @@ (null? (substitutable-paths s o)) (null? (substitutable-path-info s o))))) +(test-skip (if (getenv "GUIX_BINARY_SUBSTITUTE_URL") 0 1)) + +(test-assert "substitute query" + (let* ((s (open-connection)) + (d (package-derivation s %bootstrap-guile (%current-system))) + (o (derivation-path->output-path d)) + (dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL") + (compose uri-path string->uri)))) + ;; Create fake substituter data, to be read by `substitute-binary'. + (call-with-output-file (string-append dir "/nix-cache-info") + (lambda (p) + (format p "StoreDir: ~a\nWantMassQuery: 0\n" + (getenv "NIX_STORE_DIR")))) + (call-with-output-file (string-append dir "/" (store-path-hash-part o) + ".narinfo") + (lambda (p) + (format p "StorePath: ~a +URL: ~a +Compression: none +NarSize: 1234 +References: +System: ~a +Deriver: ~a~%" + o ; StorePath + (string-append dir "/example.nar") ; URL + (%current-system) ; System + (basename d)))) ; Deriver + + ;; Make sure `substitute-binary' correctly communicates the above data. + (set-build-options s #:use-substitutes? #t) + (and (has-substitutes? s o) + (equal? (list o) (substitutable-paths s (list o))) + (match (pk 'spi (substitutable-path-info s (list o))) + (((? substitutable? s)) + (and (equal? (substitutable-deriver s) d) + (null? (substitutable-references s)) + (equal? (substitutable-nar-size s) 1234))))))) + (test-end "store") -- cgit v1.2.3 From 7ce1f2160fa783e9a43f8f8d8d5775d05a6b0638 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 4 Apr 2013 21:47:55 +0200 Subject: substitute-binary: Fix communication of several store paths to the daemon. * guix/scripts/substitute-binary.scm (guix-substitute-binary)["--query"]: Emit blank lines only after the complete list of store paths has been returned. --- guix/scripts/substitute-binary.scm | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 6e886b6c96..389acab094 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -191,9 +191,9 @@ failure." '()))) (for-each (lambda (narinfo) (when narinfo - (display (narinfo-path narinfo)) - (newline))) - substitutable))) + (format #t "~a~%" (narinfo-path narinfo)))) + substitutable) + (newline))) (("info" paths ..1) ;; Reply info about PATHS if it's in CACHE. (let ((substitutable @@ -215,9 +215,9 @@ failure." (narinfo-references narinfo)) (format #t "~a\n~a\n" (or (narinfo-file-size narinfo) 0) - (or (narinfo-size narinfo) 0)) - (newline)) - substitutable))) + (or (narinfo-size narinfo) 0))) + substitutable) + (newline))) (wtf (error "unknown `--query' command" wtf))) (loop (read-line))))))) -- cgit v1.2.3 From f0cd71f21e41d5a638b69ecee0fa3939f27a4502 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 4 Apr 2013 22:29:08 +0200 Subject: Add (guix nar) and (guix serialization). * guix/store.scm (write-int, read-int, write-long-long, read-long-long, write-padding, write-string, read-string, read-latin1-string, write-string-list, read-string-list, write-store-path, read-store-path, write-store-path-list, read-store-path-list): Move to serialization.scm. (write-contents, write-file): Move to nar.scm. * guix/nar.scm, guix/serialization.scm: New files. * Makefile.am (MODULES): Add them. --- Makefile.am | 2 + guix/nar.scm | 110 ++++++++++++++++++++++++++++++++++++ guix/serialization.scm | 114 +++++++++++++++++++++++++++++++++++++ guix/store.scm | 149 +------------------------------------------------ 4 files changed, 228 insertions(+), 147 deletions(-) create mode 100644 guix/nar.scm create mode 100644 guix/serialization.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 8b3057fd0b..e4afb74310 100644 --- a/Makefile.am +++ b/Makefile.am @@ -34,6 +34,8 @@ MODULES = \ guix/scripts/substitute-binary.scm \ guix/base32.scm \ guix/utils.scm \ + guix/serialization.scm \ + guix/nar.scm \ guix/derivations.scm \ guix/download.scm \ guix/gnu-maintenance.scm \ diff --git a/guix/nar.scm b/guix/nar.scm new file mode 100644 index 0000000000..b42f03c514 --- /dev/null +++ b/guix/nar.scm @@ -0,0 +1,110 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix nar) + #:use-module (guix utils) + #:use-module (guix serialization) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (ice-9 ftw) + #:export (write-file)) + +;;; Comment: +;;; +;;; Read and write Nix archives, aka. ‘nar’. +;;; +;;; Code: + +(define (write-contents file p size) + "Write SIZE bytes from FILE to output port P." + (define (call-with-binary-input-file file proc) + ;; Open FILE as a binary file. This avoids scan-for-encoding, and thus + ;; avoids any initial buffering. Disable file name canonicalization to + ;; avoid stat'ing like crazy. + (with-fluids ((%file-port-name-canonicalization #f)) + (let ((port (open-file file "rb"))) + (catch #t (cut proc port) + (lambda args + (close-port port) + (apply throw args)))))) + + (define (dump in size) + (define buf-size 65536) + (define buf (make-bytevector buf-size)) + + (let loop ((left size)) + (if (<= left 0) + 0 + (let ((read (get-bytevector-n! in buf 0 buf-size))) + (if (eof-object? read) + left + (begin + (put-bytevector p buf 0 read) + (loop (- left read)))))))) + + (write-string "contents" p) + (write-long-long size p) + (call-with-binary-input-file file + ;; Use `sendfile' when available (Guile 2.0.8+). + (if (compile-time-value (defined? 'sendfile)) + (cut sendfile p <> size 0) + (cut dump <> size))) + (write-padding size p)) + +(define (write-file file port) + "Write the contents of FILE to PORT in Nar format, recursing into +sub-directories of FILE as needed." + (define %archive-version-1 "nix-archive-1") + (define p port) + + (write-string %archive-version-1 p) + + (let dump ((f file)) + (let ((s (lstat f))) + (write-string "(" p) + (case (stat:type s) + ((regular) + (write-string "type" p) + (write-string "regular" p) + (if (not (zero? (logand (stat:mode s) #o100))) + (begin + (write-string "executable" p) + (write-string "" p))) + (write-contents f p (stat:size s))) + ((directory) + (write-string "type" p) + (write-string "directory" p) + (let ((entries (remove (cut member <> '("." "..")) + (scandir f)))) + (for-each (lambda (e) + (let ((f (string-append f "/" e))) + (write-string "entry" p) + (write-string "(" p) + (write-string "name" p) + (write-string e p) + (write-string "node" p) + (dump f) + (write-string ")" p))) + entries))) + (else + (error "ENOSYS"))) + (write-string ")" p)))) + +;;; nar.scm ends here diff --git a/guix/serialization.scm b/guix/serialization.scm new file mode 100644 index 0000000000..474dc69de5 --- /dev/null +++ b/guix/serialization.scm @@ -0,0 +1,114 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix serialization) + #:use-module (guix utils) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (write-int read-int + write-long-long read-long-long + write-padding + write-string read-string read-latin1-string + write-string-list read-string-list + write-store-path read-store-path + write-store-path-list read-store-path-list)) + +;;; Comment: +;;; +;;; Serialization procedures used by the RPCs and the Nar format. This module +;;; is for internal consumption. +;;; +;;; Code: + +;; Similar to serialize.cc in Nix. + +(define (write-int n p) + (let ((b (make-bytevector 8 0))) + (bytevector-u32-set! b 0 n (endianness little)) + (put-bytevector p b))) + +(define (read-int p) + (let ((b (get-bytevector-n p 8))) + (bytevector-u32-ref b 0 (endianness little)))) + +(define (write-long-long n p) + (let ((b (make-bytevector 8 0))) + (bytevector-u64-set! b 0 n (endianness little)) + (put-bytevector p b))) + +(define (read-long-long p) + (let ((b (get-bytevector-n p 8))) + (bytevector-u64-ref b 0 (endianness little)))) + +(define write-padding + (let ((zero (make-bytevector 8 0))) + (lambda (n p) + (let ((m (modulo n 8))) + (or (zero? m) + (put-bytevector p zero 0 (- 8 m))))))) + +(define (write-string s p) + (let* ((s (string->utf8 s)) + (l (bytevector-length s)) + (m (modulo l 8)) + (b (make-bytevector (+ 8 l (if (zero? m) 0 (- 8 m)))))) + (bytevector-u32-set! b 0 l (endianness little)) + (bytevector-copy! s 0 b 8 l) + (put-bytevector p b))) + +(define (read-string p) + (let* ((len (read-int p)) + (m (modulo len 8)) + (bv (get-bytevector-n p len)) + (str (utf8->string bv))) + (or (zero? m) + (get-bytevector-n p (- 8 m))) + str)) + +(define (read-latin1-string p) + (let* ((len (read-int p)) + (m (modulo len 8)) + (str (get-string-n p len))) + (or (zero? m) + (get-bytevector-n p (- 8 m))) + str)) + +(define (write-string-list l p) + (write-int (length l) p) + (for-each (cut write-string <> p) l)) + +(define (read-string-list p) + (let ((len (read-int p))) + (unfold (cut >= <> len) + (lambda (i) + (read-string p)) + 1+ + 0))) + +(define (write-store-path f p) + (write-string f p)) ; TODO: assert path + +(define (read-store-path p) + (read-string p)) ; TODO: assert path + +(define write-store-path-list write-string-list) +(define read-store-path-list read-string-list) + +;;; serialization.scm ends here diff --git a/guix/store.scm b/guix/store.scm index de9785c835..cc21af84e4 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -17,8 +17,10 @@ ;;; along with GNU Guix. If not, see . (define-module (guix store) + #:use-module (guix nar) #:use-module (guix utils) #:use-module (guix config) + #:use-module (guix serialization) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (srfi srfi-1) @@ -29,7 +31,6 @@ #:use-module (srfi srfi-39) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) - #:use-module (ice-9 ftw) #:use-module (ice-9 regex) #:export (%daemon-socket-file @@ -161,152 +162,6 @@ -;; serialize.cc - -(define (write-int n p) - (let ((b (make-bytevector 8 0))) - (bytevector-u32-set! b 0 n (endianness little)) - (put-bytevector p b))) - -(define (read-int p) - (let ((b (get-bytevector-n p 8))) - (bytevector-u32-ref b 0 (endianness little)))) - -(define (write-long-long n p) - (let ((b (make-bytevector 8 0))) - (bytevector-u64-set! b 0 n (endianness little)) - (put-bytevector p b))) - -(define (read-long-long p) - (let ((b (get-bytevector-n p 8))) - (bytevector-u64-ref b 0 (endianness little)))) - -(define write-padding - (let ((zero (make-bytevector 8 0))) - (lambda (n p) - (let ((m (modulo n 8))) - (or (zero? m) - (put-bytevector p zero 0 (- 8 m))))))) - -(define (write-string s p) - (let* ((s (string->utf8 s)) - (l (bytevector-length s)) - (m (modulo l 8)) - (b (make-bytevector (+ 8 l (if (zero? m) 0 (- 8 m)))))) - (bytevector-u32-set! b 0 l (endianness little)) - (bytevector-copy! s 0 b 8 l) - (put-bytevector p b))) - -(define (read-string p) - (let* ((len (read-int p)) - (m (modulo len 8)) - (bv (get-bytevector-n p len)) - (str (utf8->string bv))) - (or (zero? m) - (get-bytevector-n p (- 8 m))) - str)) - -(define (read-latin1-string p) - (let* ((len (read-int p)) - (m (modulo len 8)) - (str (get-string-n p len))) - (or (zero? m) - (get-bytevector-n p (- 8 m))) - str)) - -(define (write-string-list l p) - (write-int (length l) p) - (for-each (cut write-string <> p) l)) - -(define (read-string-list p) - (let ((len (read-int p))) - (unfold (cut >= <> len) - (lambda (i) - (read-string p)) - 1+ - 0))) - -(define (write-store-path f p) - (write-string f p)) ; TODO: assert path - -(define (read-store-path p) - (read-string p)) ; TODO: assert path - -(define write-store-path-list write-string-list) -(define read-store-path-list read-string-list) - -(define (write-contents file p size) - "Write SIZE bytes from FILE to output port P." - (define (call-with-binary-input-file file proc) - ;; Open FILE as a binary file. This avoids scan-for-encoding, and thus - ;; avoids any initial buffering. Disable file name canonicalization to - ;; avoid stat'ing like crazy. - (with-fluids ((%file-port-name-canonicalization #f)) - (let ((port (open-file file "rb"))) - (catch #t (cut proc port) - (lambda args - (close-port port) - (apply throw args)))))) - - (define (dump in size) - (define buf-size 65536) - (define buf (make-bytevector buf-size)) - - (let loop ((left size)) - (if (<= left 0) - 0 - (let ((read (get-bytevector-n! in buf 0 buf-size))) - (if (eof-object? read) - left - (begin - (put-bytevector p buf 0 read) - (loop (- left read)))))))) - - (write-string "contents" p) - (write-long-long size p) - (call-with-binary-input-file file - ;; Use `sendfile' when available (Guile 2.0.8+). - (if (compile-time-value (defined? 'sendfile)) - (cut sendfile p <> size 0) - (cut dump <> size))) - (write-padding size p)) - -(define (write-file f p) - (define %archive-version-1 "nix-archive-1") - - (write-string %archive-version-1 p) - - (let dump ((f f)) - (let ((s (lstat f))) - (write-string "(" p) - (case (stat:type s) - ((regular) - (write-string "type" p) - (write-string "regular" p) - (if (not (zero? (logand (stat:mode s) #o100))) - (begin - (write-string "executable" p) - (write-string "" p))) - (write-contents f p (stat:size s))) - ((directory) - (write-string "type" p) - (write-string "directory" p) - (let ((entries (remove (cut member <> '("." "..")) - (scandir f)))) - (for-each (lambda (e) - (let ((f (string-append f "/" e))) - (write-string "entry" p) - (write-string "(" p) - (write-string "name" p) - (write-string e p) - (write-string "node" p) - (dump f) - (write-string ")" p))) - entries))) - (else - (error "ENOSYS"))) - (write-string ")" p)))) - ;; Information about a substitutable store path. (define-record-type (substitutable path deriver refs dl-size nar-size) -- cgit v1.2.3 From ca877f5a3a0e216d2e0e62bea3e42cdc2e4c3dab Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 8 Apr 2013 22:54:08 +0200 Subject: nar: Implement restoration from Nar. * guix/nar.scm (&nar-error, &nar-read-error): New condition types. (dump): New procedure. (write-contents)[dump]: Remove. Use the one above instead. (read-contents, write-file, restore-file): New procedures. (%archive-version-1): New variable. --- Makefile.am | 1 + guix/nar.scm | 150 +++++++++++++++++++++++++++++++++++++++++++++++++++------- tests/nar.scm | 95 +++++++++++++++++++++++++++++++++++++ 3 files changed, 228 insertions(+), 18 deletions(-) create mode 100644 tests/nar.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index f73437f0f4..a1bda16759 100644 --- a/Makefile.am +++ b/Makefile.am @@ -302,6 +302,7 @@ TESTS = \ tests/packages.scm \ tests/snix.scm \ tests/store.scm \ + tests/nar.scm \ tests/union.scm \ tests/guix-build.sh \ tests/guix-download.sh \ diff --git a/guix/nar.scm b/guix/nar.scm index b42f03c514..9ae76ff2a9 100644 --- a/guix/nar.scm +++ b/guix/nar.scm @@ -19,12 +19,23 @@ (define-module (guix nar) #:use-module (guix utils) #:use-module (guix serialization) + #:use-module ((guix build utils) #:select (with-directory-excursion)) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (ice-9 ftw) - #:export (write-file)) + #:use-module (ice-9 match) + #:export (nar-error? + nar-read-error? + nar-read-error-file + nar-read-error-port + nar-read-error-token + + write-file + restore-file)) ;;; Comment: ;;; @@ -32,6 +43,31 @@ ;;; ;;; Code: +(define-condition-type &nar-error &error ; XXX: inherit from &nix-error ? + nar-error?) + +(define-condition-type &nar-read-error &nar-error + nar-read-error? + (port nar-read-error-port) ; port from which we read + (file nar-read-error-file) ; file we were restoring, or #f + (token nar-read-error-token)) ; faulty token, or #f + + +(define (dump in out size) + "Copy SIZE bytes from IN to OUT." + (define buf-size 65536) + (define buf (make-bytevector buf-size)) + + (let loop ((left size)) + (if (<= left 0) + 0 + (let ((read (get-bytevector-n! in buf 0 (min left buf-size)))) + (if (eof-object? read) + left + (begin + (put-bytevector out buf 0 read) + (loop (- left read)))))))) + (define (write-contents file p size) "Write SIZE bytes from FILE to output port P." (define (call-with-binary-input-file file proc) @@ -45,33 +81,55 @@ (close-port port) (apply throw args)))))) - (define (dump in size) - (define buf-size 65536) - (define buf (make-bytevector buf-size)) - - (let loop ((left size)) - (if (<= left 0) - 0 - (let ((read (get-bytevector-n! in buf 0 buf-size))) - (if (eof-object? read) - left - (begin - (put-bytevector p buf 0 read) - (loop (- left read)))))))) - (write-string "contents" p) (write-long-long size p) (call-with-binary-input-file file ;; Use `sendfile' when available (Guile 2.0.8+). (if (compile-time-value (defined? 'sendfile)) (cut sendfile p <> size 0) - (cut dump <> size))) + (cut dump <> p size))) (write-padding size p)) +(define (read-contents in out) + "Read the contents of a file from the Nar at IN, write it to OUT, and return +the size in bytes." + (define executable? + (match (read-string in) + ("contents" + #f) + ("executable" + (match (list (read-string in) (read-string in)) + (("" "contents") #t) + (x (raise + (condition (&message + (message "unexpected executable file marker")) + (&nar-read-error (port in) + (file #f) + (token x)))))) + #t) + (x + (raise + (condition (&message (message "unsupported nar file type")) + (&nar-read-error (port in) (file #f) (token x))))))) + + (let ((size (read-long-long in))) + ;; Note: `sendfile' cannot be used here because of port buffering on IN. + (dump in out size) + + (when executable? + (chmod out #o755)) + (let ((m (modulo size 8))) + (unless (zero? m) + (get-bytevector-n in (- 8 m)))) + size)) + +(define %archive-version-1 + ;; Magic cookie for Nix archives. + "nix-archive-1") + (define (write-file file port) "Write the contents of FILE to PORT in Nar format, recursing into sub-directories of FILE as needed." - (define %archive-version-1 "nix-archive-1") (define p port) (write-string %archive-version-1 p) @@ -104,7 +162,63 @@ sub-directories of FILE as needed." (write-string ")" p))) entries))) (else - (error "ENOSYS"))) + (raise (condition (&message (message "ENOSYS")) + (&nar-error))))) (write-string ")" p)))) +(define (restore-file port file) + "Read a file (possibly a directory structure) in Nar format from PORT. +Restore it as FILE." + (let ((signature (read-string port))) + (unless (equal? signature %archive-version-1) + (raise + (condition (&message (message "invalid nar signature")) + (&nar-read-error (port port) + (token signature) + (file #f)))))) + + (let restore ((file file)) + (match (list (read-string port) (read-string port) (read-string port)) + (("(" "type" "regular") + (call-with-output-file file (cut read-contents port <>)) + (match (read-string port) + (")" #t) + (x (raise + (condition + (&message (message "invalid nar end-of-file marker")) + (&nar-read-error (port port) (file file) (token x))))))) + (("(" "type" "directory") + (let ((dir file)) + (mkdir dir) + (let loop ((prefix (read-string port))) + (match prefix + ("entry" + (match (list (read-string port) + (read-string port) (read-string port) + (read-string port)) + (("(" "name" file "node") + (restore (string-append dir "/" file)) + (match (read-string port) + (")" #t) + (x + (raise + (condition + (&message + (message "unexpected directory entry termination")) + (&nar-read-error (port port) + (file file) + (token x)))))) + (loop (read-string port))))) + (")" #t) ; done with DIR + (x + (raise + (condition + (&message (message "unexpected directory inter-entry marker")) + (&nar-read-error (port port) (file file) (token x))))))))) + (x + (raise + (condition + (&message (message "unsupported nar entry type")) + (&nar-read-error (port port) (file file) (token x)))))))) + ;;; nar.scm ends here diff --git a/tests/nar.scm b/tests/nar.scm new file mode 100644 index 0000000000..2d9bffd487 --- /dev/null +++ b/tests/nar.scm @@ -0,0 +1,95 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès +;;; +;;; 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 . + +(define-module (test-nar) + #:use-module (guix nar) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-64) + #:use-module (ice-9 ftw)) + +;; Test the (guix nar) module. + +(define (rm-rf dir) + (file-system-fold (const #t) ; enter? + (lambda (file stat result) ; leaf + (delete-file file)) + (const #t) ; down + (lambda (dir stat result) ; up + (rmdir dir)) + (const #t) ; skip + (const #t) ; error + #t + dir + lstat)) + + +(test-begin "nar") + +(test-assert "write-file + restore-file" + (let* ((input (string-append (dirname (search-path %load-path "guix.scm")) + "/guix")) + (output (string-append (dirname input) + "/test-nar-" + (number->string (getpid)))) + (nar (string-append output ".nar"))) + (dynamic-wind + (lambda () #t) + (lambda () + (call-with-output-file nar + (cut write-file input <>)) + (call-with-input-file nar + (cut restore-file <> output)) + (let* ((strip (cute string-drop <> (string-length input))) + (sibling (compose (cut string-append output <>) strip)) + (file=? (lambda (a b) + (and (eq? (stat:type (lstat a)) (stat:type (lstat b))) + (case (stat:type (lstat a)) + ((regular) + (equal? + (call-with-input-file a get-bytevector-all) + (call-with-input-file b get-bytevector-all))) + ((symlink) + (string=? (readlink a) (readlink b))) + (else + (error "what?" (lstat a)))))))) + (file-system-fold (const #t) + (lambda (name stat result) ; leaf + (and result + (file=? name (sibling name)))) + (lambda (name stat result) ; down + result) + (lambda (name stat result) ; up + result) + (const #f) ; skip + (lambda (name stat errno result) + (pk 'error name stat errno) + #f) + (> (stat:nlink (stat output)) 2) + input + lstat))) + (lambda () + (false-if-exception (delete-file nar)) + (false-if-exception (rm-rf output)) + )))) + +(test-end "nar") + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) -- cgit v1.2.3 From 6f80c9d8f387f5b881a73cefdbbba91a40d8eec6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Apr 2013 22:30:06 +0200 Subject: ui: Add a `warning' macro. * guix/ui.scm (program-name, guix-warning-port): New variables. (warning): New macro. (guix-main): Parametrize PROGRAM-NAME. * guix/scripts/build.scm, guix/scripts/download.scm, guix/scripts/gc.scm, guix/scripts/package.scm: Adjust to use `leave' and `warning' consistently. --- guix/scripts/build.scm | 16 ++++++---------- guix/scripts/download.scm | 3 +-- guix/scripts/gc.scm | 15 ++++----------- guix/scripts/package.scm | 20 ++++++++----------- guix/ui.scm | 49 +++++++++++++++++++++++++++++++++++++++++++---- 5 files changed, 64 insertions(+), 39 deletions(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index a49bfdbeb8..339ad0d06f 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -176,9 +176,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) 0 paths)))) (lambda args - (format (current-error-port) - (_ "failed to create GC root `~a': ~a~%") - root (strerror (system-error-errno args))) + (leave (_ "failed to create GC root `~a': ~a~%") + root (strerror (system-error-errno args))) (exit 1))))) (define newest-available-packages @@ -202,13 +201,10 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) ((p) ; one match p) ((p x ...) ; several matches - (format (current-error-port) - (_ "warning: ambiguous package specification `~a'~%") - request) - (format (current-error-port) - (_ "warning: choosing ~a from ~a~%") - (package-full-name p) - (location->string (package-location p))) + (warning (_ "ambiguous package specification `~a'~%") request) + (warning (_ "choosing ~a from ~a~%") + (package-full-name p) + (location->string (package-location p))) p) (_ ; no matches (if version diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 3f989a3494..7c00312c74 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -81,8 +81,7 @@ and the hash of its contents.\n")) ((or "base16" "hex" "hexadecimal") bytevector->base16-string) (x - (format (current-error-port) - "unsupported hash format: ~a~%" arg)))) + (leave (_ "unsupported hash format: ~a~%") arg)))) (alist-cons 'format fmt-proc (alist-delete 'format result)))) diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 12d80fd171..3d918923f8 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -87,13 +87,9 @@ interpreted." ("TB" (expt 10 12)) ("" 1) (_ - (format (current-error-port) (_ "error: unknown unit: ~a~%") - unit) + (leave (_ "error: unknown unit: ~a~%") unit) (exit 1)))) - (begin - (format (current-error-port) - (_ "error: invalid number: ~a") numstr) - (exit 1))))) + (leave (_ "error: invalid number: ~a") numstr)))) (define %options ;; Specification of the command-line options. @@ -114,11 +110,8 @@ interpreted." (let ((amount (size->number arg))) (if arg (alist-cons 'min-freed amount result) - (begin - (format (current-error-port) - (_ "error: invalid amount of storage: ~a~%") - arg) - (exit 1))))) + (leave (_ "error: invalid amount of storage: ~a~%") + arg)))) (#f result))))) (option '(#\d "delete") #f #f (lambda (opt name arg result) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 6de2f1beb6..89708ccc49 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -208,12 +208,10 @@ all of PACKAGES, a list of name/version/output/path/deps tuples." (switch-symlinks profile previous-profile)) (cond ((not (file-exists? profile)) ; invalid profile - (format (current-error-port) - (_ "error: profile `~a' does not exist~%") - profile)) + (leave (_ "error: profile `~a' does not exist~%") + profile)) ((zero? number) ; empty profile - (format (current-error-port) - (_ "nothing to do: already at the empty profile~%"))) + (leave (_ "nothing to do: already at the empty profile~%"))) ((or (zero? previous-number) ; going to emptiness (not (file-exists? previous-profile))) (let*-values (((drv-path drv) @@ -465,13 +463,11 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (list name (package-version p) sub-drv (ensure-output p sub-drv) (package-transitive-propagated-inputs p))) ((p p* ...) - (format (current-error-port) - (_ "warning: ambiguous package specification `~a'~%") - request) - (format (current-error-port) - (_ "warning: choosing ~a from ~a~%") - (package-full-name p) - (location->string (package-location p))) + (warning (_ "ambiguous package specification `~a'~%") + request) + (warning (_ "choosing ~a from ~a~%") + (package-full-name p) + (location->string (package-location p))) (list name (package-version p) sub-drv (ensure-output p sub-drv) (package-transitive-propagated-inputs p))) (() diff --git a/guix/ui.scm b/guix/ui.scm index 94f0825a0a..dfb6418a10 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -47,6 +47,9 @@ string->recutils package->recutils run-guix-command + program-name + guix-warning-port + warning guix-main)) ;;; Commentary: @@ -332,6 +335,43 @@ WIDTH columns." (symbol-append 'guix- command)))) (apply command-main args))) +(define program-name + ;; Name of the command-line program currently executing, or #f. + (make-parameter #f)) + +(define guix-warning-port + (make-parameter (current-warning-port))) + +(define-syntax warning + (lambda (s) + "Emit a warming. The macro assumes that `_' is bound to `gettext'." + ;; All this just to preserve `-Wformat' warnings. Too much? + + (define (augmented-format-string fmt) + (string-append "~:[~;guix ~a: ~]~a" (syntax->datum fmt))) + + (define prefix + #'(_ "warning: ")) + + (syntax-case s (N_ _) ; these are literals, yeah... + ((warning (_ fmt) args ...) + (string? (syntax->datum #'fmt)) + (with-syntax ((fmt* (augmented-format-string #'fmt)) + (prefix prefix)) + #'(format (guix-warning-port) (gettext fmt*) + (program-name) (program-name) prefix + args ...))) + ((warning (N_ singular plural n) args ...) + (and (string? (syntax->datum #'singular)) + (string? (syntax->datum #'plural))) + (with-syntax ((s (augmented-format-string #'singular)) + (p (augmented-format-string #'plural)) + (b prefix)) + #'(format (guix-warning-port) + (ngettext s p n %gettext-domain) + (program-name) (program-name) b + args ...)))))) + (define (guix-main arg0 . args) (initialize-guix) (let () @@ -340,10 +380,11 @@ WIDTH columns." (() (show-guix-usage) (exit 1)) (("--help") (show-guix-usage)) (("--version") (show-version-and-exit "guix")) - (((? option? arg1) args ...) (show-guix-usage) (exit 1)) + (((? option?) args ...) (show-guix-usage) (exit 1)) ((command args ...) - (apply run-guix-command - (string->symbol command) - args))))) + (parameterize ((program-name command)) + (apply run-guix-command + (string->symbol command) + args)))))) ;;; ui.scm ends here -- cgit v1.2.3 From c7b62db614a40c7d7dc93b7e763e3741325486df Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 12 Apr 2013 14:35:01 +0200 Subject: nar: Add support for symlinks. * guix/nar.scm (write-file): Add case for type `symlink'. (restore-file): Likewise. * tests/nar.scm (random-file-size, make-file-tree, delete-file-tree, with-file-tree, file-tree-equal?, make-random-bytevector, populate-file): New procedures. (%test-dir): New variable. ("write-file + restore-file"): Use `%test-dir' and `file-tree-equal?'. ("write-file + restore-file with symlinks"): New test. --- guix/nar.scm | 23 +++++++- tests/nar.scm | 183 +++++++++++++++++++++++++++++++++++++++++++++++----------- 2 files changed, 169 insertions(+), 37 deletions(-) (limited to 'guix') diff --git a/guix/nar.scm b/guix/nar.scm index 9ae76ff2a9..29b57dc989 100644 --- a/guix/nar.scm +++ b/guix/nar.scm @@ -161,6 +161,11 @@ sub-directories of FILE as needed." (dump f) (write-string ")" p))) entries))) + ((symlink) + (write-string "type" p) + (write-string "symlink" p) + (write-string "target" p) + (write-string (readlink f) p)) (else (raise (condition (&message (message "ENOSYS")) (&nar-error))))) @@ -178,14 +183,26 @@ Restore it as FILE." (file #f)))))) (let restore ((file file)) + (define (read-eof-marker) + (match (read-string port) + (")" #t) + (x (raise + (condition + (&message (message "invalid nar end-of-file marker")) + (&nar-read-error (port port) (file file) (token x))))))) + (match (list (read-string port) (read-string port) (read-string port)) (("(" "type" "regular") (call-with-output-file file (cut read-contents port <>)) - (match (read-string port) - (")" #t) + (read-eof-marker)) + (("(" "type" "symlink") + (match (list (read-string port) (read-string port)) + (("target" target) + (symlink target file) + (read-eof-marker)) (x (raise (condition - (&message (message "invalid nar end-of-file marker")) + (&message (message "invalid symlink tokens")) (&nar-read-error (port port) (file file) (token x))))))) (("(" "type" "directory") (let ((dir file)) diff --git a/tests/nar.scm b/tests/nar.scm index 2d9bffd487..4321cbda53 100644 --- a/tests/nar.scm +++ b/tests/nar.scm @@ -22,10 +22,122 @@ #:use-module (rnrs io ports) #:use-module (srfi srfi-26) #:use-module (srfi srfi-64) - #:use-module (ice-9 ftw)) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match)) ;; Test the (guix nar) module. + +;;; +;;; File system testing tools, initially contributed to Guile, then libchop. +;;; + +(define (random-file-size) + (define %average (* 1024 512)) ; 512 KiB + (define %stddev (* 1024 64)) ; 64 KiB + (inexact->exact + (max 0 (round (+ %average (* %stddev (random:normal))))))) + +(define (make-file-tree dir tree) + "Make file system TREE at DIR." + (let loop ((dir dir) + (tree tree)) + (define (scope file) + (string-append dir "/" file)) + + (match tree + (('directory name (body ...)) + (mkdir (scope name)) + (for-each (cute loop (scope name) <>) body)) + (('directory name (? integer? mode) (body ...)) + (mkdir (scope name)) + (for-each (cute loop (scope name) <>) body) + (chmod (scope name) mode)) + ((file) + (populate-file (scope file) (random-file-size))) + ((file (? integer? mode)) + (populate-file (scope file) (random-file-size)) + (chmod (scope file) mode)) + ((from '-> to) + (symlink to (scope from)))))) + +(define (delete-file-tree dir tree) + "Delete file TREE from DIR." + (let loop ((dir dir) + (tree tree)) + (define (scope file) + (string-append dir "/" file)) + + (match tree + (('directory name (body ...)) + (for-each (cute loop (scope name) <>) body) + (rmdir (scope name))) + (('directory name (? integer? mode) (body ...)) + (chmod (scope name) #o755) ; make sure it can be entered + (for-each (cute loop (scope name) <>) body) + (rmdir (scope name))) + ((from '-> _) + (delete-file (scope from))) + ((file _ ...) + (delete-file (scope file)))))) + +(define-syntax-rule (with-file-tree dir tree body ...) + (dynamic-wind + (lambda () + (make-file-tree dir 'tree)) + (lambda () + body ...) + (lambda () + (delete-file-tree dir 'tree)))) + +(define (file-tree-equal? input output) + "Return #t if the file trees at INPUT and OUTPUT are equal." + (define strip + (cute string-drop <> (string-length input))) + (define sibling + (compose (cut string-append output <>) strip)) + (define (file=? a b) + (and (eq? (stat:type (lstat a)) (stat:type (lstat b))) + (case (stat:type (lstat a)) + ((regular) + (equal? + (call-with-input-file a get-bytevector-all) + (call-with-input-file b get-bytevector-all))) + ((symlink) + (string=? (readlink a) (readlink b))) + (else + (error "what?" (lstat a)))))) + + (file-system-fold (const #t) + (lambda (name stat result) ; leaf + (and result + (file=? name (sibling name)))) + (lambda (name stat result) ; down + result) + (lambda (name stat result) ; up + result) + (const #f) ; skip + (lambda (name stat errno result) + (pk 'error name stat errno) + #f) + (> (stat:nlink (stat output)) 2) + input + lstat)) + +(define (make-random-bytevector n) + (let ((bv (make-bytevector n))) + (let loop ((i 0)) + (if (< i n) + (begin + (bytevector-u8-set! bv i (random 256)) + (loop (1+ i))) + bv)))) + +(define (populate-file file size) + (call-with-output-file file + (lambda (p) + (put-bytevector p (make-random-bytevector size))))) + (define (rm-rf dir) (file-system-fold (const #t) ; enter? (lambda (file stat result) ; leaf @@ -39,15 +151,18 @@ dir lstat)) +(define %test-dir + ;; An output directory under $top_builddir. + (string-append (dirname (search-path %load-path "configure")) + "/test-nar-" (number->string (getpid)))) + (test-begin "nar") (test-assert "write-file + restore-file" (let* ((input (string-append (dirname (search-path %load-path "guix.scm")) "/guix")) - (output (string-append (dirname input) - "/test-nar-" - (number->string (getpid)))) + (output %test-dir) (nar (string-append output ".nar"))) (dynamic-wind (lambda () #t) @@ -56,40 +171,40 @@ (cut write-file input <>)) (call-with-input-file nar (cut restore-file <> output)) - (let* ((strip (cute string-drop <> (string-length input))) - (sibling (compose (cut string-append output <>) strip)) - (file=? (lambda (a b) - (and (eq? (stat:type (lstat a)) (stat:type (lstat b))) - (case (stat:type (lstat a)) - ((regular) - (equal? - (call-with-input-file a get-bytevector-all) - (call-with-input-file b get-bytevector-all))) - ((symlink) - (string=? (readlink a) (readlink b))) - (else - (error "what?" (lstat a)))))))) - (file-system-fold (const #t) - (lambda (name stat result) ; leaf - (and result - (file=? name (sibling name)))) - (lambda (name stat result) ; down - result) - (lambda (name stat result) ; up - result) - (const #f) ; skip - (lambda (name stat errno result) - (pk 'error name stat errno) - #f) - (> (stat:nlink (stat output)) 2) - input - lstat))) + (file-tree-equal? input output)) (lambda () (false-if-exception (delete-file nar)) - (false-if-exception (rm-rf output)) - )))) + (false-if-exception (rm-rf output)))))) + +(test-assert "write-file + restore-file with symlinks" + (let ((input (string-append %test-dir ".input"))) + (mkdir input) + (dynamic-wind + (const #t) + (lambda () + (with-file-tree input + (directory "root" + (("reg") ("exe" #o777) ("sym" -> "reg"))) + (let* ((output %test-dir) + (nar (string-append output ".nar"))) + (dynamic-wind + (lambda () #t) + (lambda () + (call-with-output-file nar + (cut write-file input <>)) + (call-with-input-file nar + (cut restore-file <> output)) + (file-tree-equal? input output)) + (lambda () + (false-if-exception (delete-file nar))))))) + (lambda () + (rmdir input))))) (test-end "nar") (exit (= (test-runner-fail-count (test-runner-current)) 0)) + +;;; Local Variables: +;;; eval: (put 'with-file-tree 'scheme-indent-function 2) +;;; End: -- cgit v1.2.3 From f03f0c9a867e22dd999a8519f4bf03b182739c97 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 12 Apr 2013 15:52:27 +0200 Subject: substitute-binary: Correctly handle missing narinfos in `--query' mode. * guix/scripts/substitute-binary.scm (guix-substitute-binary)["--query"]("have", "info"): Filter SUBSTITUTABLE through `narinfo?'. --- guix/scripts/substitute-binary.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 389acab094..64df4f09d6 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -192,7 +192,7 @@ failure." (for-each (lambda (narinfo) (when narinfo (format #t "~a~%" (narinfo-path narinfo)))) - substitutable) + (filter narinfo? substitutable)) (newline))) (("info" paths ..1) ;; Reply info about PATHS if it's in CACHE. @@ -216,7 +216,7 @@ failure." (format #t "~a\n~a\n" (or (narinfo-file-size narinfo) 0) (or (narinfo-size narinfo) 0))) - substitutable) + (filter narinfo? substitutable)) (newline))) (wtf (error "unknown `--query' command" wtf))) -- cgit v1.2.3 From cdf2022052268b9c517d486294ec34f0c18091aa Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 12 Apr 2013 17:30:27 +0200 Subject: substitute-binary: Implement `--substitute'. This allows build outputs to be transparently downloaded from http://hydra.gnu.org, for example. * config-daemon.ac: Check for `gzip', `bzip2', and `xz'. * guix/config.scm.in (%gzip, %bzip2, %xz): New variable. * guix/scripts/substitute-binary.scm (fetch): Return SIZE as a second value. (): Change `url' to `uri'. (make-narinfo): Rename to... (narinfo-maker): ... this. Handle relative URLs. (fetch-narinfo): Adjust accordingly. (filtered-port, decompressed-port): New procedures. (guix-substitute-binary): Implement the `--substitute' case. * tests/store.scm ("substitute query"): Use (%store-prefix) instead of (getenv "NIX_STORE_DIR"). ("substitute"): New test. --- config-daemon.ac | 8 +++ guix/config.scm.in | 14 +++++- guix/scripts/substitute-binary.scm | 100 +++++++++++++++++++++++++++++-------- tests/store.scm | 55 +++++++++++++++++++- 4 files changed, 154 insertions(+), 23 deletions(-) (limited to 'guix') diff --git a/config-daemon.ac b/config-daemon.ac index eed1e23f9e..7c51f2b95c 100644 --- a/config-daemon.ac +++ b/config-daemon.ac @@ -11,6 +11,14 @@ if test "x$guix_build_daemon" = "xyes"; then AC_PROG_RANLIB AC_CONFIG_HEADER([nix/config.h]) + dnl Decompressors, for use by the substituter. + AC_PATH_PROG([GZIP], [gzip]) + AC_PATH_PROG([BZIP2], [bzip2]) + AC_PATH_PROG([XZ], [xz]) + AC_SUBST([GZIP]) + AC_SUBST([BZIP2]) + AC_SUBST([XZ]) + dnl Use 64-bit file system calls so that we can support files > 2 GiB. AC_SYS_LARGEFILE diff --git a/guix/config.scm.in b/guix/config.scm.in index ab7b0669b8..772ea8c289 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -26,7 +26,10 @@ %system %libgcrypt %nixpkgs - %nix-instantiate)) + %nix-instantiate + %gzip + %bzip2 + %xz)) ;;; Commentary: ;;; @@ -67,4 +70,13 @@ (define %nix-instantiate "@NIX_INSTANTIATE@") +(define %gzip + "@GZIP@") + +(define %bzip2 + "@BZIP2@") + +(define %xz + "@XZ@") + ;;; config.scm ends here diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 64df4f09d6..2b447ce7f2 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -20,10 +20,13 @@ #:use-module (guix ui) #:use-module (guix store) #:use-module (guix utils) + #:use-module (guix config) + #:use-module (guix nar) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (ice-9 match) #:use-module (ice-9 threads) + #:use-module (ice-9 format) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) @@ -70,9 +73,12 @@ pairs." (apply make args))) (define (fetch uri) + "Return a binary input port to URI and the number of bytes it's expected to +provide." (case (uri-scheme uri) ((file) - (open-input-file (uri-path uri))) + (let ((port (open-input-file (uri-path uri)))) + (values port (stat:size (stat port))))) ((http) (let*-values (((resp port) ;; XXX: `http-get*' was introduced in 2.0.7, and deprecated @@ -86,7 +92,7 @@ pairs." (response-content-length resp))) (case code ((200) ; OK - port) + (values port size)) ((301 ; moved permanently 302) ; found (redirection) (let ((uri (response-location resp))) @@ -120,11 +126,11 @@ failure." '("StoreDir" "WantMassQuery"))))) (define-record-type - (%make-narinfo path url compression file-hash file-size nar-hash nar-size + (%make-narinfo path uri compression file-hash file-size nar-hash nar-size references deriver system) narinfo? (path narinfo-path) - (url narinfo-url) + (uri narinfo-uri) (compression narinfo-compression) (file-hash narinfo-file-hash) (file-size narinfo-file-size) @@ -134,18 +140,26 @@ failure." (deriver narinfo-deriver) (system narinfo-system)) -(define (make-narinfo path url compression file-hash file-size nar-hash nar-size - references deriver system) - "Return a new object." - (%make-narinfo path url compression file-hash - (and=> file-size string->number) - nar-hash - (and=> nar-size string->number) - (string-tokenize references) - (match deriver - ((or #f "") #f) - (_ deriver)) - system)) +(define (narinfo-maker cache-url) + "Return a narinfo constructor for narinfos originating from CACHE-URL." + (lambda (path url compression file-hash file-size nar-hash nar-size + references deriver system) + "Return a new object." + (%make-narinfo path + + ;; Handle the case where URL is a relative URL. + (or (string->uri url) + (string->uri (string-append cache-url "/" url))) + + compression file-hash + (and=> file-size string->number) + nar-hash + (and=> nar-size string->number) + (string-tokenize references) + (match deriver + ((or #f "") #f) + (_ deriver)) + system))) (define (fetch-narinfo cache path) "Return the record for PATH, or #f if CACHE does not hold PATH." @@ -159,11 +173,36 @@ failure." (store-path-hash-part path) ".narinfo")) (lambda (properties) - (alist->record properties make-narinfo + (alist->record properties (narinfo-maker (cache-url cache)) '("StorePath" "URL" "Compression" "FileHash" "FileSize" "NarHash" "NarSize" "References" "Deriver" "System"))))) +(define (filtered-port command input) + "Return an input port (and PID) where data drained from INPUT is filtered +through COMMAND. INPUT must be a file input port." + (let ((i+o (pipe))) + (match (primitive-fork) + (0 + (close-port (car i+o)) + (close-port (current-input-port)) + (dup2 (fileno input) 0) + (close-port (current-output-port)) + (dup2 (fileno (cdr i+o)) 1) + (apply execl (car command) command)) + (child + (close-port (cdr i+o)) + (values (car i+o) child))))) + +(define (decompressed-port compression input) + "Return an input port where INPUT is decompressed according to COMPRESSION." + (match compression + ("none" (values input #f)) + ("bzip2" (filtered-port `(,%bzip2 "-dc") input)) + ("xz" (filtered-port `(,%xz "-dc") input)) + ("gzip" (filtered-port `(,%gzip "-dc") input)) + (else (error "unsupported compression scheme" compression)))) + (define %cache-url (or (getenv "GUIX_BINARY_SUBSTITUTE_URL") "http://hydra.gnu.org")) @@ -222,10 +261,29 @@ failure." (error "unknown `--query' command" wtf))) (loop (read-line))))))) (("--substitute" store-path destination) - ;; Download PATH and add it to the store. - ;; TODO: Implement. - (format (current-error-port) "substitution not implemented yet~%") - #f) + ;; Download STORE-PATH and add store it as a Nar in file DESTINATION. + (let* ((cache (open-cache %cache-url)) + (narinfo (fetch-narinfo cache store-path)) + (uri (narinfo-uri narinfo))) + ;; Tell the daemon what the expected hash of the Nar itself is. + (format #t "~a~%" (narinfo-hash narinfo)) + + (let*-values (((raw download-size) + (fetch uri)) + ((input pid) + (decompressed-port (narinfo-compression narinfo) + raw))) + ;; Note that Hydra currently generates Nars on the fly and doesn't + ;; specify a Content-Length, so DOWNLOAD-SIZE is #f in practice. + (format (current-error-port) + (_ "downloading `~a' from `~a'~:[~*~; (~,1f KiB)~]...~%") + store-path (uri->string uri) + download-size + (and=> download-size (cut / <> 1024.0))) + + ;; Unpack the Nar at INPUT into DESTINATION. + (restore-file input destination) + (or (not pid) (zero? (cdr (waitpid pid))))))) (("--version") (show-version-and-exit "guix substitute-binary")))) diff --git a/tests/store.scm b/tests/store.scm index c75b99c6a9..4ee20a9352 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -23,9 +23,11 @@ #:use-module (guix base32) #:use-module (guix packages) #:use-module (guix derivations) + #:use-module (guix nar) #:use-module (gnu packages) #:use-module (gnu packages bootstrap) #:use-module (ice-9 match) + #:use-module (rnrs io ports) #:use-module (web uri) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) @@ -141,7 +143,7 @@ (call-with-output-file (string-append dir "/nix-cache-info") (lambda (p) (format p "StoreDir: ~a\nWantMassQuery: 0\n" - (getenv "NIX_STORE_DIR")))) + (%store-prefix)))) (call-with-output-file (string-append dir "/" (store-path-hash-part o) ".narinfo") (lambda (p) @@ -167,6 +169,57 @@ Deriver: ~a~%" (null? (substitutable-references s)) (equal? (substitutable-nar-size s) 1234))))))) +(test-assert "substitute" + (let* ((s (open-connection)) + (c (random-text)) ; contents of the output + (d (build-expression->derivation + s "substitute-me" (%current-system) + `(call-with-output-file %output + (lambda (p) + (exit 1) ; would actually fail + (display ,c p))) + '() + #:guile-for-build + (package-derivation s %bootstrap-guile (%current-system)))) + (o (derivation-path->output-path d)) + (dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL") + (compose uri-path string->uri)))) + ;; Create fake substituter data, to be read by `substitute-binary'. + (call-with-output-file (string-append dir "/nix-cache-info") + (lambda (p) + (format p "StoreDir: ~a\nWantMassQuery: 0\n" + (%store-prefix)))) + (call-with-output-file (string-append dir "/example.out") + (lambda (p) + (display c p))) + (call-with-output-file (string-append dir "/example.nar") + (lambda (p) + (write-file (string-append dir "/example.out") p))) + (call-with-output-file (string-append dir "/" (store-path-hash-part o) + ".narinfo") + (lambda (p) + (format p "StorePath: ~a +URL: ~a +Compression: none +NarSize: 1234 +NarHash: sha256:~a +References: +System: ~a +Deriver: ~a~%" + o ; StorePath + "example.nar" ; relative URL + (call-with-input-file (string-append dir "/example.nar") + (compose bytevector->nix-base32-string sha256 + get-bytevector-all)) + (%current-system) ; System + (basename d)))) ; Deriver + + ;; Make sure we use `substitute-binary'. + (set-build-options s #:use-substitutes? #t) + (and (has-substitutes? s o) + (build-derivations s (list d)) + (equal? c (call-with-input-file o get-string-all))))) + (test-end "store") -- cgit v1.2.3 From 581f9eb84532b5682f48926e868456e2457fe54c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 12 Apr 2013 15:43:55 +0200 Subject: guix package: Add `--no-substitutes'. * guix/scripts/package.scm (%default-options): Add `substitutes?'. (show-help, %options): Add and document `--no-substitutes'. (guix-package): Call `set-build-options' to honor `substitutes?'. --- doc/guix.texi | 3 +++ guix/scripts/package.scm | 13 ++++++++++++- 2 files changed, 15 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 1be172c3f6..c91bc2021d 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -570,6 +570,9 @@ Use @var{profile} instead of the user's default profile. @itemx -n Show what would be done without actually doing it. +@item --no-substitutes +Build instead of resorting to pre-built substitutes. + @item --verbose Produce verbose output. In particular, emit the environment's build log on the standard error port. diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 89708ccc49..ba75cd778c 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -313,7 +313,8 @@ but ~a is available upstream~%") (define %default-options ;; Alist of default option values. - `((profile . ,%current-profile))) + `((profile . ,%current-profile) + (substitutes? . #t))) (define (show-help) (display (_ "Usage: guix package [OPTION]... PACKAGES... @@ -334,6 +335,8 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) -p, --profile=PROFILE use PROFILE instead of the user's default profile")) (display (_ " -n, --dry-run show what would be done without actually doing it")) + (display (_ " + --no-substitutes build instead of resorting to pre-built substitutes")) (display (_ " --bootstrap use the bootstrap Guile to build the profile")) (display (_ " @@ -388,6 +391,10 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t result))) + (option '("no-substitutes") #f #f + (lambda (opt name arg result) + (alist-cons 'substitutes? #f + (alist-delete 'substitutes? result)))) (option '("bootstrap") #f #f (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) @@ -750,6 +757,10 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (or (process-query opts) (with-error-handling (parameterize ((%store (open-connection))) + (set-build-options (%store) + #:use-substitutes? + (assoc-ref opts 'substitutes?)) + (parameterize ((%guile-for-build (package-derivation (%store) (if (assoc-ref opts 'bootstrap?) -- cgit v1.2.3 From d5d6db8918fb8cd66132f5ad5d4c03d6ed2db815 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 12 Apr 2013 18:07:17 +0200 Subject: package: Being at the empty profile is not an error. * guix/scripts/package.scm (roll-back): Use `format', not `leave' when indicating "already at the empty profile". Fixes a regression introduced in a2011be5dfaf2b94a1d0e3dfbcf4b512389b4711. Reported by Nikita Karetnikov . --- guix/scripts/package.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index ba75cd778c..ac99d16497 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -211,7 +211,8 @@ all of PACKAGES, a list of name/version/output/path/deps tuples." (leave (_ "error: profile `~a' does not exist~%") profile)) ((zero? number) ; empty profile - (leave (_ "nothing to do: already at the empty profile~%"))) + (format (current-error-port) + (_ "nothing to do: already at the empty profile~%"))) ((or (zero? previous-number) ; going to emptiness (not (file-exists? previous-profile))) (let*-values (((drv-path drv) -- cgit v1.2.3 From 841032d4482360b8125291f80b20111e1371167a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 12 Apr 2013 18:22:41 +0200 Subject: store: Remove unneeded and conflicting import. * guix/store.scm: Remove unneeded (ice-9 rdelim) import. In Guile 2.0.9 that module exports `read-string', which conflicts with that of (guix serialization). --- guix/store.scm | 1 - 1 file changed, 1 deletion(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index cc21af84e4..b1b60babf0 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -30,7 +30,6 @@ #:use-module (srfi srfi-35) #:use-module (srfi srfi-39) #:use-module (ice-9 match) - #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:export (%daemon-socket-file -- cgit v1.2.3 From 35ac56b63e438aaefde9364db7164dd213677022 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 16 Apr 2013 14:05:00 +0200 Subject: build-system/{perl,cmake}: Keep the standard search paths of gnu-build-system. Reported by Andreas Enge . * guix/build-system/gnu.scm (standard-search-paths): New procedure. (gnu-build): Use it. * guix/build-system/perl.scm (perl-build): Append (standard-search-paths) to the search paths of PERL. * guix/build-system/cmake.scm (cmake-build): Append (standard-search-paths) to SEARCH-PATHS. --- guix/build-system/cmake.scm | 3 ++- guix/build-system/gnu.scm | 18 ++++++++++++------ guix/build-system/perl.scm | 3 ++- 3 files changed, 16 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm index 4e993f3961..3347dc502c 100644 --- a/guix/build-system/cmake.scm +++ b/guix/build-system/cmake.scm @@ -72,7 +72,8 @@ provides a 'CMakeLists.txt' file as its build system." #:outputs %outputs #:inputs %build-inputs #:search-paths ',(map search-path-specification->sexp - search-paths) + (append search-paths + (standard-search-paths))) #:patches ,patches #:patch-flags ,patch-flags #:phases ,phases diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index 3b3d99b313..b64bce7dae 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -27,6 +27,7 @@ #:use-module (ice-9 match) #:export (gnu-build gnu-build-system + standard-search-paths standard-inputs package-with-explicit-inputs package-with-extra-configure-variable @@ -143,6 +144,16 @@ standard packages used as implicit inputs of the GNU build system." (let ((distro (resolve-module '(gnu packages base)))) (module-ref distro '%final-inputs))) +(define (standard-search-paths) + "Return the list of for the standard (implicit) +inputs." + (append-map (match-lambda + ((_ (? package? p) _ ...) + (package-native-search-paths p)) + (_ + '())) + (standard-packages))) + (define standard-inputs (memoize (lambda (system) @@ -204,12 +215,7 @@ which could lead to gratuitous input divergence." (define implicit-search-paths (if implicit-inputs? - (append-map (match-lambda - ((_ (? package? p) _ ...) - (package-native-search-paths p)) - (_ - '())) - (standard-packages)) + (standard-search-paths) '())) (define builder diff --git a/guix/build-system/perl.scm b/guix/build-system/perl.scm index c97698e225..1ff9fd2674 100644 --- a/guix/build-system/perl.scm +++ b/guix/build-system/perl.scm @@ -55,7 +55,8 @@ "Build SOURCE using PERL, and with INPUTS. This assumes that SOURCE provides a `Makefile.PL' file as its build system." (define perl-search-paths - (package-native-search-paths perl)) + (append (package-native-search-paths perl) + (standard-search-paths))) (define builder `(begin -- cgit v1.2.3 From 2bcfb9e065ac6abb6abf7ac9a263ba3c4d70124f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 28 Apr 2013 21:38:40 +0200 Subject: utils: Add `string-tokenize*'. * guix/utils.scm (string-tokenize*): New procedure. * tests/utils.scm ("string-tokenize*"): New test. --- guix/utils.scm | 28 ++++++++++++++++++++++++++++ tests/utils.scm | 10 ++++++++++ 2 files changed, 38 insertions(+) (limited to 'guix') diff --git a/guix/utils.scm b/guix/utils.scm index 3cbed2fd0f..0b09affffd 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -60,6 +60,7 @@ version-compare version>? package-name->name+version + string-tokenize* file-extension call-with-temporary-output-file fold2)) @@ -471,6 +472,33 @@ introduce the version part." (let ((dot (string-rindex file #\.))) (and dot (substring file (+ 1 dot) (string-length file))))) +(define (string-tokenize* string separator) + "Return the list of substrings of STRING separated by SEPARATOR. This is +like `string-tokenize', but SEPARATOR is a string." + (define (index string what) + (let loop ((string string) + (offset 0)) + (cond ((string-null? string) + #f) + ((string-prefix? what string) + offset) + (else + (loop (string-drop string 1) (+ 1 offset)))))) + + (define len + (string-length separator)) + + (let loop ((string string) + (result '())) + (cond ((index string separator) + => + (lambda (offset) + (loop (string-drop string (+ offset len)) + (cons (substring string 0 offset) + result)))) + (else + (reverse (cons string result)))))) + (define (call-with-temporary-output-file proc) "Call PROC with a name of a temporary file and open output port to that file; close the file and delete it when leaving the dynamic extent of this diff --git a/tests/utils.scm b/tests/utils.scm index fa7d7b03fd..97547a6d62 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -64,6 +64,16 @@ ("nixpkgs" "1.0pre22125_a28fe19") ("gtk2" "2.38.0")))) +(test-equal "string-tokenize*" + '(("foo") + ("foo" "bar" "baz") + ("foo" "bar" "") + ("foo" "bar" "baz")) + (list (string-tokenize* "foo" ":") + (string-tokenize* "foo;bar;baz" ";") + (string-tokenize* "foo!bar!" "!") + (string-tokenize* "foo+-+bar+-+baz" "+-+"))) + (test-equal "fold2, 1 list" (list (reverse (iota 5)) (map - (reverse (iota 5)))) -- cgit v1.2.3 From 5924080dccae93fa725bf77df5f7a1e9a8756101 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 28 Apr 2013 23:05:57 +0200 Subject: guix package: Add `--search-paths' & co. * guix/scripts/package.scm (search-path-environment-variables, display-search-paths): New procedures. (show-help, %options): Add `--search-paths'. (guix-package)[process-actions]: Call `display-search-paths' once the profile is ready. [process-query]: Honor `search-paths'. --- doc/guix.texi | 22 +++++++++++++++- guix/scripts/package.scm | 66 +++++++++++++++++++++++++++++++++++++++++++++++- tests/guix-package.sh | 8 ++++++ 3 files changed, 94 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index e23eab0f81..d571de95a0 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -517,8 +517,13 @@ Thus, when installing MPC, the MPFR and GMP libraries also get installed in the profile; removing MPC also removes MPFR and GMP---unless they had also been explicitly installed independently. +Besides, packages sometime rely on the definition of environment +variables for their search paths (see explanation of +@code{--search-paths} below.) Any missing or possibly incorrect +environment variable definitions are reported here. + @c XXX: keep me up-to-date -Besides, when installing a GNU package, the tool reports the +Finally, when installing a GNU package, the tool reports the availability of a newer upstream version. In the future, it may provide the option of installing directly from the upstream version, even if that version is not yet in the distribution. @@ -566,6 +571,21 @@ Installing, removing, or upgrading packages from a generation that has been rolled back to overwrites previous future generations. Thus, the history of a profile's generations is always linear. +@item --search-paths +@cindex search paths +Report environment variable definitions, in Bash syntax, that may be +needed in order to use the set of installed packages. These environment +variables are used to specify @dfn{search paths} for files used by some +of the installed packages. + +For example, GCC needs the @code{CPATH} and @code{LIBRARY_PATH} +environment variables to be defined so it can look for headers and +libraries in the user's profile (@pxref{Environment Variables,,, gcc, +Using the GNU Compiler Collection (GCC)}). If GCC and, say, the C +library are installed in the profile, then @code{--search-paths} will +suggest setting these variables to @code{@var{profile}/include} and +@code{@var{profile}/lib}, respectively. + @item --profile=@var{profile} @itemx -p @var{profile} Use @var{profile} instead of the user's default profile. diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index c5656efc14..560b673618 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -330,6 +330,53 @@ but ~a is available upstream~%") ((getaddrinfo-error ftp-error) #f) (else (apply throw key args)))))) +(define* (search-path-environment-variables packages profile + #:optional (getenv getenv)) + "Return environment variable definitions that may be needed for the use of +PACKAGES in PROFILE. Use GETENV to determine the current settings and report +only settings not already effective." + + ;; The search path info is not stored in the manifest. Thus, we infer the + ;; search paths from same-named packages found in the distro. + + (define package-in-manifest->package + (match-lambda + ((name version _ ...) + (match (append (find-packages-by-name name version) + (find-packages-by-name name)) + ((p _ ...) p) + (_ #f))))) + + (define search-path-definition + (match-lambda + (($ variable directories separator) + (let ((values (or (and=> (getenv variable) + (cut string-tokenize* <> separator)) + '())) + (directories (filter file-exists? + (map (cut string-append profile + "/" <>) + directories)))) + (if (every (cut member <> values) directories) + #f + (format #f "export ~a=\"~a\"" + variable + (string-join directories separator))))))) + + (let* ((packages (filter-map package-in-manifest->package packages)) + (search-paths (delete-duplicates + (append-map package-native-search-paths + packages)))) + (filter-map search-path-definition search-paths))) + +(define (display-search-paths packages profile) + "Display the search path environment variables that may need to be set for +PACKAGES, in the context of PROFILE." + (let ((settings (search-path-environment-variables packages profile))) + (unless (null? settings) + (format #t (_ "The following environment variable definitions may be needed:~%")) + (format #t "~{ ~a~%~}" settings)))) + ;;; ;;; Command-line options. @@ -354,6 +401,8 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) -u, --upgrade[=REGEXP] upgrade all the installed packages matching REGEXP")) (display (_ " --roll-back roll back to the previous generation")) + (display (_ " + --search-paths display needed environment variable definitions")) (newline) (display (_ " -p, --profile=PROFILE use PROFILE instead of the user's default profile")) @@ -408,6 +457,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (option '("roll-back") #f #f (lambda (opt name arg result) (alist-cons 'roll-back? #t result))) + (option '("search-paths") #f #f + (lambda (opt name arg result) + (cons `(query search-paths) result))) (option '(#\p "profile") #t #f (lambda (opt name arg result) (alist-cons 'profile arg @@ -728,7 +780,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (build-derivations (%store) (list prof-drv))) (begin (switch-symlinks name prof) - (switch-symlinks profile name)))))))))) + (switch-symlinks profile name) + (display-search-paths packages + profile)))))))))) (define (process-query opts) ;; Process any query specified by OPTS. Return #t when a query was @@ -776,6 +830,16 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (for-each (cute package->recutils <> (current-output-port)) (find-packages-by-description regexp)) #t)) + + (('search-paths) + (let* ((manifest (profile-manifest profile)) + (packages (manifest-packages manifest)) + (settings (search-path-environment-variables packages + profile + (const #f)))) + (format #t "~{~a~%~}" settings) + #t)) + (_ #f)))) (let ((opts (parse-options))) diff --git a/tests/guix-package.sh b/tests/guix-package.sh index 7b101aa501..5a514a0dc0 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -47,6 +47,10 @@ test -L "$profile" && test -L "$profile-1-link" ! test -f "$profile-2-link" test -f "$profile/bin/guile" +# No search path env. var. here. +guix package --search-paths -p "$profile" +test "`guix package --search-paths -p "$profile" | wc -l`" = 0 + # Check whether we have network access. if guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null then @@ -119,6 +123,10 @@ then rm "$profile-1-link" guix package --bootstrap -p "$profile" --roll-back test "`readlink_base "$profile"`" = "$profile-0-link" + + # Make sure LIBRARY_PATH gets listed by `--search-paths'. + guix package --bootstrap -p "$profile" -i guile-bootstrap -i gcc-bootstrap + guix package --search-paths -p "$profile" | grep LIBRARY_PATH fi # Make sure the `:' syntax works. -- cgit v1.2.3 From 593987671af63984632ae54eab13f9a47d471ea5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 27 Apr 2013 17:27:16 +0200 Subject: build-system/gnu: Fix default name for the "doc" output directory. * guix/build/gnu-build-system.scm (configure)[package-name]: Drop the prefix corresponding to the hash part of OUT. --- guix/build/gnu-build-system.scm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index 94a7d6bca8..47820aa02e 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -109,9 +109,10 @@ makefiles." (base (basename out)) (dash (string-rindex base #\-))) ;; XXX: We'd rather use `package-name->name+version' or similar. - (if dash - (substring base 0 dash) - base))) + (string-drop (if dash + (substring base 0 dash) + base) + (+ 1 (string-index base #\-))))) (let* ((prefix (assoc-ref outputs "out")) (bindir (assoc-ref outputs "bin")) -- cgit v1.2.3 From 01155b1808b17f0a4f54388261ab0c6f5fee2f1b Mon Sep 17 00:00:00 2001 From: Nikita Karetnikov Date: Sun, 28 Apr 2013 16:08:23 +0000 Subject: utils: Adjust 'wrap-program'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/build/utils.scm (wrap-program): Fix computation of PROG-REAL and PROG-TMP when PROG is an absolute file name. Add "$@" in the generated script, and quote PROG-REAL. Signed-off-by: Ludovic Courtès --- guix/build/utils.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/build/utils.scm b/guix/build/utils.scm index 356dd46b52..a4a82a5f8c 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -680,8 +680,8 @@ contents: This is useful for scripts that expect particular programs to be in $PATH, for programs that expect particular shared libraries to be in $LD_LIBRARY_PATH, or modules in $GUILE_LOAD_PATH, etc." - (let ((prog-real (string-append "." prog "-real")) - (prog-tmp (string-append "." prog "-tmp"))) + (let ((prog-real (string-append (dirname prog) "/." (basename prog) "-real")) + (prog-tmp (string-append (dirname prog) "/." (basename prog) "-tmp"))) (define (export-variable lst) ;; Return a string that exports an environment variable. (match lst @@ -709,7 +709,7 @@ modules in $GUILE_LOAD_PATH, etc." (with-output-to-file prog-tmp (lambda () (format #t - "#!~a~%~a~%exec ~a~%" + "#!~a~%~a~%exec \"~a\" \"$@\"~%" (which "bash") (string-join (map export-variable vars) "\n") -- cgit v1.2.3