aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-01-08 22:06:54 +0100
committerLudovic Courtès <ludo@gnu.org>2014-01-08 22:06:54 +0100
commit2f265602ff23e41f75932aa568fe62e149e3cb9d (patch)
tree3ff7d0b4be81246a4dfd3df414e163d8cbdc4990
parentaa6b0d6bf01aba60c6b5524e4422e7a4cebf01e4 (diff)
parent1d6816f98ca1746f0b627a6dee9c0adbbf7533c4 (diff)
downloadguix-2f265602ff23e41f75932aa568fe62e149e3cb9d.tar
guix-2f265602ff23e41f75932aa568fe62e149e3cb9d.tar.gz
Merge branch 'master' into core-updates
-rw-r--r--.dir-locals.el1
-rw-r--r--.gitignore1
-rw-r--r--Makefile.am12
-rw-r--r--ROADMAP14
-rw-r--r--THANKS2
-rw-r--r--TODO73
-rw-r--r--config-daemon.ac2
-rw-r--r--configure.ac10
-rw-r--r--daemon.am8
-rw-r--r--doc/guix.texi119
-rw-r--r--gnu-system.am4
-rw-r--r--gnu/packages.scm43
-rw-r--r--gnu/packages/autotools.scm4
-rw-r--r--gnu/packages/cdrom.scm8
-rw-r--r--gnu/packages/games.scm95
-rw-r--r--gnu/packages/gdbm.scm4
-rw-r--r--gnu/packages/gl.scm59
-rw-r--r--gnu/packages/gnome.scm28
-rw-r--r--gnu/packages/gnunet.scm4
-rw-r--r--gnu/packages/gnupg.scm13
-rw-r--r--gnu/packages/gnuzilla.scm1
-rw-r--r--gnu/packages/iso-codes.scm4
-rw-r--r--gnu/packages/lsh.scm82
-rw-r--r--gnu/packages/nettle.scm10
-rw-r--r--gnu/packages/parallel.scm4
-rw-r--r--gnu/packages/patches/gtkglext-disable-disable-deprecated.patch36
-rw-r--r--gnu/packages/patches/gtkglext-remove-pangox-dependency.patch132
-rw-r--r--gnu/packages/patches/pulseaudio-volume-test.patch29
-rw-r--r--gnu/packages/pulseaudio.scm15
-rw-r--r--gnu/packages/python.scm8
-rw-r--r--gnu/packages/qemu.scm1
-rw-r--r--gnu/packages/qt.scm1
-rw-r--r--gnu/packages/sdl.scm1
-rw-r--r--gnu/packages/shishi.scm10
-rw-r--r--gnu/packages/ssh.scm15
-rw-r--r--gnu/packages/vim.scm4
-rw-r--r--gnu/packages/xorg.scm62
-rw-r--r--guix/config.scm.in12
-rw-r--r--guix/pk-crypto.scm372
-rw-r--r--guix/pki.scm139
-rw-r--r--guix/scripts/archive.scm337
-rw-r--r--guix/scripts/authenticate.scm101
-rw-r--r--guix/scripts/build.scm293
-rw-r--r--guix/scripts/package.scm88
-rwxr-xr-xguix/scripts/substitute-binary.scm16
-rw-r--r--guix/store.scm105
-rw-r--r--guix/utils.scm16
-rw-r--r--nix/libutil/gcrypt-hash.cc1
-rw-r--r--nix/libutil/gcrypt-hash.hh17
-rw-r--r--nix/nix-daemon/guix-daemon.cc10
-rw-r--r--nix/scripts/guix-authenticate.in11
-rwxr-xr-xnix/sync-with-upstream8
-rw-r--r--po/POTFILES.in1
-rw-r--r--test-env.in18
-rw-r--r--tests/guix-archive.sh66
-rw-r--r--tests/guix-authenticate.sh63
-rw-r--r--tests/guix-package.sh9
-rw-r--r--tests/pk-crypto.scm230
-rw-r--r--tests/pki.scm51
-rw-r--r--tests/signing-key.pub4
-rw-r--r--tests/signing-key.sec8
-rw-r--r--tests/store.scm45
62 files changed, 2510 insertions, 430 deletions
diff --git a/.dir-locals.el b/.dir-locals.el
index bb4e964dd5..87cdaae807 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -20,6 +20,7 @@
(eval . (put 'substitute-keyword-arguments 'scheme-indent-function 1))
(eval . (put 'with-error-handling 'scheme-indent-function 0))
(eval . (put 'with-mutex 'scheme-indent-function 1))
+ (eval . (put 'with-atomic-file-output 'scheme-indent-function 1))
(eval . (put 'syntax-parameterize 'scheme-indent-function 1))
(eval . (put 'with-monad 'scheme-indent-function 1))
diff --git a/.gitignore b/.gitignore
index a8a5cad74c..09a593e9fa 100644
--- a/.gitignore
+++ b/.gitignore
@@ -84,3 +84,4 @@ GPATH
GRTAGS
GTAGS
/nix-setuid-helper
+/nix/scripts/guix-authenticate
diff --git a/Makefile.am b/Makefile.am
index eb278a76e9..6d6aba059b 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -30,6 +30,8 @@ MODULES = \
guix/base32.scm \
guix/records.scm \
guix/hash.scm \
+ guix/pk-crypto.scm \
+ guix/pki.scm \
guix/utils.scm \
guix/download.scm \
guix/monads.scm \
@@ -66,12 +68,14 @@ MODULES = \
guix/snix.scm \
guix/scripts/download.scm \
guix/scripts/build.scm \
+ guix/scripts/archive.scm \
guix/scripts/import.scm \
guix/scripts/package.scm \
guix/scripts/gc.scm \
guix/scripts/hash.scm \
guix/scripts/pull.scm \
guix/scripts/substitute-binary.scm \
+ guix/scripts/authenticate.scm \
guix/scripts/refresh.scm \
guix.scm \
$(GNU_SYSTEM_MODULES)
@@ -107,6 +111,8 @@ clean-go:
SCM_TESTS = \
tests/base32.scm \
tests/hash.scm \
+ tests/pk-crypto.scm \
+ tests/pki.scm \
tests/builders.scm \
tests/derivations.scm \
tests/ui.scm \
@@ -126,7 +132,9 @@ SH_TESTS = \
tests/guix-download.sh \
tests/guix-gc.sh \
tests/guix-hash.sh \
- tests/guix-package.sh
+ tests/guix-package.sh \
+ tests/guix-archive.sh \
+ tests/guix-authenticate.sh
if BUILD_DAEMON
@@ -170,6 +178,8 @@ EXTRA_DIST = \
srfi/srfi-64.scm \
srfi/srfi-64.upstream.scm \
tests/test.drv \
+ tests/signing-key.pub \
+ tests/signing-key.sec \
build-aux/config.rpath \
bootstrap \
release.nix \
diff --git a/ROADMAP b/ROADMAP
index 6c0e2c5377..1843743916 100644
--- a/ROADMAP
+++ b/ROADMAP
@@ -2,7 +2,7 @@
#+TITLE: Tentative GNU Guix Road Map
-Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
Copying and distribution of this file, with or without modification,
are permitted in any medium without royalty provided the copyright
@@ -15,10 +15,18 @@ The goals of the GNU Guix project are two-fold:
- to use it to build a practical 100% free software distribution of
GNU/Linux and possibly other GNU variants, with a focus on the
- promotion and tight integration of GNU components.
+ promotion and tight integration of GNU components–the GNU system.
-This documents lists tentative milestones toward these goals.
+This document lists milestones toward these goals.
+The timeline below was written at the end of Dec. 2012. An updated and more
+detailed list of the remaining milestones was posted at
+https://lists.gnu.org/archive/html/guix-devel/2013-12/msg00120.html .
+
+The actual timeline was of course slightly different than initially
+envisioned, and so was the feature set–things like cross-compilation support
+and the MIPS64 port were not planned back then. See the news section at
+http://www.gnu.org/software/guix/ and ‘NEWS’ for the release history.
* GNU Guix 0.1: Jan. 2013 (was: Dec. 2012)
diff --git a/THANKS b/THANKS
index 95d92aa9d6..592bd44449 100644
--- a/THANKS
+++ b/THANKS
@@ -15,7 +15,9 @@ infrastructure help:
Rafael Ferreira <rafael.f.f1@gmail.com>
Christian Grothoff <christian@grothoff.org>
Jeffrin Jose <ahiliation@yahoo.co.in>
+ Kete <kete@ninthfloor.org>
Matthew Lien <bluet@bluet.org>
+ Niels Möller <nisse@lysator.liu.se>
Yutaka Niibe <gniibe@fsij.org>
Cyrill Schenkel <cyrill.schenkel@gmail.com>
Jason Self <jself@gnu.org>
diff --git a/TODO b/TODO
index 10326ec2ac..0d52633556 100644
--- a/TODO
+++ b/TODO
@@ -11,23 +11,6 @@ Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
* integrate needed Nix code
-** Remove dependency on OpenSSL
-
-The ‘openssl’ command-line tool is used in libstore to sign store paths
-to be exported, and to check such signatures. The signing keys are
-usually in /etc/nix/signing-key.{pub,sec}. They are a PKCS#8-encoded
-X.509 SubjectPublicKeyInfo. These can be decoded with the [[http://lists.gnu.org/archive/html/help-gnutls/2012-12/msg00012.html][C API of
-GnuTLS]], but not yet with its Guile bindings. There’s also
-‘gnutls_privkey_sign_data’ to sign, and related functions.
-
-
-** Add `guix publish' to publish the store using Guile's web server
-
-Generate narinfos and nars on the fly, upon HTTP GET requests.
-Ideally, extend .nix-cache-info to include the server's public key, and also
-reply to requests for .narinfo.sig.
-Optionally, use Guile-Avahi to publish the service.
-
** MAYBE Add a substituter that uses the GNUnet DHT or [[http://libswift.org][libswift]]
Would be neat if binaries could be pushed to and pulled from the GNUnet DHT or
@@ -40,6 +23,13 @@ Use UPnP and similar to traverse NAT, like ‘filegive’ does.
Like scripts/build-remote.pl in Nix.
+* Add `guix publish' to publish the store using Guile's web server
+
+Generate narinfos and nars on the fly, upon HTTP GET requests.
+Ideally, extend .nix-cache-info to include the server's public key, and also
+reply to requests for .narinfo.sig.
+Optionally, use Guile-Avahi to publish the service.
+
* user interface
** Add a package.el (Emacs) back-end
@@ -48,17 +38,6 @@ package.el is quite monolithic, but we may be able to reuse/extend
** add guile-ncurses interface
-* extend <origin>
-** add OpenPGP signatures:
-
- (origin
- (method http-fetch)
- (uri "http://.../foo.tgz")
- (signature-uri (string-append uri ".sig"))
- (signer-openpgp-fingerprint "..."))
-
-** allow <origin> to be a derivation/package or a file
-
* extend <package>
** add ‘recommends’ field
@@ -84,28 +63,45 @@ create a new ‘dir’.
("i3" ,p3)))
#+END_SRC
+* MAYBE use HOP-like escapes to refer to inputs in build-side code
+
+Instead of doing things like:
+
+#+BEGIN_SRC scheme
+ (inputs `(("foo" ,foo)))
+ (arguments '(#:configure-flags
+ (list (string-append "--with-foo="
+ (assoc-ref %build-inputs "foo")))))
+#+END_SRC
+
+Allow things like:
+
+#+BEGIN_SRC scheme
+ (inputs (list foo))
+ (arguments ~(#:configure-flags
+ (list (string-append "--with-foo=" $foo))))
+
+#+END_SRC
+
+... where '~' is 'build-quote' and '$' is 'build-unquote'. Better yet,
+automatically compute the list of references of an expression passed to
+'derivation-expression'.
+
+Use a [[http://dorophone.blogspot.fr/2011/09/scheme-syntax-is-monad.html][monad]] for the syntax.
-* synchronize package descriptions with GSRC and/or the [[http://directory.fsf.org][FSD]]
+* synchronize non-GNU package descriptions with the [[http://directory.fsf.org][FSD]]
Meta-data for GNU packages, including descriptions and synopses, can be
dumped from the FSD:
http://directory.fsf.org/wiki?title=GNU/Export&action=purge .
We could periodically synchronize with that.
-See http://lists.gnu.org/archive/html/bug-guix/2013-04/msg00120.html for info
-on how to synchronize with GSRC's descriptions.
-
* add a guildhall build system
The Guildhall is Guile’s packaging system. It should be easy to add a
‘guildhall-build-system’ that does the right thing based on guildhall
recipes.
-* build-expression->derivation: define `%system' in the builder
-
-Would allow build expressions to have system-dependent code, like
-`glibc-dynamic-linker'.
-
* add ‘allowed-references’ in <package>
[[file:~/src/nix/src/libstore/build.cc::if%20(drv.env.find("allowedReferences")%20!%3D%20drv.env.end())%20{][See how Nix implements that internally]].
@@ -126,9 +122,6 @@ run when that is defined.
Would download a substitute, and compare its contents against a (hopefully
locally-built) copy.
-* guix package
-
-** add ‘--list-generations’, and ‘--delete-generations’
* guix build utils
** MAYBE Change ‘ld-wrapper’ to add RPATH for libs passed by file name
diff --git a/config-daemon.ac b/config-daemon.ac
index 5db08d099d..0717141198 100644
--- a/config-daemon.ac
+++ b/config-daemon.ac
@@ -105,6 +105,8 @@ if test "x$guix_build_daemon" = "xyes"; then
[chmod +x nix/scripts/list-runtime-roots])
AC_CONFIG_FILES([nix/scripts/substitute-binary],
[chmod +x nix/scripts/substitute-binary])
+ AC_CONFIG_FILES([nix/scripts/guix-authenticate],
+ [chmod +x nix/scripts/guix-authenticate])
fi
AM_CONDITIONAL([BUILD_DAEMON], [test "x$guix_build_daemon" = "xyes"])
diff --git a/configure.ac b/configure.ac
index 07f8539504..799b3e8152 100644
--- a/configure.ac
+++ b/configure.ac
@@ -36,10 +36,12 @@ AC_ARG_ENABLE([daemon],
[guix_build_daemon="$enableval"],
[guix_build_daemon="yes"])
-# Prepare a version of $localstatedir that does not contain references
+# Prepare a version of $localstatedir & co. that does not contain references
# to shell variables.
guix_localstatedir="`eval echo $localstatedir | sed -e "s|NONE|/usr/local|g"`"
+guix_sysconfdir="`eval echo $sysconfdir | sed -e "s|NONE|/usr/local|g"`"
AC_SUBST([guix_localstatedir])
+AC_SUBST([guix_sysconfdir])
dnl We require the pkg.m4 set of macros from pkg-config.
dnl Make sure it's available.
@@ -60,7 +62,8 @@ GUIX_CHECK_SRFI_37
AM_CONDITIONAL([INSTALL_SRFI_37], [test "x$ac_cv_guix_srfi_37_broken" = xyes])
AC_ARG_WITH([nix-prefix],
- [AS_HELP_STRING([--with-nix-prefix=DIR], [search for Nix in DIR])],
+ [AS_HELP_STRING([--with-nix-prefix=DIR],
+ [search for Nix in DIR (for testing purposes and '--disable-daemon' builds)])],
[case "$withval" in
yes|no) ;;
*)
@@ -84,7 +87,8 @@ if test "x$NIX_INSTANTIATE" = "x"; then
fi
AC_ARG_WITH([nixpkgs],
- [AS_HELP_STRING([--with-nixpkgs=DIR], [search for Nixpkgs in DIR])],
+ [AS_HELP_STRING([--with-nixpkgs=DIR],
+ [search for Nixpkgs in DIR (for testing purposes only)])],
[case "$withval" in
yes|no) AC_MSG_ERROR([Please use `--with-nixpkgs=DIR'.]);;
*) NIXPKGS="$withval";;
diff --git a/daemon.am b/daemon.am
index 77bfe71987..60bbaf73ed 100644
--- a/daemon.am
+++ b/daemon.am
@@ -112,10 +112,10 @@ libstore_a_CPPFLAGS = \
-DNIX_DATA_DIR=\"$(datadir)\" \
-DNIX_STATE_DIR=\"$(localstatedir)/nix\" \
-DNIX_LOG_DIR=\"$(localstatedir)/log/nix\" \
- -DNIX_CONF_DIR=\"$(sysconfdir)/nix\" \
+ -DNIX_CONF_DIR=\"$(sysconfdir)/guix\" \
-DNIX_LIBEXEC_DIR=\"$(libexecdir)\" \
-DNIX_BIN_DIR=\"$(bindir)\" \
- -DOPENSSL_PATH="\"openssl\""
+ -DOPENSSL_PATH="\"guix-authenticate\""
libstore_a_CXXFLAGS = \
$(SQLITE3_CFLAGS) $(LIBGCRYPT_CFLAGS)
@@ -180,6 +180,10 @@ nodist_pkglibexec_SCRIPTS = \
nix/scripts/list-runtime-roots \
nix/scripts/substitute-binary
+# XXX: It'd be better to hide it in $(pkglibexecdir).
+nodist_libexec_SCRIPTS = \
+ nix/scripts/guix-authenticate
+
EXTRA_DIST += \
nix/sync-with-upstream \
nix/libstore/schema.sql \
diff --git a/doc/guix.texi b/doc/guix.texi
index fcffa5a22b..93d1c2be3b 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -10,7 +10,7 @@
@include version.texi
@copying
-Copyright @copyright{} 2012, 2013 Ludovic Courtès@*
+Copyright @copyright{} 2012, 2013, 2014 Ludovic Courtès@*
Copyright @copyright{} 2013 Andreas Enge@*
Copyright @copyright{} 2013 Nikita Karetnikov
@@ -213,7 +213,8 @@ Bash syntax and the @code{shadow} commands):
do
useradd -g guix-builder -G guix-builder \
-d /var/empty -s `which nologin` \
- -c "Guix build user $i" guix-builder$i;
+ -c "Guix build user $i" --system \
+ guix-builder$i;
done
@end example
@@ -236,6 +237,14 @@ case, shared memory support is unavailable in the chroot environment.
The workaround is to make sure that @file{/dev/shm} is directly a
@code{tmpfs} mount point.}.
+Finally, you may want to generate a key pair to allow the daemon to
+export signed archives of files from the store (@pxref{Invoking guix
+archive}):
+
+@example
+# guix archive --generate-key
+@end example
+
Guix may also be used in a single-user setup, with @command{guix-daemon}
running as an unprivileged user. However, to maximize non-interference
of build processes, the daemon still needs to perform certain operations
@@ -407,9 +416,10 @@ management tools it provides.
@menu
* Features:: How Guix will make your life brighter.
* Invoking guix package:: Package installation, removal, etc.
-* Packages with Multiple Outputs:: Single source package, multiple outputs.
+* Packages with Multiple Outputs:: Single source package, multiple outputs.
* Invoking guix gc:: Running the garbage collector.
* Invoking guix pull:: Fetching the latest Guix and distribution.
+* Invoking guix archive:: Exporting and importing store files.
@end menu
@node Features
@@ -914,6 +924,103 @@ Use the bootstrap Guile to build the latest Guix. This option is only
useful to Guix developers.
@end table
+
+@node Invoking guix archive
+@section Invoking @command{guix archive}
+
+The @command{guix archive} command allows users to @dfn{export} files
+from the store into a single archive, and to later @dfn{import} them.
+In particular, it allows store files to be transferred from one machine
+to another machine's store. For example, to transfer the @code{emacs}
+package to a machine connected over SSH, one would run:
+
+@example
+guix archive --export emacs | ssh the-machine guix archive --import
+@end example
+
+@noindent
+However, note that, in this example, all of @code{emacs} and its
+dependencies are transferred, regardless of what is already available in
+the target machine's store. The @code{--missing} option can help figure
+out which items are missing from the target's store.
+
+Archives are stored in the ``Nix archive'' or ``Nar'' format, which is
+comparable in spirit to `tar'. When exporting, the daemon digitally
+signs the contents of the archive, and that digital signature is
+appended. When importing, the daemon verifies the signature and rejects
+the import in case of an invalid signature or if the signing key is not
+authorized.
+@c FIXME: Add xref to daemon doc about signatures.
+
+The main options are:
+
+@table @code
+@item --export
+Export the specified store files or packages (see below.) Write the
+resulting archive to the standard output.
+
+@item --import
+Read an archive from the standard input, and import the files listed
+therein into the store. Abort if the archive has an invalid digital
+signature, or if it is signed by a public key not among the authorized
+keys (see @code{--authorize} below.)
+
+@item --missing
+Read a list of store file names from the standard input, one per line,
+and write on the standard output the subset of these files missing from
+the store.
+
+@item --generate-key[=@var{parameters}]
+@cindex signing, archives
+Generate a new key pair for the daemons. This is a prerequisite before
+archives can be exported with @code{--export}. Note that this operation
+usually takes time, because it needs to gather enough entropy to
+generate the key pair.
+
+The generated key pair is typically stored under @file{/etc/guix}, in
+@file{signing-key.pub} (public key) and @file{signing-key.sec} (private
+key, which must be kept secret.) When @var{parameters} is omitted, it
+is a 4096-bit RSA key. Alternately, @var{parameters} can specify
+@code{genkey} parameters suitable for Libgcrypt (@pxref{General
+public-key related Functions, @code{gcry_pk_genkey},, gcrypt, The
+Libgcrypt Reference Manual}).
+
+@item --authorize
+@cindex authorizing, archives
+Authorize imports signed by the public key passed on standard input.
+The public key must be in ``s-expression advanced format''---i.e., the
+same format as the @file{signing-key.pub} file.
+
+The list of authorized keys is kept in the human-editable file
+@file{/etc/guix/acl}. The file contains
+@url{http://people.csail.mit.edu/rivest/Sexp.txt, ``advanced-format
+s-expressions''} and is structured as an access-control list in the
+@url{http://theworld.com/~cme/spki.txt, Simple Public-Key Infrastructure
+(SPKI)}.
+@end table
+
+To export store files as an archive to the standard output, run:
+
+@example
+guix archive --export @var{options} @var{specifications}...
+@end example
+
+@var{specifications} may be either store file names or package
+specifications, as for @command{guix package} (@pxref{Invoking guix
+package}). For instance, the following command creates an archive
+containing the @code{gui} output of the @code{git} package and the main
+output of @code{emacs}:
+
+@example
+guix archive --export git:gui /nix/store/...-emacs-24.3 > great.nar
+@end example
+
+If the specified packages are not built yet, @command{guix archive}
+automatically builds them. The build process may be controlled with the
+same options that can be passed to the @command{guix build} command
+(@pxref{Invoking guix build}).
+
+
@c *********************************************************************
@node Programming Interface
@chapter Programming Interface
@@ -1559,6 +1666,12 @@ packages locally.
Do not use substitutes for build products. That is, always build things
locally instead of allowing downloads of pre-built binaries.
+@item --no-build-hook
+Do not attempt to offload builds @i{via} the daemon's ``build hook''.
+That is, always build things locally instead of offloading builds to
+remote machines.
+@c TODO: Add xref to build hook doc.
+
@item --max-silent-time=@var{seconds}
When the build or substitution process remains silent for more than
@var{seconds}, terminate it and report a build failure.
diff --git a/gnu-system.am b/gnu-system.am
index d2b9bee25c..fbf61d6ec1 100644
--- a/gnu-system.am
+++ b/gnu-system.am
@@ -63,6 +63,7 @@ GNU_SYSTEM_MODULES = \
gnu/packages/fonts.scm \
gnu/packages/fontutils.scm \
gnu/packages/freeipmi.scm \
+ gnu/packages/games.scm \
gnu/packages/gawk.scm \
gnu/packages/gcal.scm \
gnu/packages/gcc.scm \
@@ -254,6 +255,8 @@ dist_patch_DATA = \
gnu/packages/patches/guile-linux-syscalls.patch \
gnu/packages/patches/guile-relocatable.patch \
gnu/packages/patches/guix-test-networking.patch \
+ gnu/packages/patches/gtkglext-disable-disable-deprecated.patch \
+ gnu/packages/patches/gtkglext-remove-pangox-dependency.patch \
gnu/packages/patches/hop-bigloo-4.0b.patch \
gnu/packages/patches/libevent-dns-tests.patch \
gnu/packages/patches/libffi-mips-n32-fix.patch \
@@ -273,6 +276,7 @@ dist_patch_DATA = \
gnu/packages/patches/procps-make-3.82.patch \
gnu/packages/patches/pspp-tests.patch \
gnu/packages/patches/pulseaudio-test-timeouts.patch \
+ gnu/packages/patches/pulseaudio-volume-test.patch \
gnu/packages/patches/python-fix-dbm.patch \
gnu/packages/patches/qemu-make-4.0.patch \
gnu/packages/patches/qemu-multiple-smb-shares.patch \
diff --git a/gnu/packages.scm b/gnu/packages.scm
index e9f2540b91..8365a00051 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -33,6 +33,7 @@
%bootstrap-binaries-path
fold-packages
find-packages-by-name
+ find-best-packages-by-name
find-newest-available-packages))
;;; Commentary:
@@ -148,24 +149,36 @@ then only return packages whose version is equal to VERSION."
result))
'()))
-(define (find-newest-available-packages)
- "Return a vhash keyed by package names, and with
+(define find-newest-available-packages
+ (memoize
+ (lambda ()
+ "Return a vhash keyed by package names, and with
associated values of the form
(newest-version newest-package ...)
where the preferred package is listed first."
- ;; FIXME: Currently, the preferred package is whichever one
- ;; was found last by 'fold-packages'. Find a better solution.
- (fold-packages (lambda (p r)
- (let ((name (package-name p))
- (version (package-version p)))
- (match (vhash-assoc name r)
- ((_ newest-so-far . pkgs)
- (case (version-compare version newest-so-far)
- ((>) (vhash-cons name `(,version ,p) r))
- ((=) (vhash-cons name `(,version ,p ,@pkgs) r))
- ((<) r)))
- (#f (vhash-cons name `(,version ,p) r)))))
- vlist-null))
+ ;; FIXME: Currently, the preferred package is whichever one
+ ;; was found last by 'fold-packages'. Find a better solution.
+ (fold-packages (lambda (p r)
+ (let ((name (package-name p))
+ (version (package-version p)))
+ (match (vhash-assoc name r)
+ ((_ newest-so-far . pkgs)
+ (case (version-compare version newest-so-far)
+ ((>) (vhash-cons name `(,version ,p) r))
+ ((=) (vhash-cons name `(,version ,p ,@pkgs) r))
+ ((<) r)))
+ (#f (vhash-cons name `(,version ,p) r)))))
+ vlist-null))))
+
+(define (find-best-packages-by-name name version)
+ "If version is #f, return the list of packages named NAME with the highest
+version numbers; otherwise, return the list of packages named NAME and at
+VERSION."
+ (if version
+ (find-packages-by-name name version)
+ (match (vhash-assoc name (find-newest-available-packages))
+ ((_ version pkgs ...) pkgs)
+ (#f '()))))
diff --git a/gnu/packages/autotools.scm b/gnu/packages/autotools.scm
index d37842c4ce..c2e4637ac0 100644
--- a/gnu/packages/autotools.scm
+++ b/gnu/packages/autotools.scm
@@ -132,14 +132,14 @@ exec ~a --no-auto-compile \"$0\" \"$@\"
(define-public automake
(package
(name "automake")
- (version "1.14")
+ (version "1.14.1")
(source (origin
(method url-fetch)
(uri (string-append "mirror://gnu/automake/automake-"
version ".tar.xz"))
(sha256
(base32
- "0nc0zqq8j336kamizzd86wb19vhbwywv5avcjh3cyx230xfqy671"))
+ "0s86rzdayj1licgj35q0mnynv5xa8f4p32m36blc5jk9id5z1d59"))
(patches
(list (search-patch "automake-skip-amhello-tests.patch")))))
(build-system gnu-build-system)
diff --git a/gnu/packages/cdrom.scm b/gnu/packages/cdrom.scm
index e54cce55fd..195de8ce52 100644
--- a/gnu/packages/cdrom.scm
+++ b/gnu/packages/cdrom.scm
@@ -68,14 +68,14 @@ caching facility provided by the library.")
(define-public libcdio
(package
(name "libcdio")
- (version "0.90")
+ (version "0.92")
(source (origin
(method url-fetch)
(uri (string-append "mirror://gnu/libcdio/libcdio-"
version ".tar.gz"))
(sha256
(base32
- "0kpp6gr5sjr30pb9klncc37fhkw0wi6r41d2fmvmw17cbj176zmg"))))
+ "1b9zngn8nnxb1yyngi1kwi73nahp4lsx59j17q1bahzz58svydik"))))
(build-system gnu-build-system)
(inputs
`(("ncurses" ,ncurses)
@@ -98,14 +98,14 @@ extraction from CDs.")
(define-public xorriso
(package
(name "xorriso")
- (version "1.3.2")
+ (version "1.3.4")
(source (origin
(method url-fetch)
(uri (string-append "mirror://gnu/xorriso/xorriso-"
version ".tar.gz"))
(sha256
(base32
- "1z04580nkkziy2flbxjjx0q6vp9p7vcp7yp0agx2aqz3l1vjcwhf"))))
+ "0wvxbvkpdydcbmqi9xz7nv8cna6vp9726ahmmxxyx56cz4xifr4x"))))
(build-system gnu-build-system)
(inputs
`(("acl" ,acl)
diff --git a/gnu/packages/games.scm b/gnu/packages/games.scm
new file mode 100644
index 0000000000..0f5ae4174d
--- /dev/null
+++ b/gnu/packages/games.scm
@@ -0,0 +1,95 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013 John Darrington <jmd@gnu.org>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(define-module (gnu packages games)
+ #:use-module (guix licenses)
+ #:use-module (guix packages)
+ #:use-module (guix download)
+ #:use-module (gnu packages gettext)
+ #:use-module (gnu packages gl)
+ #:use-module (gnu packages glib)
+ #:use-module (gnu packages gnome)
+ #:use-module (gnu packages gtk)
+ #:use-module (gnu packages guile)
+ #:use-module (gnu packages libcanberra)
+ #:use-module (gnu packages python)
+ #:use-module (gnu packages readline)
+ #:use-module (gnu packages xorg)
+ #:use-module (gnu packages pkg-config)
+ #:use-module (gnu packages sqlite)
+ #:use-module (guix build-system gnu))
+
+(define-public gnubg
+ (package
+ (name "gnubg")
+ (version "1.02")
+ (source
+ (origin
+ (method url-fetch)
+ (uri (string-append "http://files.gnubg.org/media/sources/gnubg-release-"
+ version ".000-sources." "tar.gz"))
+ (sha256
+ (base32
+ "015mvjk2iw1cg1kxwxfnvp2rxb9cylf6yc39i30fdy414k07zkky"))))
+ (build-system gnu-build-system)
+ (inputs `(("glib" ,glib)
+ ("readline" ,readline)
+ ("gtk+" ,gtk+-2)
+ ("mesa" ,mesa)
+ ("gtkglext" ,gtkglext)
+ ("sqlite" ,sqlite)
+ ("libcanberra" ,libcanberra)))
+ (native-inputs `(("python-2" ,python-2)
+ ("pkg-config" ,pkg-config)))
+ (home-page "https://gnubg.org")
+ (synopsis "Backgammon game")
+ (description "The GNU backgammon application can be used for playing, analyzing and
+teaching the game. It has an advanced evaluation engine based on artificial
+neural networks suitable for both beginners and advanced players. In
+addition to a command-line interface, it also features an attractive, 3D
+representation of the playing board.")
+ (license gpl3+)))
+
+(define-public gnubik
+ (package
+ (name "gnubik")
+ (version "2.4.1")
+ (source
+ (origin
+ (method url-fetch)
+ (uri (string-append "mirror://gnu/gnubik/gnubik-"
+ version ".tar.gz"))
+ (sha256
+ (base32
+ "0mfpwz341i1qpzi2qgslpc5i7d4fv7i01kv392m11pczqdc7i7m5"))))
+ (build-system gnu-build-system)
+ (inputs `(("gtk+" ,gtk+-2)
+ ("mesa" ,mesa)
+ ("libx11" ,libx11)
+ ("guile" ,guile-2.0)
+ ("gtkglext" ,gtkglext)))
+ (native-inputs `(("gettext" ,gnu-gettext)
+ ("pkg-config" ,pkg-config)))
+ (home-page "https://www.gnu.org/software/gnubik/")
+ (synopsis "3d Rubik's cube game.")
+ (description "GNUbik is a puzzle game in which you must manipulate a cube to make
+each of its faces have a uniform color. The game is customizable, allowing
+you to set the size of the cube (the default is 3x3) or to change the colors.
+You may even apply photos to the faces instead of colors. The game is
+scriptable with Guile.")
+ (license gpl3+)))
diff --git a/gnu/packages/gdbm.scm b/gnu/packages/gdbm.scm
index a43db9243e..62d02001c8 100644
--- a/gnu/packages/gdbm.scm
+++ b/gnu/packages/gdbm.scm
@@ -25,7 +25,7 @@
(define-public gdbm
(package
(name "gdbm")
- (version "1.10")
+ (version "1.11")
(source
(origin
(method url-fetch)
@@ -33,7 +33,7 @@
version ".tar.gz"))
(sha256
(base32
- "0h9lfzdjc2yl849y0byg51h6xfjg0y7vg9jnsw3gpfwlbd617y13"))))
+ "1hz3jgh3pd4qzp6jy0l8pd8x01g9abw7csnrlnj1a2sxy122z4cd"))))
(arguments `(#:configure-flags '("--enable-libgdbm-compat")))
(build-system gnu-build-system)
(home-page "http://www.gnu.org/software/gdbm/")
diff --git a/gnu/packages/gl.scm b/gnu/packages/gl.scm
index f54d6899ae..ee8aed9284 100644
--- a/gnu/packages/gl.scm
+++ b/gnu/packages/gl.scm
@@ -23,7 +23,12 @@
#:use-module (guix download)
#:use-module (guix build-system gnu)
#:use-module (guix packages)
+ #:use-module (gnu packages bison)
+ #:use-module (gnu packages flex)
+ #:use-module (gnu packages pkg-config)
+ #:use-module (gnu packages python)
#:use-module (gnu packages xorg)
+ #:use-module (gnu packages xml)
#:use-module (gnu packages fontutils))
(define-public glu
@@ -110,3 +115,57 @@ the X-Consortium license.")
rendering modes are: Bitmaps, Anti-aliased pixmaps, Texture maps, Outlines,
Polygon meshes, and Extruded polygon meshes")
(license l:x11)))
+
+(define-public mesa
+ (package
+ (name "mesa")
+ ;; In newer versions (9.0.5, 9.1 and 9.2 tested), "make" results in an
+ ;; infinite configure loop, see
+ ;; https://bugs.freedesktop.org/show_bug.cgi?id=58812
+ (version "8.0.5")
+ (source
+ (origin
+ (method url-fetch)
+ (uri (string-append
+ "ftp://ftp.freedesktop.org/pub/mesa/older-versions/8.x/"
+ version
+ "/MesaLib-" version
+ ".tar.bz2"))
+ (sha256
+ (base32
+ "0pjs8x51c0i6mawgd4w03lxpyx5fnx7rc8plr8jfsscf9yiqs6si"))))
+ (build-system gnu-build-system)
+ (propagated-inputs
+ `(("glproto" ,glproto)
+ ("libdrm" ,libdrm-2.4.33)
+ ("libxdamage" ,libxdamage)
+ ("libxxf86vm" ,libxxf86vm)))
+ (inputs
+ `(("dri2proto" ,dri2proto)
+ ("expat" ,expat)
+ ("libx11" ,libx11)
+ ("libxfixes" ,libxfixes)
+ ("libxml2" ,libxml2)
+ ("makedepend" ,makedepend)))
+ (native-inputs
+ `(("pkg-config" ,pkg-config)
+ ("flex" ,flex)
+ ("bison" ,bison)
+ ("python" ,python-2))) ; incompatible with Python 3 (print syntax)
+ (arguments
+ `(#:configure-flags
+ `("--with-gallium-drivers=r600,svga,swrast") ; drop r300 from the default list as it requires llvm
+ #:phases
+ (alist-cons-after
+ 'unpack 'remove-symlink
+ (lambda* (#:key #:allow-other-keys)
+ ;; remove dangling symlink to /usr/include/wine/windows
+ (delete-file "src/gallium/state_trackers/d3d1x/w32api"))
+ %standard-phases)))
+ (home-page "http://mesa3d.org/")
+ (synopsis "Mesa, an OpenGL implementation")
+ (description "Mesa is a free implementation of the OpenGL specification -
+a system for rendering interactive 3D graphics. A variety of device drivers
+allows Mesa to be used in many different environments ranging from software
+emulation to complete hardware acceleration for modern GPUs.")
+ (license l:x11)))
diff --git a/gnu/packages/gnome.scm b/gnu/packages/gnome.scm
index 609310efa5..90683f3635 100644
--- a/gnu/packages/gnome.scm
+++ b/gnu/packages/gnome.scm
@@ -21,6 +21,7 @@
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix build-system gnu)
+ #:use-module (gnu packages)
#:use-module (gnu packages glib)
#:use-module (gnu packages gnupg)
#:use-module (gnu packages gstreamer)
@@ -34,6 +35,7 @@
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
#:use-module (gnu packages xml)
+ #:use-module (gnu packages gl)
#:use-module (gnu packages xorg))
(define-public brasero
@@ -468,3 +470,29 @@ demand (lazy) programming language support for C, Python and JS; simplicity of
the API")
(license lgpl2.0+)))
+
+(define-public gtkglext
+ (package
+ (name "gtkglext")
+ (version "1.2.0")
+ (source (origin
+ (method url-fetch)
+ (uri (string-append "mirror://sourceforge/project/gtkglext/gtkglext/"
+ version "/gtkglext-" version ".tar.gz"))
+ (sha256
+ (base32 "1ya4d2j2aacr9ii5zj4ac95fjpdvlm2rg79mgnk7yvl1dcy3y1z5"))
+ (patches (list
+ (search-patch "gtkglext-remove-pangox-dependency.patch")
+ (search-patch "gtkglext-disable-disable-deprecated.patch")))))
+ (build-system gnu-build-system)
+ (inputs `(("gtk+" ,gtk+-2)
+ ("mesa" ,mesa)
+ ("libx11" ,libx11)
+ ("libxt" ,libxt)))
+ (native-inputs `(("pkg-config" ,pkg-config)))
+ (home-page "https://projects.gnome.org/gtkglext")
+ (synopsis "OpenGL extension to GTK+.")
+ (description "GtkGLExt is an OpenGL extension to GTK+. It provides
+additional GDK objects which support OpenGL rendering in GTK+ and GtkWidget
+API add-ons to make GTK+ widgets OpenGL-capable.")
+ (license lgpl2.1+)))
diff --git a/gnu/packages/gnunet.scm b/gnu/packages/gnunet.scm
index 63bbf08b56..df5b1e337c 100644
--- a/gnu/packages/gnunet.scm
+++ b/gnu/packages/gnunet.scm
@@ -41,14 +41,14 @@
(define-public libextractor
(package
(name "libextractor")
- (version "1.2")
+ (version "1.3")
(source (origin
(method url-fetch)
(uri (string-append "mirror://gnu/libextractor/libextractor-"
version ".tar.gz"))
(sha256
(base32
- "1n7z6s5ils6xmf6b0z1xda41maxj94c1n6wlyyxmacs5lrkh2a96"))))
+ "0zvv7wd011npcx7yphw9bpgivyxz6mlp87a57n96nv85k96dd2l6"))))
(build-system gnu-build-system)
;; WARNING: Checks require /dev/shm to be in the build chroot, especially
;; not to be a symbolic link to /run/shm.
diff --git a/gnu/packages/gnupg.scm b/gnu/packages/gnupg.scm
index be13eb0ba0..c3f717e60e 100644
--- a/gnu/packages/gnupg.scm
+++ b/gnu/packages/gnupg.scm
@@ -78,6 +78,7 @@ Daemon and possibly more in the future.")
`(#:configure-flags
(list (string-append "--with-gpg-error-prefix="
(assoc-ref %build-inputs "libgpg-error")))))
+ (outputs '("out" "debug"))
(home-page "http://gnupg.org/")
(synopsis "Cryptographic function library")
(description
@@ -87,6 +88,18 @@ algorithms, public key algorithms, large integer functions and random number
generation.")
(license lgpl2.0+)))
+(define-public libgcrypt-1.5
+ (package (inherit libgcrypt)
+ (version "1.5.3")
+ (source
+ (origin
+ (method url-fetch)
+ (uri (string-append "mirror://gnupg/libgcrypt/libgcrypt-"
+ version ".tar.bz2"))
+ (sha256
+ (base32
+ "1lar8y3lh61zl5flljpz540d78g99h4d5idfwrfw8lm3gm737xdw"))))))
+
(define-public libassuan
(package
(name "libassuan")
diff --git a/gnu/packages/gnuzilla.scm b/gnu/packages/gnuzilla.scm
index c3f464c15e..c2a1801c16 100644
--- a/gnu/packages/gnuzilla.scm
+++ b/gnu/packages/gnuzilla.scm
@@ -37,6 +37,7 @@
#:use-module (gnu packages libffi)
#:use-module (gnu packages python)
#:use-module (gnu packages xorg)
+ #:use-module (gnu packages gl)
#:use-module (gnu packages yasm)
#:use-module (gnu packages zip))
diff --git a/gnu/packages/iso-codes.scm b/gnu/packages/iso-codes.scm
index e1424b81ef..be0b746796 100644
--- a/gnu/packages/iso-codes.scm
+++ b/gnu/packages/iso-codes.scm
@@ -28,7 +28,7 @@
(define-public iso-codes
(package
(name "iso-codes")
- (version "3.47")
+ (version "3.49")
(source (origin
(method url-fetch)
(uri (string-append
@@ -36,7 +36,7 @@
version ".tar.xz"))
(sha256
(base32
- "1ka2rrnfwbydklpx9p1cw74z03v5h0df3pjplq5ic689jngcv6a8"))))
+ "1ryk5i467p7xxrbrqynb35ci046yj9k9b4d3hfxzass962lz9q04"))))
(build-system gnu-build-system)
(inputs
`(("gettext" ,gnu-gettext)
diff --git a/gnu/packages/lsh.scm b/gnu/packages/lsh.scm
index ac01a878bc..1c823492c5 100644
--- a/gnu/packages/lsh.scm
+++ b/gnu/packages/lsh.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -30,7 +30,7 @@
#:use-module (gnu packages multiprecision)
#:use-module (gnu packages readline)
#:use-module (gnu packages gperf)
- #:use-module (gnu packages base))
+ #:use-module (gnu packages guile))
(define-public liboop
(package
@@ -61,27 +61,45 @@ basis for almost any application.")
(package
(name "lsh")
(version "2.1")
- (source
- (origin
- (method url-fetch)
- (uri (string-append "mirror://gnu/lsh/lsh-"
- version ".tar.gz"))
- (sha256
- (base32
- "1qqjy9zfzgny0rkb27c8c7dfsylvb6n0ld8h3an2r83pmaqr9gwb"))))
+ (source (origin
+ (method url-fetch)
+ (uri (string-append "mirror://gnu/lsh/lsh-"
+ version ".tar.gz"))
+ (sha256
+ (base32
+ "1qqjy9zfzgny0rkb27c8c7dfsylvb6n0ld8h3an2r83pmaqr9gwb"))
+ (modules '((guix build utils)))
+ (snippet
+ '(begin
+ (use-modules (guix build utils))
+
+ (substitute* "src/testsuite/functions.sh"
+ (("localhost")
+ ;; Avoid host name lookups since they don't work in
+ ;; chroot builds.
+ "127.0.0.1")
+ (("set -e")
+ ;; Make tests more verbose.
+ "set -e\nset -x"))
+
+ (substitute* (find-files "src/testsuite" "-test$")
+ (("localhost") "127.0.0.1"))
+
+ (substitute* "src/testsuite/login-auth-test"
+ (("/bin/cat") "cat"))))))
(build-system gnu-build-system)
+ (native-inputs
+ `(("m4" ,m4)
+ ("guile" ,guile-2.0)
+ ("gperf" ,gperf)
+ ("psmisc" ,psmisc))) ; for `killall'
(inputs
`(("nettle" ,nettle)
("linux-pam" ,linux-pam)
- ("m4" ,m4)
("readline" ,readline)
("liboop" ,liboop)
("zlib" ,guix:zlib)
- ("gmp" ,gmp)
- ("guile" ,guile-final)
- ("gperf" ,gperf)
- ("psmisc" ,psmisc) ; for `killall'
- ))
+ ("gmp" ,gmp)))
(arguments
'(;; Skip the `configure' test that checks whether /dev/ptmx &
;; co. work as expected, because it relies on impurities (for
@@ -95,27 +113,19 @@ basis for almost any application.")
#:phases
(alist-cons-before
- 'configure 'fix-test-suite
- (lambda _
- ;; Tests rely on $USER being set.
- (setenv "USER" "guix")
+ 'configure 'pre-configure
+ (lambda* (#:key inputs #:allow-other-keys)
+ ;; Make sure 'lsh' and 'lshd' pick 'sexp-conv' in the right place by
+ ;; default.
+ (substitute* "src/environ.h.in"
+ (("^#define PATH_SEXP_CONV.*")
+ (let* ((nettle (assoc-ref inputs "nettle"))
+ (sexp-conv (string-append nettle "/bin/sexp-conv")))
+ (string-append "#define PATH_SEXP_CONV \""
+ sexp-conv "\"\n"))))
- (substitute* "src/testsuite/functions.sh"
- (("localhost")
- ;; Avoid host name lookups since they don't work in chroot
- ;; builds.
- "127.0.0.1")
- (("set -e")
- ;; Make tests more verbose.
- "set -e\nset -x"))
-
- (substitute* (find-files "src/testsuite" "-test$")
- (("localhost") "127.0.0.1"))
-
- (substitute* "src/testsuite/login-auth-test"
- (("/bin/cat")
- ;; Use the right path to `cat'.
- (which "cat"))))
+ ;; Tests rely on $USER being set.
+ (setenv "USER" "guix"))
%standard-phases)))
(home-page "http://www.lysator.liu.se/~nisse/lsh/")
(synopsis "GNU implementation of the Secure Shell (ssh) protocols")
diff --git a/gnu/packages/nettle.scm b/gnu/packages/nettle.scm
index 4e9b3dd7b7..96407837b4 100644
--- a/gnu/packages/nettle.scm
+++ b/gnu/packages/nettle.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -36,7 +36,13 @@
(base32
"0h2vap31yvi1a438d36lg1r1nllfx3y19r4rfxv7slrm6kafnwdw"))))
(build-system gnu-build-system)
- (inputs `(("m4" ,m4)))
+ (arguments
+ ;; 'sexp-conv' and other programs need to have their RUNPATH point to
+ ;; $libdir, which is not the case by default. Work around it.
+ '(#:configure-flags (list (string-append "LDFLAGS=-Wl,-rpath="
+ (assoc-ref %outputs "out")
+ "/lib"))))
+ (native-inputs `(("m4" ,m4)))
(propagated-inputs `(("gmp" ,gmp)))
(home-page "http://www.lysator.liu.se/~nisse/nettle/")
(synopsis "C library for low-level cryptographic functionality")
diff --git a/gnu/packages/parallel.scm b/gnu/packages/parallel.scm
index 83b45cc15f..9ce24a3cbf 100644
--- a/gnu/packages/parallel.scm
+++ b/gnu/packages/parallel.scm
@@ -27,7 +27,7 @@
(define-public parallel
(package
(name "parallel")
- (version "20131122")
+ (version "20131222")
(source
(origin
(method url-fetch)
@@ -35,7 +35,7 @@
version ".tar.bz2"))
(sha256
(base32
- "1l19grs8nimkninig4h0hfmnykm41j0amcvav6ic4wfd33v0lppg"))))
+ "08ggxb4id263623mr14clafsdl1n1zhfx13z3mn6kqbd4d6vwwk7"))))
(build-system gnu-build-system)
(inputs `(("perl" ,perl)))
(home-page "http://www.gnu.org/software/parallel/")
diff --git a/gnu/packages/patches/gtkglext-disable-disable-deprecated.patch b/gnu/packages/patches/gtkglext-disable-disable-deprecated.patch
new file mode 100644
index 0000000000..8f0c23c97f
--- /dev/null
+++ b/gnu/packages/patches/gtkglext-disable-disable-deprecated.patch
@@ -0,0 +1,36 @@
+Having DISABLE_DEPRECATED flags set in the distribution breaks
+building with libraries later than those which the maintainer
+happened to have installed. This patch removes them.
+
+diff -r -U 3 a/gtk/Makefile.am b/gtk/Makefile.am
+--- a/gtk/Makefile.am 2003-05-09 15:55:05.000000000 +0200
++++ b/gtk/Makefile.am 2013-12-26 15:06:38.000000000 +0100
+@@ -36,11 +36,7 @@
+ -I$(top_srcdir) \
+ -I$(top_builddir)/gdk \
+ $(GTKGLEXT_DEBUG_FLAGS) \
+- $(GTKGLEXT_DEP_CFLAGS) \
+- -DG_DISABLE_DEPRECATED \
+- -DGDK_DISABLE_DEPRECATED \
+- -DGDK_PIXBUF_DISABLE_DEPRECATED \
+- -DGTK_DISABLE_DEPRECATED
++ $(GTKGLEXT_DEP_CFLAGS)
+
+ common_ldflags = \
+ -version-info $(LT_CURRENT):$(LT_REVISION):$(LT_AGE) \
+diff -r -U 3 a/gtk/Makefile.in b/gtk/Makefile.in
+--- a/gtk/Makefile.in 2006-02-05 04:17:42.000000000 +0100
++++ b/gtk/Makefile.in 2013-12-26 15:07:00.000000000 +0100
+@@ -234,11 +234,7 @@
+ -I$(top_srcdir) \
+ -I$(top_builddir)/gdk \
+ $(GTKGLEXT_DEBUG_FLAGS) \
+- $(GTKGLEXT_DEP_CFLAGS) \
+- -DG_DISABLE_DEPRECATED \
+- -DGDK_DISABLE_DEPRECATED \
+- -DGDK_PIXBUF_DISABLE_DEPRECATED \
+- -DGTK_DISABLE_DEPRECATED
++ $(GTKGLEXT_DEP_CFLAGS)
+
+
+ common_ldflags = \
diff --git a/gnu/packages/patches/gtkglext-remove-pangox-dependency.patch b/gnu/packages/patches/gtkglext-remove-pangox-dependency.patch
new file mode 100644
index 0000000000..4f03785322
--- /dev/null
+++ b/gnu/packages/patches/gtkglext-remove-pangox-dependency.patch
@@ -0,0 +1,132 @@
+This patch removes the dependency on pangox which has been deprecated. It
+achieves the same result as the upstream patch at
+https://git.gnome.org/browse/gtkglext/commit/?id=df7a7b35b80b395d7ba411c7f727970a46fb0588
+Like the upstream patch, it removes the functions gdk_gl_font_use_pango_font,
+and gdk_gl_font_use_pango_font_for_display from the API.
+
+diff -r -U 3 a/configure b/configure
+--- a/configure 2006-02-05 04:17:47.000000000 +0100
++++ b/configure 2013-12-26 12:55:21.000000000 +0100
+@@ -19880,14 +19880,12 @@
+ gtk+-2.0 >= 2.0.0 \\
+ gdk-2.0 >= 2.0.0 \\
+ pango >= 1.0.0 \\
+-pangox >= 1.0.0 \\
+ gmodule-2.0 >= 2.0.0 \\
+ \"") >&5
+ ($PKG_CONFIG --exists --print-errors "\
+ gtk+-2.0 >= 2.0.0 \
+ gdk-2.0 >= 2.0.0 \
+ pango >= 1.0.0 \
+-pangox >= 1.0.0 \
+ gmodule-2.0 >= 2.0.0 \
+ ") 2>&5
+ ac_status=$?
+@@ -19897,7 +19895,6 @@
+ gtk+-2.0 >= 2.0.0 \
+ gdk-2.0 >= 2.0.0 \
+ pango >= 1.0.0 \
+-pangox >= 1.0.0 \
+ gmodule-2.0 >= 2.0.0 \
+ " 2>/dev/null`
+ else
+@@ -19916,14 +19913,12 @@
+ gtk+-2.0 >= 2.0.0 \\
+ gdk-2.0 >= 2.0.0 \\
+ pango >= 1.0.0 \\
+-pangox >= 1.0.0 \\
+ gmodule-2.0 >= 2.0.0 \\
+ \"") >&5
+ ($PKG_CONFIG --exists --print-errors "\
+ gtk+-2.0 >= 2.0.0 \
+ gdk-2.0 >= 2.0.0 \
+ pango >= 1.0.0 \
+-pangox >= 1.0.0 \
+ gmodule-2.0 >= 2.0.0 \
+ ") 2>&5
+ ac_status=$?
+@@ -19933,7 +19928,6 @@
+ gtk+-2.0 >= 2.0.0 \
+ gdk-2.0 >= 2.0.0 \
+ pango >= 1.0.0 \
+-pangox >= 1.0.0 \
+ gmodule-2.0 >= 2.0.0 \
+ " 2>/dev/null`
+ else
+@@ -19958,7 +19952,6 @@
+ gtk+-2.0 >= 2.0.0 \
+ gdk-2.0 >= 2.0.0 \
+ pango >= 1.0.0 \
+-pangox >= 1.0.0 \
+ gmodule-2.0 >= 2.0.0 \
+ "`
+ else
+@@ -19966,7 +19959,6 @@
+ gtk+-2.0 >= 2.0.0 \
+ gdk-2.0 >= 2.0.0 \
+ pango >= 1.0.0 \
+-pangox >= 1.0.0 \
+ gmodule-2.0 >= 2.0.0 \
+ "`
+ fi
+@@ -19977,7 +19969,6 @@
+ gtk+-2.0 >= 2.0.0 \
+ gdk-2.0 >= 2.0.0 \
+ pango >= 1.0.0 \
+-pangox >= 1.0.0 \
+ gmodule-2.0 >= 2.0.0 \
+ ) were not met:
+
+@@ -19994,7 +19985,6 @@
+ gtk+-2.0 >= 2.0.0 \
+ gdk-2.0 >= 2.0.0 \
+ pango >= 1.0.0 \
+-pangox >= 1.0.0 \
+ gmodule-2.0 >= 2.0.0 \
+ ) were not met:
+
+@@ -25420,7 +25410,7 @@
+ # CFLAGS and LIBS
+ ##################################################
+
+-GDKGLEXT_PACKAGES="gdk-2.0 pango pangox gmodule-2.0"
++GDKGLEXT_PACKAGES="gdk-2.0 pango gmodule-2.0"
+ GDKGLEXT_EXTRA_CFLAGS="$GL_CFLAGS $GDKGLEXT_WIN_CFLAGS"
+ GDKGLEXT_EXTRA_LIBS="$GL_LIBS $GDKGLEXT_WIN_LIBS"
+ GDKGLEXT_DEP_CFLAGS="$GDKGLEXT_EXTRA_CFLAGS `$PKG_CONFIG --cflags $GDKGLEXT_PACKAGES`"
+diff -r -U 3 a/gdk/x11/Makefile.in b/gdk/x11/Makefile.in
+--- a/gdk/x11/Makefile.in 2006-02-05 04:17:42.000000000 +0100
++++ b/gdk/x11/Makefile.in 2013-12-26 13:12:04.000000000 +0100
+@@ -257,7 +257,6 @@
+ gdkgldrawable-x11.c \
+ gdkglpixmap-x11.c \
+ gdkglwindow-x11.c \
+- gdkglfont-x11.c \
+ gdkglglxext.c
+
+
+@@ -288,7 +287,7 @@
+ am__objects_1 =
+ am__objects_2 = gdkglquery-x11.lo gdkglconfig-x11.lo gdkgloverlay-x11.lo \
+ gdkglcontext-x11.lo gdkgldrawable-x11.lo gdkglpixmap-x11.lo \
+- gdkglwindow-x11.lo gdkglfont-x11.lo gdkglglxext.lo
++ gdkglwindow-x11.lo gdkglglxext.lo
+ am__objects_3 = $(am__objects_1) $(am__objects_2)
+ am_libgdkglext_x11_la_OBJECTS = $(am__objects_3)
+ libgdkglext_x11_la_OBJECTS = $(am_libgdkglext_x11_la_OBJECTS)
+@@ -299,7 +298,6 @@
+ @AMDEP_TRUE@DEP_FILES = ./$(DEPDIR)/gdkglconfig-x11.Plo \
+ @AMDEP_TRUE@ ./$(DEPDIR)/gdkglcontext-x11.Plo \
+ @AMDEP_TRUE@ ./$(DEPDIR)/gdkgldrawable-x11.Plo \
+-@AMDEP_TRUE@ ./$(DEPDIR)/gdkglfont-x11.Plo \
+ @AMDEP_TRUE@ ./$(DEPDIR)/gdkglglxext.Plo \
+ @AMDEP_TRUE@ ./$(DEPDIR)/gdkgloverlay-x11.Plo \
+ @AMDEP_TRUE@ ./$(DEPDIR)/gdkglpixmap-x11.Plo \
+@@ -349,7 +347,6 @@
+ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gdkglconfig-x11.Plo@am__quote@
+ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gdkglcontext-x11.Plo@am__quote@
+ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gdkgldrawable-x11.Plo@am__quote@
+-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gdkglfont-x11.Plo@am__quote@
+ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gdkglglxext.Plo@am__quote@
+ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gdkgloverlay-x11.Plo@am__quote@
+ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gdkglpixmap-x11.Plo@am__quote@
diff --git a/gnu/packages/patches/pulseaudio-volume-test.patch b/gnu/packages/patches/pulseaudio-volume-test.patch
new file mode 100644
index 0000000000..2cfa0cd6ca
--- /dev/null
+++ b/gnu/packages/patches/pulseaudio-volume-test.patch
@@ -0,0 +1,29 @@
+Fix seemingly random failures of 'volume-test' in particular on 32-bit
+machines. See <https://bugs.freedesktop.org/show_bug.cgi?id=72374> for
+details.
+
+From 27e47c72a25846e107b6e450c3a1480a2742382e Mon Sep 17 00:00:00 2001
+From: Tanu Kaskinen <tanu.kaskinen@linux.intel.com>
+Date: Sat, 14 Dec 2013 07:21:22 +0000
+Subject: volume-test: Increase the allowed number of rouding errors
+
+BugLink: https://bugs.freedesktop.org/show_bug.cgi?id=72374
+---
+diff --git a/src/tests/volume-test.c b/src/tests/volume-test.c
+index a2daf3e..1ab0b5c 100644
+--- a/src/tests/volume-test.c
++++ b/src/tests/volume-test.c
+@@ -138,7 +138,13 @@ START_TEST (volume_test) {
+ pa_log("max deviation: %lu n=%lu", (unsigned long) md, (unsigned long) mdn);
+
+ fail_unless(md <= 1);
+- fail_unless(mdn <= 251);
++
++ /* mdn counts the times there were rounding errors during the test. The
++ * number of rounding errors seems to vary slightly depending on the
++ * hardware. The original limit was 251 errors, but it was increased to 253
++ * when the test was failing on Tanu's laptop.
++ * See https://bugs.freedesktop.org/show_bug.cgi?id=72374 */
++ fail_unless(mdn <= 253);
+ }
+ END_TEST
diff --git a/gnu/packages/pulseaudio.scm b/gnu/packages/pulseaudio.scm
index a2e8217422..91bbe2d77a 100644
--- a/gnu/packages/pulseaudio.scm
+++ b/gnu/packages/pulseaudio.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -143,7 +143,9 @@ parse JSON formatted strings back into the C representation of JSON objects.")
(sha256
(base32
"1bndz4l8jxyq3zq128gzp3gryxl6yjs66j2y1d7yabw2n5mv7kim"))
- (patches (list (search-patch "pulseaudio-test-timeouts.patch")))))
+ (patches (map search-patch
+ '("pulseaudio-test-timeouts.patch"
+ "pulseaudio-volume-test.patch")))))
(build-system gnu-build-system)
(arguments
`(#:configure-flags '("--localstatedir=/var" ;"--sysconfdir=/etc"
@@ -154,14 +156,7 @@ parse JSON formatted strings back into the C representation of JSON objects.")
;; 'tests/lock-autospawn-test.c' wants to create a file
;; under ~/.config/pulse.
(setenv "HOME" (getcwd)))
- %standard-phases)
-
- ,@(if (or (string=? (%current-system) "i686-linux")
- (string=? (%current-system) "mips64el-linux"))
- ;; Work around test failure:
- ;; <https://bugs.freedesktop.org/show_bug.cgi?id=72374>.
- '(#:tests? #f)
- '())))
+ %standard-phases)))
(inputs
;; TODO: Add optional inputs (GTK+?).
`(;; ("sbc" ,sbc)
diff --git a/gnu/packages/python.scm b/gnu/packages/python.scm
index faf2c9d527..b5070e7fda 100644
--- a/gnu/packages/python.scm
+++ b/gnu/packages/python.scm
@@ -41,7 +41,7 @@
(define-public python-2
(package
(name "python")
- (version "2.7.5")
+ (version "2.7.6")
(source
(origin
(method url-fetch)
@@ -49,7 +49,7 @@
version "/Python-" version ".tar.xz"))
(sha256
(base32
- "1c8xan2dlsqfq8q82r3mhl72v3knq3qyn71fjq89xikx2smlqg7k"))))
+ "18gnpyh071dxa0rv3silrz92jw9qpblswzwv4gzqcwxzz20qxmhz"))))
(build-system gnu-build-system)
(arguments
`(#:tests? #f
@@ -160,7 +160,7 @@ data types.")
(define-public python
(package (inherit python-2)
- (version "3.3.2")
+ (version "3.3.3")
(source
(origin
(method url-fetch)
@@ -168,7 +168,7 @@ data types.")
version "/Python-" version ".tar.xz"))
(sha256
(base32
- "0hsbwqjnhr85a2w252c8d3yj8d9i5sy8s6a6cfk6zqqhp3234nvl"))))
+ "11f6hg9wdhm6hyzj49gxlvvp1s0l5hqgcsq1i4ayygqs1arpb4ik"))))
(native-search-paths
(list (search-path-specification
(variable "PYTHONPATH")
diff --git a/gnu/packages/qemu.scm b/gnu/packages/qemu.scm
index 0d7923ba0f..4212d74821 100644
--- a/gnu/packages/qemu.scm
+++ b/gnu/packages/qemu.scm
@@ -36,6 +36,7 @@
#:use-module (gnu packages linux)
#:use-module (gnu packages samba)
#:use-module (gnu packages xorg)
+ #:use-module (gnu packages gl)
#:use-module (gnu packages sdl)
#:use-module (gnu packages perl))
diff --git a/gnu/packages/qt.scm b/gnu/packages/qt.scm
index e40ae81aaa..f22fbe6f9e 100644
--- a/gnu/packages/qt.scm
+++ b/gnu/packages/qt.scm
@@ -37,6 +37,7 @@
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages pulseaudio)
#:use-module (gnu packages python)
+ #:use-module (gnu packages gl)
#:use-module (gnu packages xorg))
(define-public libxkbcommon
diff --git a/gnu/packages/sdl.scm b/gnu/packages/sdl.scm
index fa1b5da4eb..86b403503b 100644
--- a/gnu/packages/sdl.scm
+++ b/gnu/packages/sdl.scm
@@ -31,6 +31,7 @@
#:use-module (gnu packages oggvorbis)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages pulseaudio)
+ #:use-module (gnu packages gl)
#:use-module (gnu packages xorg)
#:export (sdl
sdl2
diff --git a/gnu/packages/shishi.scm b/gnu/packages/shishi.scm
index 2f5fa8a37c..0523a4eef5 100644
--- a/gnu/packages/shishi.scm
+++ b/gnu/packages/shishi.scm
@@ -43,7 +43,15 @@
(inputs
`(("gnutls" ,gnutls)
("zlib" ,zlib)
- ("libgcrypt" ,libgcrypt)
+ ;; libgcrypt 1.6 fails because of the following test:
+ ;; #include <gcrypt.h>
+ ;; /* GCRY_MODULE_ID_USER was added in 1.4.4 and gc-libgcrypt.c
+ ;; will fail on startup if we don't have 1.4.4 or later, so
+ ;; test for it early. */
+ ;; #if !defined GCRY_MODULE_ID_USER
+ ;; error too old libgcrypt
+ ;; #endif
+ ("libgcrypt" ,libgcrypt-1.5)
("libtasn1" ,libtasn1)))
(home-page "http://www.gnu.org/software/shishi/")
(synopsis "Implementation of the Kerberos 5 network security system")
diff --git a/gnu/packages/ssh.scm b/gnu/packages/ssh.scm
index 76d51c44c6..2197388902 100644
--- a/gnu/packages/ssh.scm
+++ b/gnu/packages/ssh.scm
@@ -36,20 +36,20 @@
(define-public libssh
(package
(name "libssh")
- (version "0.5.3")
+ (version "0.5.5")
(source (origin
(method url-fetch)
- (uri (string-append "http://www.libssh.org/files/0.5/libssh-"
+ (uri (string-append "https://red.libssh.org/attachments/download/51/libssh-"
version ".tar.gz"))
(sha256
(base32
- "1w6s217vjq0w3v5i0c5ql6m0ki1yz05g9snah3azxfkl9k4schpd"))))
+ "17cfdff4hc0ijzrr15biq29fiabafz0bw621zlkbwbc1zh2hzpy0"))))
(build-system cmake-build-system)
(arguments
'(#:configure-flags '("-DWITH_GCRYPT=ON"
- ;; Leave a valid RUNPATH upon install.
- "-DCMAKE_SKIP_BUILD_RPATH=ON")
+ ;; Leave a valid RUNPATH upon install.
+ "-DCMAKE_SKIP_BUILD_RPATH=ON")
;; TODO: Add 'CMockery' and '-DWITH_TESTING=ON' for the test suite.
#:tests? #f
@@ -80,7 +80,10 @@
lib))))
%standard-phases)))
(inputs `(("zlib" ,zlib)
- ("libgcrypt" ,libgcrypt)))
+ ;; Link against an older gcrypt, because libssh tries to access
+ ;; fields of 'gcry_thread_cbs' that are now private:
+ ;; src/threads.c:72:26: error: 'struct gcry_thread_cbs' has no member named 'mutex_init'
+ ("libgcrypt", libgcrypt-1.5)))
(native-inputs `(("patchelf" ,patchelf)))
(synopsis "SSH client library")
(description
diff --git a/gnu/packages/vim.scm b/gnu/packages/vim.scm
index a80f50a4a6..0b532ae4e2 100644
--- a/gnu/packages/vim.scm
+++ b/gnu/packages/vim.scm
@@ -31,14 +31,14 @@
(define-public vim
(package
(name "vim")
- (version "7.3")
+ (version "7.4")
(source (origin
(method url-fetch)
(uri (string-append "ftp://ftp.vim.org/pub/vim/unix/vim-"
version ".tar.bz2"))
(sha256
(base32
- "079201qk8g9yisrrb0dn52ch96z3lzw6z473dydw9fzi0xp5spaw"))))
+ "1pjaffap91l2rb9pjnlbrpvb3ay5yhhr3g91zabjvw1rqk9adxfh"))))
(build-system gnu-build-system)
(arguments
`(#:test-target "test"
diff --git a/gnu/packages/xorg.scm b/gnu/packages/xorg.scm
index acc9fe61eb..dfdd82c8b8 100644
--- a/gnu/packages/xorg.scm
+++ b/gnu/packages/xorg.scm
@@ -28,6 +28,7 @@
#:use-module (gnu packages flex)
#:use-module (gnu packages fontutils)
#:use-module (gnu packages gettext)
+ #:use-module (gnu packages gl)
#:use-module (gnu packages glib)
#:use-module (gnu packages gnupg)
#:use-module (gnu packages gperf)
@@ -2969,7 +2970,8 @@ tracking.")
"0isiwx516gww8hfk3vy7js83yziyjym9mq2zjadyq1a8v5gqf9y8"))))
(build-system gnu-build-system)
(inputs `(("libx11" ,libx11)
- ("libxext" ,libxext)))
+ ("libxext" ,libxext)
+ ("xorg-server" ,xorg-server)))
(native-inputs
`(("pkg-config" ,pkg-config)))
(home-page "http://www.x.org/wiki/")
@@ -4266,64 +4268,6 @@ tracking.")
(license license:x11)))
-;; package outside the x.org system proper of height 3
-
-(define-public mesa
- (package
- (name "mesa")
- ;; In newer versions (9.0.5, 9.1 and 9.2 tested), "make" results in an
- ;; infinite configure loop, see
- ;; https://bugs.freedesktop.org/show_bug.cgi?id=58812
- (version "8.0.5")
- (source
- (origin
- (method url-fetch)
- (uri (string-append
- "ftp://ftp.freedesktop.org/pub/mesa/older-versions/8.x/"
- version
- "/MesaLib-" version
- ".tar.bz2"))
- (sha256
- (base32
- "0pjs8x51c0i6mawgd4w03lxpyx5fnx7rc8plr8jfsscf9yiqs6si"))))
- (build-system gnu-build-system)
- (propagated-inputs
- `(("glproto" ,glproto)
- ("libdrm" ,libdrm-2.4.33)
- ("libxdamage" ,libxdamage)
- ("libxxf86vm" ,libxxf86vm)))
- (inputs
- `(("dri2proto" ,dri2proto)
- ("expat" ,expat)
- ("libx11" ,libx11)
- ("libxfixes" ,libxfixes)
- ("libxml2" ,libxml2)
- ("makedepend" ,makedepend)))
- (native-inputs
- `(("pkg-config" ,pkg-config)
- ("flex" ,flex)
- ("bison" ,bison)
- ("python" ,python-2))) ; incompatible with Python 3 (print syntax)
- (arguments
- `(#:configure-flags
- `("--with-gallium-drivers=r600,svga,swrast") ; drop r300 from the default list as it requires llvm
- #:phases
- (alist-cons-after
- 'unpack 'remove-symlink
- (lambda* (#:key #:allow-other-keys)
- ;; remove dangling symlink to /usr/include/wine/windows
- (delete-file "src/gallium/state_trackers/d3d1x/w32api"))
- %standard-phases)))
- (home-page "http://mesa3d.org/")
- (synopsis "Mesa, an OpenGL implementation")
- (description "Mesa is a free implementation of the OpenGL specification -
-a system for rendering interactive 3D graphics. A variety of device drivers
-allows Mesa to be used in many different environments ranging from software
-emulation to complete hardware acceleration for modern GPUs.")
- (license license:x11)))
-
-
-
;; packages of height 3 in the propagated-inputs tree
(define-public libxcb
diff --git a/guix/config.scm.in b/guix/config.scm.in
index 772ea8c289..3a5c50e00a 100644
--- a/guix/config.scm.in
+++ b/guix/config.scm.in
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -23,6 +23,7 @@
%guix-home-page-url
%store-directory
%state-directory
+ %config-directory
%system
%libgcrypt
%nixpkgs
@@ -50,11 +51,16 @@
"@PACKAGE_URL@")
(define %store-directory
- "@storedir@")
+ (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path)
+ "@storedir@"))
(define %state-directory
;; This must match `NIX_STATE_DIR' as defined in `daemon.am'.
- "@guix_localstatedir@/nix")
+ (or (getenv "NIX_STATE_DIR") "@guix_localstatedir@/nix"))
+
+(define %config-directory
+ ;; This must match `NIX_CONF_DIR' as defined in `daemon.am'.
+ (or (getenv "NIX_CONF_DIR") "@guix_sysconfdir@/guix"))
(define %system
"@guix_system@")
diff --git a/guix/pk-crypto.scm b/guix/pk-crypto.scm
new file mode 100644
index 0000000000..50f709418c
--- /dev/null
+++ b/guix/pk-crypto.scm
@@ -0,0 +1,372 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(define-module (guix pk-crypto)
+ #:use-module (guix config)
+ #:use-module ((guix utils)
+ #:select (bytevector->base16-string
+ base16-string->bytevector))
+ #:use-module (system foreign)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 match)
+ #:export (canonical-sexp?
+ error-source
+ error-string
+ string->canonical-sexp
+ canonical-sexp->string
+ number->canonical-sexp
+ canonical-sexp-car
+ canonical-sexp-cdr
+ canonical-sexp-nth
+ canonical-sexp-nth-data
+ canonical-sexp-length
+ canonical-sexp-null?
+ canonical-sexp-list?
+ bytevector->hash-data
+ hash-data->bytevector
+ sign
+ verify
+ generate-key
+ find-sexp-token
+ canonical-sexp->sexp
+ sexp->canonical-sexp))
+
+
+;;; Commentary:
+;;;
+;;; Public key cryptographic routines from GNU Libgcrypt.
+;;;;
+;;; Libgcrypt uses "canonical s-expressions" to represent key material,
+;;; parameters, and data. We keep it as an opaque object to map them to
+;;; Scheme s-expressions because (1) Libgcrypt sexps may be stored in secure
+;;; memory, and (2) the read syntax is different.
+;;;
+;;; A 'canonical-sexp->sexp' procedure is provided nevertheless, for use in
+;;; cases where it is safe to move data out of Libgcrypt---e.g., when
+;;; processing ACL entries, public keys, etc.
+;;;
+;;; Canonical sexps were defined by Rivest et al. in the IETF draft at
+;;; <http://people.csail.mit.edu/rivest/Sexp.txt> for the purposes of SPKI
+;;; (see <http://www.ietf.org/rfc/rfc2693.txt>.)
+;;;
+;;; Code:
+
+;; Libgcrypt "s-expressions".
+(define-wrapped-pointer-type <canonical-sexp>
+ canonical-sexp?
+ naked-pointer->canonical-sexp
+ canonical-sexp->pointer
+ (lambda (obj port)
+ ;; Don't print OBJ's external representation: we don't want key material
+ ;; to leak in backtraces and such.
+ (format port "#<canonical-sexp ~a | ~a>"
+ (number->string (object-address obj) 16)
+ (number->string (pointer-address (canonical-sexp->pointer obj))
+ 16))))
+
+(define libgcrypt-func
+ (let ((lib (dynamic-link %libgcrypt)))
+ (lambda (func)
+ "Return a pointer to symbol FUNC in libgcrypt."
+ (dynamic-func func lib))))
+
+(define finalize-canonical-sexp!
+ (libgcrypt-func "gcry_sexp_release"))
+
+(define-inlinable (pointer->canonical-sexp ptr)
+ "Return a <canonical-sexp> that wraps PTR."
+ (let* ((sexp (naked-pointer->canonical-sexp ptr))
+ (ptr* (canonical-sexp->pointer sexp)))
+ ;; Did we already have a <canonical-sexp> object for PTR?
+ (when (equal? ptr ptr*)
+ ;; No, so we can safely add a finalizer (in Guile 2.0.9
+ ;; 'set-pointer-finalizer!' *adds* a finalizer rather than replacing the
+ ;; existing one.)
+ (set-pointer-finalizer! ptr finalize-canonical-sexp!))
+ sexp))
+
+(define error-source
+ (let* ((ptr (libgcrypt-func "gcry_strsource"))
+ (proc (pointer->procedure '* ptr (list int))))
+ (lambda (err)
+ "Return the error source (a string) for ERR, an error code as thrown
+along with 'gcry-error'."
+ (pointer->string (proc err)))))
+
+(define error-string
+ (let* ((ptr (libgcrypt-func "gcry_strerror"))
+ (proc (pointer->procedure '* ptr (list int))))
+ (lambda (err)
+ "Return the error description (a string) for ERR, an error code as
+thrown along with 'gcry-error'."
+ (pointer->string (proc err)))))
+
+(define string->canonical-sexp
+ (let* ((ptr (libgcrypt-func "gcry_sexp_new"))
+ (proc (pointer->procedure int ptr `(* * ,size_t ,int))))
+ (lambda (str)
+ "Parse STR and return the corresponding gcrypt s-expression."
+ (let* ((sexp (bytevector->pointer (make-bytevector (sizeof '*))))
+ (err (proc sexp (string->pointer str) 0 1)))
+ (if (= 0 err)
+ (pointer->canonical-sexp (dereference-pointer sexp))
+ (throw 'gcry-error err))))))
+
+(define-syntax GCRYSEXP_FMT_ADVANCED
+ (identifier-syntax 3))
+
+(define canonical-sexp->string
+ (let* ((ptr (libgcrypt-func "gcry_sexp_sprint"))
+ (proc (pointer->procedure size_t ptr `(* ,int * ,size_t))))
+ (lambda (sexp)
+ "Return a textual representation of SEXP."
+ (let loop ((len 1024))
+ (let* ((buf (bytevector->pointer (make-bytevector len)))
+ (size (proc (canonical-sexp->pointer sexp)
+ GCRYSEXP_FMT_ADVANCED buf len)))
+ (if (zero? size)
+ (loop (* len 2))
+ (pointer->string buf size "ISO-8859-1")))))))
+
+(define canonical-sexp-car
+ (let* ((ptr (libgcrypt-func "gcry_sexp_car"))
+ (proc (pointer->procedure '* ptr '(*))))
+ (lambda (lst)
+ "Return the first element of LST, an sexp, if that element is a list;
+return #f if LST or its first element is not a list (this is different from
+the usual Lisp 'car'.)"
+ (let ((result (proc (canonical-sexp->pointer lst))))
+ (if (null-pointer? result)
+ #f
+ (pointer->canonical-sexp result))))))
+
+(define canonical-sexp-cdr
+ (let* ((ptr (libgcrypt-func "gcry_sexp_cdr"))
+ (proc (pointer->procedure '* ptr '(*))))
+ (lambda (lst)
+ "Return the tail of LST, an sexp, or #f if LST is not a list."
+ (let ((result (proc (canonical-sexp->pointer lst))))
+ (if (null-pointer? result)
+ #f
+ (pointer->canonical-sexp result))))))
+
+(define canonical-sexp-nth
+ (let* ((ptr (libgcrypt-func "gcry_sexp_nth"))
+ (proc (pointer->procedure '* ptr `(* ,int))))
+ (lambda (lst index)
+ "Return the INDEXth nested element of LST, an s-expression. Return #f
+if that element does not exist, or if it's an atom. (Note: this is obviously
+different from Scheme's 'list-ref'.)"
+ (let ((result (proc (canonical-sexp->pointer lst) index)))
+ (if (null-pointer? result)
+ #f
+ (pointer->canonical-sexp result))))))
+
+(define (dereference-size_t p)
+ "Return the size_t value pointed to by P."
+ (bytevector-uint-ref (pointer->bytevector p (sizeof size_t))
+ 0 (native-endianness)
+ (sizeof size_t)))
+
+(define canonical-sexp-length
+ (let* ((ptr (libgcrypt-func "gcry_sexp_length"))
+ (proc (pointer->procedure int ptr '(*))))
+ (lambda (sexp)
+ "Return the length of SEXP if it's a list (including the empty list);
+return zero if SEXP is an atom."
+ (proc (canonical-sexp->pointer sexp)))))
+
+(define token-string?
+ (let ((token-cs (char-set-union char-set:digit
+ char-set:letter
+ (char-set #\- #\. #\/ #\_
+ #\: #\* #\+ #\=))))
+ (lambda (str)
+ "Return #t if STR is a token as per Section 4.3 of
+<http://people.csail.mit.edu/rivest/Sexp.txt>."
+ (and (not (string-null? str))
+ (string-every token-cs str)
+ (not (char-set-contains? char-set:digit (string-ref str 0)))))))
+
+(define canonical-sexp-nth-data
+ (let* ((ptr (libgcrypt-func "gcry_sexp_nth_data"))
+ (proc (pointer->procedure '* ptr `(* ,int *))))
+ (lambda (lst index)
+ "Return as a symbol (for \"sexp tokens\") or a bytevector (for any other
+\"octet string\") the INDEXth data element (atom) of LST, an s-expression.
+Return #f if that element does not exist, or if it's a list."
+ (let* ((size* (bytevector->pointer (make-bytevector (sizeof '*))))
+ (result (proc (canonical-sexp->pointer lst) index size*)))
+ (if (null-pointer? result)
+ #f
+ (let* ((len (dereference-size_t size*))
+ (str (pointer->string result len "ISO-8859-1")))
+ ;; The sexp spec speaks of "tokens" and "octet strings".
+ ;; Sometimes these octet strings are actual strings (text),
+ ;; sometimes they're bytevectors, and sometimes they're
+ ;; multi-precision integers (MPIs). Only the application knows.
+ ;; However, for convenience, we return a symbol when a token is
+ ;; encountered since tokens are frequent (at least in the 'car'
+ ;; of each sexp.)
+ (if (token-string? str)
+ (string->symbol str) ; an sexp "token"
+ (bytevector-copy ; application data, textual or binary
+ (pointer->bytevector result len)))))))))
+
+(define (number->canonical-sexp number)
+ "Return an s-expression representing NUMBER."
+ (string->canonical-sexp (string-append "#" (number->string number 16) "#")))
+
+(define* (bytevector->hash-data bv #:optional (hash-algo "sha256"))
+ "Given BV, a bytevector containing a hash, return an s-expression suitable
+for use as the data for 'sign'."
+ (string->canonical-sexp
+ (format #f "(data (flags pkcs1) (hash \"~a\" #~a#))"
+ hash-algo
+ (bytevector->base16-string bv))))
+
+(define (hash-data->bytevector data)
+ "Return two values: the hash value (a bytevector), and the hash algorithm (a
+string) extracted from DATA, an sexp as returned by 'bytevector->hash-data'.
+Return #f if DATA does not conform."
+ (let ((hash (find-sexp-token data 'hash)))
+ (if hash
+ (let ((algo (canonical-sexp-nth-data hash 1))
+ (value (canonical-sexp-nth-data hash 2)))
+ (values value (symbol->string algo)))
+ (values #f #f))))
+
+(define sign
+ (let* ((ptr (libgcrypt-func "gcry_pk_sign"))
+ (proc (pointer->procedure int ptr '(* * *))))
+ (lambda (data secret-key)
+ "Sign DATA (an s-expression) with SECRET-KEY (an s-expression whose car
+is 'private-key'.)"
+ (let* ((sig (bytevector->pointer (make-bytevector (sizeof '*))))
+ (err (proc sig (canonical-sexp->pointer data)
+ (canonical-sexp->pointer secret-key))))
+ (if (= 0 err)
+ (pointer->canonical-sexp (dereference-pointer sig))
+ (throw 'gry-error err))))))
+
+(define verify
+ (let* ((ptr (libgcrypt-func "gcry_pk_verify"))
+ (proc (pointer->procedure int ptr '(* * *))))
+ (lambda (signature data public-key)
+ "Verify that SIGNATURE is a signature of DATA with PUBLIC-KEY, all of
+which are gcrypt s-expressions."
+ (zero? (proc (canonical-sexp->pointer signature)
+ (canonical-sexp->pointer data)
+ (canonical-sexp->pointer public-key))))))
+
+(define generate-key
+ (let* ((ptr (libgcrypt-func "gcry_pk_genkey"))
+ (proc (pointer->procedure int ptr '(* *))))
+ (lambda (params)
+ "Return as an s-expression a new key pair for PARAMS. PARAMS must be an
+s-expression like: (genkey (rsa (nbits 4:2048)))."
+ (let* ((key (bytevector->pointer (make-bytevector (sizeof '*))))
+ (err (proc key (canonical-sexp->pointer params))))
+ (if (zero? err)
+ (pointer->canonical-sexp (dereference-pointer key))
+ (throw 'gcry-error err))))))
+
+(define find-sexp-token
+ (let* ((ptr (libgcrypt-func "gcry_sexp_find_token"))
+ (proc (pointer->procedure '* ptr `(* * ,size_t))))
+ (lambda (sexp token)
+ "Find in SEXP the first element whose 'car' is TOKEN and return it;
+return #f if not found."
+ (let* ((token (string->pointer (symbol->string token)))
+ (res (proc (canonical-sexp->pointer sexp) token 0)))
+ (if (null-pointer? res)
+ #f
+ (pointer->canonical-sexp res))))))
+
+(define-inlinable (canonical-sexp-null? sexp)
+ "Return #t if SEXP is the empty-list sexp."
+ (null-pointer? (canonical-sexp->pointer sexp)))
+
+(define (canonical-sexp-list? sexp)
+ "Return #t if SEXP is a list."
+ (or (canonical-sexp-null? sexp)
+ (> (canonical-sexp-length sexp) 0)))
+
+(define (canonical-sexp-fold proc seed sexp)
+ "Fold PROC (as per SRFI-1) over SEXP, a canonical sexp."
+ (if (canonical-sexp-list? sexp)
+ (let ((len (canonical-sexp-length sexp)))
+ (let loop ((index 0)
+ (result seed))
+ (if (= index len)
+ result
+ (loop (+ 1 index)
+ ;; XXX: Call 'nth-data' *before* 'nth' to work around
+ ;; <https://bugs.g10code.com/gnupg/issue1594>, which
+ ;; affects 1.6.0 and earlier versions.
+ (proc (or (canonical-sexp-nth-data sexp index)
+ (canonical-sexp-nth sexp index))
+ result)))))
+ (error "sexp is not a list" sexp)))
+
+(define (canonical-sexp->sexp sexp)
+ "Return a Scheme sexp corresponding to SEXP. This is particularly useful to
+compare sexps (since Libgcrypt does not provide an 'equal?' procedure), or to
+use pattern matching."
+ (if (canonical-sexp-list? sexp)
+ (reverse
+ (canonical-sexp-fold (lambda (item result)
+ (cons (if (canonical-sexp? item)
+ (canonical-sexp->sexp item)
+ item)
+ result))
+ '()
+ sexp))
+
+ ;; As of Libgcrypt 1.6.0, there's no function to extract the buffer of a
+ ;; non-list sexp (!), so we first enlist SEXP, then get at its buffer.
+ (let ((sexp (string->canonical-sexp
+ (string-append "(" (canonical-sexp->string sexp)
+ ")"))))
+ (or (canonical-sexp-nth-data sexp 0)
+ (canonical-sexp-nth sexp 0)))))
+
+(define (sexp->canonical-sexp sexp)
+ "Return a canonical sexp equivalent to SEXP, a Scheme sexp as returned by
+'canonical-sexp->sexp'."
+ ;; XXX: This is inefficient, but the Libgcrypt API doesn't allow us to do
+ ;; much better.
+ (string->canonical-sexp
+ (call-with-output-string
+ (lambda (port)
+ (define (write item)
+ (cond ((list? item)
+ (display "(" port)
+ (for-each write item)
+ (display ")" port))
+ ((symbol? item)
+ (format port " ~a" item))
+ ((bytevector? item)
+ (format port " #~a#"
+ (bytevector->base16-string item)))
+ (else
+ (error "unsupported sexp item type" item))))
+
+ (write sexp)))))
+
+;;; pk-crypto.scm ends here
diff --git a/guix/pki.scm b/guix/pki.scm
new file mode 100644
index 0000000000..5e4dbadd35
--- /dev/null
+++ b/guix/pki.scm
@@ -0,0 +1,139 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(define-module (guix pki)
+ #:use-module (guix config)
+ #:use-module (guix pk-crypto)
+ #:use-module ((guix utils) #:select (with-atomic-file-output))
+ #:use-module ((guix build utils) #:select (mkdir-p))
+ #:use-module (ice-9 match)
+ #:use-module (rnrs io ports)
+ #:export (%public-key-file
+ %private-key-file
+ %acl-file
+ current-acl
+ public-keys->acl
+ acl->public-keys
+ signature-sexp
+ authorized-key?))
+
+;;; Commentary:
+;;;
+;;; Public key infrastructure for the authentication and authorization of
+;;; archive imports. This is essentially a subset of SPKI for our own
+;;; purposes (see <http://theworld.com/~cme/spki.txt> and
+;;; <http://www.ietf.org/rfc/rfc2693.txt>.)
+;;;
+;;; Code:
+
+(define (acl-entry-sexp public-key)
+ "Return a SPKI-style ACL entry sexp for PUBLIC-KEY, authorizing imports
+signed by the corresponding secret key (see the IETF draft at
+<http://theworld.com/~cme/spki.txt> for the ACL format.)"
+ ;; Note: We always use PUBLIC-KEY to designate the subject. Someday we may
+ ;; want to have name certificates and to use subject names instead of
+ ;; complete keys.
+ (string->canonical-sexp
+ (format #f
+ "(entry ~a (tag (guix import)))"
+ (canonical-sexp->string public-key))))
+
+(define (acl-sexp entries)
+ "Return an ACL sexp from ENTRIES, a list of 'entry' sexps."
+ (string->canonical-sexp
+ (string-append "(acl "
+ (string-join (map canonical-sexp->string entries))
+ ")")))
+
+(define (public-keys->acl keys)
+ "Return an ACL canonical sexp that lists all of KEYS with a '(guix import)'
+tag---meaning that all of KEYS are authorized for archive imports. Each
+element in KEYS must be a canonical sexp with type 'public-key'."
+ (acl-sexp (map acl-entry-sexp keys)))
+
+(define %acl-file
+ (string-append %config-directory "/acl"))
+
+(define %public-key-file
+ (string-append %config-directory "/signing-key.pub"))
+
+(define %private-key-file
+ (string-append %config-directory "/signing-key.sec"))
+
+(define (ensure-acl)
+ "Make sure the ACL file exists, and create an initialized one if needed."
+ (unless (file-exists? %acl-file)
+ ;; If there's no public key file, don't attempt to create the ACL.
+ (when (file-exists? %public-key-file)
+ (let ((public-key (call-with-input-file %public-key-file
+ (compose string->canonical-sexp
+ get-string-all))))
+ (mkdir-p (dirname %acl-file))
+ (with-atomic-file-output %acl-file
+ (lambda (port)
+ (display (canonical-sexp->string
+ (public-keys->acl (list public-key)))
+ port)))))))
+
+(define (current-acl)
+ "Return the current ACL as a canonical sexp."
+ (ensure-acl)
+ (if (file-exists? %acl-file)
+ (call-with-input-file %acl-file
+ (compose string->canonical-sexp
+ get-string-all))
+ (public-keys->acl '()))) ; the empty ACL
+
+(define (acl->public-keys acl)
+ "Return the public keys (as canonical sexps) listed in ACL with the '(guix
+import)' tag."
+ (match (canonical-sexp->sexp acl)
+ (('acl
+ ('entry subject-keys
+ ('tag ('guix 'import)))
+ ...)
+ (map sexp->canonical-sexp subject-keys))
+ (_
+ (error "invalid access-control list" acl))))
+
+(define* (authorized-key? key
+ #:optional (acl (current-acl)))
+ "Return #t if KEY (a canonical sexp) is an authorized public key for archive
+imports according to ACL."
+ (let ((key (canonical-sexp->sexp key)))
+ (match (canonical-sexp->sexp acl)
+ (('acl
+ ('entry subject-keys
+ ('tag ('guix 'import)))
+ ...)
+ (not (not (member key subject-keys))))
+ (_
+ (error "invalid access-control list" acl)))))
+
+(define (signature-sexp data secret-key public-key)
+ "Return a SPKI-style sexp for the signature of DATA with SECRET-KEY that
+includes DATA, the actual signature value (with a 'sig-val' tag), and
+PUBLIC-KEY (see <http://theworld.com/~cme/spki.txt> for examples.)"
+ (string->canonical-sexp
+ (format #f
+ "(signature ~a ~a ~a)"
+ (canonical-sexp->string data)
+ (canonical-sexp->string (sign data secret-key))
+ (canonical-sexp->string public-key))))
+
+;;; pki.scm ends here
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
new file mode 100644
index 0000000000..32690c6b45
--- /dev/null
+++ b/guix/scripts/archive.scm
@@ -0,0 +1,337 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(define-module (guix scripts archive)
+ #:use-module (guix config)
+ #:use-module (guix utils)
+ #:use-module ((guix build utils) #:select (mkdir-p))
+ #:use-module (guix store)
+ #:use-module (guix packages)
+ #:use-module (guix derivations)
+ #:use-module (guix ui)
+ #:use-module (guix pki)
+ #:use-module (guix pk-crypto)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 rdelim)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-37)
+ #:use-module (guix scripts build)
+ #:use-module (guix scripts package)
+ #:use-module (rnrs io ports)
+ #:export (guix-archive))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+ ;; Alist of default option values.
+ `((system . ,(%current-system))
+ (substitutes? . #t)
+ (max-silent-time . 3600)
+ (verbosity . 0)))
+
+(define (show-help)
+ (display (_ "Usage: guix archive [OPTION]... PACKAGE...
+Export/import one or more packages from/to the store.\n"))
+ (display (_ "
+ --export export the specified files/packages to stdout"))
+ (display (_ "
+ --import import from the archive passed on stdin"))
+ (display (_ "
+ --missing print the files from stdin that are missing"))
+ (newline)
+ (display (_ "
+ --generate-key[=PARAMETERS]
+ generate a key pair with the given parameters"))
+ (display (_ "
+ -e, --expression=EXPR build the package or derivation 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 (_ "
+ --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\""))
+ (display (_ "
+ -n, --dry-run do not build the derivations"))
+ (display (_ "
+ --fallback fall back to building when the substituter fails"))
+ (display (_ "
+ --no-substitutes build instead of resorting to pre-built substitutes"))
+ (display (_ "
+ --max-silent-time=SECONDS
+ mark the build as failed after SECONDS of silence"))
+ (display (_ "
+ -c, --cores=N allow the use of up to N CPU cores for the build"))
+ (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 '("export") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'export #t result)))
+ (option '("import") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'import #t result)))
+ (option '("missing") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'missing #t result)))
+ (option '("generate-key") #f #t
+ (lambda (opt name arg result)
+ (catch 'gcry-error
+ (lambda ()
+ (let ((params
+ (string->canonical-sexp
+ (or arg "(genkey (rsa (nbits 4:4096)))"))))
+ (alist-cons 'generate-key params result)))
+ (lambda args
+ (leave (_ "invalid key generation parameters: ~s~%")
+ arg)))))
+ (option '("authorize") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'authorize #t result)))
+
+ (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 '("target") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'target arg
+ (alist-delete 'target result eq?))))
+ (option '(#\e "expression") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'expression arg 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 '("fallback") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'fallback? #t
+ (alist-delete 'fallback? result))))
+ (option '("no-substitutes") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'substitutes? #f
+ (alist-delete 'substitutes? result))))
+ (option '("max-silent-time") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'max-silent-time (string->number* arg)
+ 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)))))))
+
+(define (options->derivations+files store opts)
+ "Given OPTS, the result of 'args-fold', return a list of derivations to
+build and a list of store files to transfer."
+ (define package->derivation
+ (match (assoc-ref opts 'target)
+ (#f package-derivation)
+ (triplet
+ (cut package-cross-derivation <> <> triplet <>))))
+
+ (define src? (assoc-ref opts 'source?))
+ (define sys (assoc-ref opts 'system))
+
+ (fold2 (lambda (arg derivations files)
+ (match arg
+ (('expression . str)
+ (let ((drv (derivation-from-expression store str
+ package->derivation
+ sys src?)))
+ (values (cons drv derivations)
+ (cons (derivation->output-path drv) files))))
+ (('argument . (? store-path? file))
+ (values derivations (cons file files)))
+ (('argument . (? string? spec))
+ (let-values (((p output)
+ (specification->package+output spec)))
+ (if src?
+ (let* ((s (package-source p))
+ (drv (package-source-derivation store s)))
+ (values (cons drv derivations)
+ (cons (derivation->output-path drv)
+ files)))
+ (let ((drv (package->derivation store p sys)))
+ (values (cons drv derivations)
+ (cons (derivation->output-path drv output)
+ files))))))
+ (_
+ (values derivations files))))
+ '()
+ '()
+ opts))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (export-from-store store opts)
+ "Export the packages or derivations specified in OPTS from STORE. Write the
+resulting archive to the standard output port."
+ (let-values (((drv files)
+ (options->derivations+files store opts)))
+ (show-what-to-build store drv
+ #:use-substitutes? (assoc-ref opts 'substitutes?)
+ #:dry-run? (assoc-ref opts 'dry-run?))
+
+ (set-build-options store
+ #:build-cores (or (assoc-ref opts 'cores) 0)
+ #:fallback? (assoc-ref opts 'fallback?)
+ #:use-substitutes? (assoc-ref opts 'substitutes?)
+ #:max-silent-time (assoc-ref opts 'max-silent-time))
+
+ (if (or (assoc-ref opts 'dry-run?)
+ (build-derivations store drv))
+ (export-paths store files (current-output-port))
+ (leave (_ "unable to export the given packages~%")))))
+
+(define (generate-key-pair parameters)
+ "Generate a key pair with PARAMETERS, a canonical sexp, and store it in the
+right place."
+ (when (or (file-exists? %public-key-file)
+ (file-exists? %private-key-file))
+ (leave (_ "key pair exists under '~a'; remove it first~%")
+ (dirname %public-key-file)))
+
+ (format (current-error-port)
+ (_ "Please wait while gathering entropy to generate the key pair;
+this may take time...~%"))
+
+ (let* ((pair (catch 'gcry-error
+ (lambda ()
+ (generate-key parameters))
+ (lambda (key err)
+ (leave (_ "key generation failed: ~a: ~a~%")
+ (error-source err)
+ (error-string err)))))
+ (public (find-sexp-token pair 'public-key))
+ (secret (find-sexp-token pair 'private-key)))
+ ;; Create the following files as #o400.
+ (umask #o266)
+
+ (mkdir-p (dirname %public-key-file))
+ (with-atomic-file-output %public-key-file
+ (lambda (port)
+ (display (canonical-sexp->string public) port)))
+ (with-atomic-file-output %private-key-file
+ (lambda (port)
+ (display (canonical-sexp->string secret) port)))
+
+ ;; Make the public key readable by everyone.
+ (chmod %public-key-file #o444)))
+
+(define (authorize-key)
+ "Authorize imports signed by the public key passed as an advanced sexp on
+the input port."
+ (define (read-key)
+ (catch 'gcry-error
+ (lambda ()
+ (string->canonical-sexp (get-string-all (current-input-port))))
+ (lambda (key err)
+ (leave (_ "failed to read public key: ~a: ~a~%")
+ (error-source err) (error-string err)))))
+
+ (let ((key (read-key))
+ (acl (current-acl)))
+ (unless (eq? 'public-key (canonical-sexp-nth-data key 0))
+ (leave (_ "s-expression does not denote a public key~%")))
+
+ ;; Add KEY to the ACL and write that.
+ (let ((acl (public-keys->acl (cons key (acl->public-keys acl)))))
+ (with-atomic-file-output %acl-file
+ (lambda (port)
+ (display (canonical-sexp->string acl) port))))))
+
+(define (guix-archive . 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 (lines port)
+ ;; Return lines read from PORT.
+ (let loop ((line (read-line port))
+ (result '()))
+ (if (eof-object? line)
+ (reverse result)
+ (loop (read-line port)
+ (cons line result)))))
+
+ (with-error-handling
+ ;; Ask for absolute file names so that .drv file names passed from the
+ ;; user to 'read-derivation' are absolute when it returns.
+ (with-fluids ((%file-port-name-canonicalization 'absolute))
+ (let ((opts (parse-options)))
+ (cond ((assoc-ref opts 'generate-key)
+ =>
+ generate-key-pair)
+ ((assoc-ref opts 'authorize)
+ (authorize-key))
+ (else
+ (let ((store (open-connection)))
+ (cond ((assoc-ref opts 'export)
+ (export-from-store store opts))
+ ((assoc-ref opts 'import)
+ (import-paths store (current-input-port)))
+ ((assoc-ref opts 'missing)
+ (let* ((files (lines (current-input-port)))
+ (missing (remove (cut valid-path? store <>)
+ files)))
+ (format #t "~{~a~%~}" missing)))
+ (else
+ (leave
+ (_ "either '--export' or '--import' \
+must be specified~%")))))))))))
diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm
new file mode 100644
index 0000000000..c7a14f7a8b
--- /dev/null
+++ b/guix/scripts/authenticate.scm
@@ -0,0 +1,101 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(define-module (guix scripts authenticate)
+ #:use-module (guix config)
+ #:use-module (guix utils)
+ #:use-module (guix pk-crypto)
+ #:use-module (guix pki)
+ #:use-module (guix ui)
+ #:use-module (rnrs io ports)
+ #:use-module (ice-9 match)
+ #:export (guix-authenticate))
+
+;;; Commentary:
+;;;
+;;; This program is used internally by the daemon to sign exported archive
+;;; (the 'export-paths' RPC), and to authenticate imported archives (the
+;;; 'import-paths' RPC.)
+;;;
+;;; Code:
+
+(define (read-canonical-sexp file)
+ "Read a gcrypt sexp from FILE and return it."
+ (call-with-input-file file
+ (compose string->canonical-sexp get-string-all)))
+
+(define (read-hash-data file)
+ "Read sha256 hash data from FILE and return it as a gcrypt sexp."
+ (let* ((hex (call-with-input-file file get-string-all))
+ (bv (base16-string->bytevector (string-trim-both hex))))
+ (bytevector->hash-data bv)))
+
+
+;;;
+;;; Entry point with 'openssl'-compatible interface. We support this
+;;; interface because that's what the daemon expects, and we want to leave it
+;;; unmodified currently.
+;;;
+
+(define (guix-authenticate . args)
+ (match args
+ (("rsautl" "-sign" "-inkey" key "-in" hash-file)
+ ;; Sign the hash in HASH-FILE with KEY, and return an sexp that includes
+ ;; both the hash and the actual signature.
+ (let* ((secret-key (read-canonical-sexp key))
+ (public-key (if (string-suffix? ".sec" key)
+ (read-canonical-sexp
+ (string-append (string-drop-right key 4) ".pub"))
+ (leave
+ (_ "cannot find public key for secret key '~a'~%")
+ key)))
+ (data (read-hash-data hash-file))
+ (signature (signature-sexp data secret-key public-key)))
+ (display (canonical-sexp->string signature))
+ #t))
+ (("rsautl" "-verify" "-inkey" _ "-pubin" "-in" signature-file)
+ ;; Read the signature as produced above, check whether its public key is
+ ;; authorized, and verify the signature, and print the signed data to
+ ;; stdout upon success.
+ (let* ((sig+data (read-canonical-sexp signature-file))
+ (public-key (find-sexp-token sig+data 'public-key))
+ (data (find-sexp-token sig+data 'data))
+ (signature (find-sexp-token sig+data 'sig-val)))
+ (if (and data signature)
+ (if (authorized-key? public-key)
+ (if (verify signature data public-key)
+ (begin
+ (display (bytevector->base16-string
+ (hash-data->bytevector data)))
+ #t) ; success
+ (leave (_ "error: invalid signature: ~a~%")
+ (canonical-sexp->string signature)))
+ (leave (_ "error: unauthorized public key: ~a~%")
+ (canonical-sexp->string public-key)))
+ (leave (_ "error: corrupt signature data: ~a~%")
+ (canonical-sexp->string sig+data)))))
+ (("--help")
+ (display (_ "Usage: guix authenticate OPTION...
+Sign or verify the signature on the given file. This tool is meant to
+be used internally by 'guix-daemon'.\n")))
+ (("--version")
+ (show-version-and-exit "guix authenticate"))
+ (else
+ (leave (_ "wrong arguments")))))
+
+;;; authenticate.scm ends here
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index dd9a9b8127..7cb3710853 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
@@ -32,14 +32,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))
+ #:autoload (gnu packages) (find-best-packages-by-name)
+ #:export (derivation-from-expression
+ guix-build))
-(define %store
- (make-parameter #f))
-
-(define (derivation-from-expression str package-derivation
+(define (derivation-from-expression store str package-derivation
system source?)
"Read/eval STR and return the corresponding derivation path for SYSTEM.
When SOURCE? is true and STR evaluates to a package, return the derivation of
@@ -50,12 +47,57 @@ derivation of a package."
(if source?
(let ((source (package-source p)))
(if source
- (package-source-derivation (%store) source)
+ (package-source-derivation store source)
(leave (_ "package `~a' has no source~%")
(package-name p))))
- (package-derivation (%store) p system)))
+ (package-derivation store p system)))
((? procedure? proc)
- (run-with-store (%store) (proc) #:system system))))
+ (run-with-store store (proc) #:system system))))
+
+(define (specification->package spec)
+ "Return a package matching SPEC. SPEC 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 spec)))
+ (match (find-best-packages-by-name name version)
+ ((p) ; one match
+ p)
+ ((p x ...) ; several matches
+ (warning (_ "ambiguous package specification `~a'~%") spec)
+ (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))))))
+
+(define (register-root store 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
+ (leave (_ "failed to create GC root `~a': ~a~%")
+ root (strerror (system-error-errno args)))))))
;;;
@@ -66,6 +108,7 @@ derivation of a package."
;; Alist of default option values.
`((system . ,(%current-system))
(substitutes? . #t)
+ (build-hook? . #t)
(max-silent-time . 3600)
(verbosity . 0)))
@@ -91,6 +134,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(display (_ "
--no-substitutes build instead of resorting to pre-built substitutes"))
(display (_ "
+ --no-build-hook do not attempt to offload builds via the build hook"))
+ (display (_ "
--max-silent-time=SECONDS
mark the build as failed after SECONDS of silence"))
(display (_ "
@@ -157,6 +202,10 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(lambda (opt name arg result)
(alist-cons 'substitutes? #f
(alist-delete 'substitutes? result))))
+ (option '("no-build-hook") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'build-hook? #f
+ (alist-delete 'build-hook? result))))
(option '("max-silent-time") #t #f
(lambda (opt name arg result)
(alist-cons 'max-silent-time (string->number* arg)
@@ -173,6 +222,36 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(lambda (opt name arg result)
(alist-cons 'log-file? #t result)))))
+(define (options->derivations store opts)
+ "Given OPTS, the result of 'args-fold', return a list of derivations to
+build."
+ (define package->derivation
+ (match (assoc-ref opts 'target)
+ (#f package-derivation)
+ (triplet
+ (cut package-cross-derivation <> <> triplet <>))))
+
+ (define src? (assoc-ref opts 'source?))
+ (define sys (assoc-ref opts 'system))
+
+ (filter-map (match-lambda
+ (('expression . str)
+ (derivation-from-expression store str package->derivation
+ sys src?))
+ (('argument . (? derivation-path? drv))
+ (call-with-input-file drv read-derivation))
+ (('argument . (? store-path?))
+ ;; Nothing to do; maybe for --log-file.
+ #f)
+ (('argument . (? string? x))
+ (let ((p (specification->package x)))
+ (if src?
+ (let ((s (package-source p)))
+ (package-source-derivation store s))
+ (package->derivation store p sys))))
+ (_ #f))
+ opts))
+
;;;
;;; Entry point.
@@ -188,146 +267,66 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(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
- (leave (_ "failed to create GC root `~a': ~a~%")
- root (strerror (system-error-errno args)))))))
-
- (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
- (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
- (leave (_ "~A: package not found for version ~a~%")
- name version)
- (leave (_ "~A: unknown package~%") name))))))
-
(with-error-handling
;; Ask for absolute file names so that .drv file names passed from the
;; user to 'read-derivation' are absolute when it returns.
(with-fluids ((%file-port-name-canonicalization 'absolute))
- (let ((opts (parse-options)))
- (define package->derivation
- (match (assoc-ref opts 'target)
- (#f package-derivation)
- (triplet
- (cut package-cross-derivation <> <> triplet <>))))
-
- (parameterize ((%store (open-connection)))
- (let* ((src? (assoc-ref opts 'source?))
- (sys (assoc-ref opts 'system))
- (drv (filter-map (match-lambda
- (('expression . str)
- (derivation-from-expression
- str package->derivation sys src?))
- (('argument . (? derivation-path? drv))
- (call-with-input-file drv read-derivation))
- (('argument . (? store-path?))
- ;; Nothing to do; maybe for --log-file.
- #f)
- (('argument . (? string? x))
- (let ((p (find-package x)))
- (if src?
- (let ((s (package-source p)))
- (package-source-derivation
- (%store) s))
- (package->derivation (%store) p sys))))
- (_ #f))
- opts))
- (roots (filter-map (match-lambda
- (('gc-root . root) root)
- (_ #f))
- opts)))
+ (let* ((opts (parse-options))
+ (store (open-connection))
+ (drv (options->derivations store opts))
+ (roots (filter-map (match-lambda
+ (('gc-root . root) root)
+ (_ #f))
+ opts)))
- (unless (assoc-ref opts 'log-file?)
- (show-what-to-build (%store) drv
- #:use-substitutes? (assoc-ref opts 'substitutes?)
- #:dry-run? (assoc-ref opts 'dry-run?)))
+ (unless (assoc-ref opts 'log-file?)
+ (show-what-to-build store drv
+ #:use-substitutes? (assoc-ref opts 'substitutes?)
+ #:dry-run? (assoc-ref opts 'dry-run?)))
- ;; TODO: Add more options.
- (set-build-options (%store)
- #:keep-failed? (assoc-ref opts 'keep-failed?)
- #:build-cores (or (assoc-ref opts 'cores) 0)
- #:fallback? (assoc-ref opts 'fallback?)
- #:use-substitutes? (assoc-ref opts 'substitutes?)
- #:max-silent-time (assoc-ref opts 'max-silent-time)
- #:verbosity (assoc-ref opts 'verbosity))
+ ;; TODO: Add more options.
+ (set-build-options store
+ #:keep-failed? (assoc-ref opts 'keep-failed?)
+ #:build-cores (or (assoc-ref opts 'cores) 0)
+ #:fallback? (assoc-ref opts 'fallback?)
+ #:use-substitutes? (assoc-ref opts 'substitutes?)
+ #:use-build-hook? (assoc-ref opts 'build-hook?)
+ #:max-silent-time (assoc-ref opts 'max-silent-time)
+ #:verbosity (assoc-ref opts 'verbosity))
- (cond ((assoc-ref opts 'log-file?)
- (for-each (lambda (file)
- (let ((log (log-file (%store) file)))
- (if log
- (format #t "~a~%" log)
- (leave (_ "no build log for '~a'~%")
- file))))
- (delete-duplicates
- (append (map derivation-file-name drv)
- (filter-map (match-lambda
- (('argument
- . (? store-path? file))
- file)
- (_ #f))
- opts)))))
- ((assoc-ref opts 'derivations-only?)
- (format #t "~{~a~%~}" (map derivation-file-name drv))
- (for-each (cut register-root <> <>)
- (map (compose list derivation-file-name) drv)
- roots))
- ((not (assoc-ref opts 'dry-run?))
- (and (build-derivations (%store) drv)
- (for-each (lambda (d)
- (format #t "~{~a~%~}"
- (map (match-lambda
- ((out-name . out)
- (derivation->output-path
- d out-name)))
- (derivation-outputs d))))
- drv)
- (for-each (cut register-root <> <>)
- (map (lambda (drv)
- (map cdr
- (derivation->output-paths drv)))
- drv)
- roots))))))))))
+ (cond ((assoc-ref opts 'log-file?)
+ (for-each (lambda (file)
+ (let ((log (log-file store file)))
+ (if log
+ (format #t "~a~%" log)
+ (leave (_ "no build log for '~a'~%")
+ file))))
+ (delete-duplicates
+ (append (map derivation-file-name drv)
+ (filter-map (match-lambda
+ (('argument
+ . (? store-path? file))
+ file)
+ (_ #f))
+ opts)))))
+ ((assoc-ref opts 'derivations-only?)
+ (format #t "~{~a~%~}" (map derivation-file-name drv))
+ (for-each (cut register-root store <> <>)
+ (map (compose list derivation-file-name) drv)
+ roots))
+ ((not (assoc-ref opts 'dry-run?))
+ (and (build-derivations store drv)
+ (for-each (lambda (d)
+ (format #t "~{~a~%~}"
+ (map (match-lambda
+ ((out-name . out)
+ (derivation->output-path
+ d out-name)))
+ (derivation-outputs d))))
+ drv)
+ (for-each (cut register-root store <> <>)
+ (map (lambda (drv)
+ (map cdr
+ (derivation->output-paths drv)))
+ drv)
+ roots))))))))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 49fa457a9c..04393abc9a 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
;;;
@@ -41,7 +41,8 @@
#:use-module ((gnu packages base) #:select (guile-final))
#:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile))
#:use-module (guix gnu-maintenance)
- #:export (guix-package))
+ #:export (specification->package+output
+ guix-package))
(define %store
(make-parameter #f))
@@ -56,7 +57,7 @@
(cut string-append <> "/.guix-profile")))
(define %profile-directory
- (string-append (or (getenv "NIX_STATE_DIR") %state-directory) "/profiles/"
+ (string-append %state-directory "/profiles/"
(or (and=> (getenv "USER")
(cut string-append "per-user/" <>))
"default")))
@@ -292,21 +293,24 @@ return its return value."
(format (current-error-port) " interrupted by signal ~a~%" SIGINT)
#f))))
-(define newest-available-packages
- (memoize find-newest-available-packages))
-
-(define (find-best-packages-by-name name version)
- "If version is #f, return the list of packages named NAME with the highest
-version numbers; otherwise, return the list of packages named NAME and at
-VERSION."
- (if version
- (find-packages-by-name name version)
- (match (vhash-assoc name (newest-available-packages))
- ((_ version pkgs ...) pkgs)
- (#f '()))))
+(define-syntax-rule (leave-on-EPIPE exp ...)
+ "Run EXP... in a context when EPIPE errors are caught and lead to 'exit'
+with successful exit code. This is useful when writing to the standard output
+may lead to EPIPE, because the standard output is piped through 'head' or
+similar."
+ (catch 'system-error
+ (lambda ()
+ exp ...)
+ (lambda args
+ ;; We really have to exit this brutally, otherwise Guile eventually
+ ;; attempts to flush all the ports, leading to an uncaught EPIPE down
+ ;; the path.
+ (if (= EPIPE (system-error-errno args))
+ (primitive-_exit 0)
+ (apply throw args)))))
(define* (specification->package+output spec #:optional (output "out"))
- "Find the package and output specified by SPEC, or #f and #f; SPEC may
+ "Return the package and output specified by SPEC, or #f and #f; SPEC may
optionally contain a version number and an output name, as in these examples:
guile
@@ -342,7 +346,7 @@ version; if SPEC does not specify an output, return OUTPUT."
"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))
+ (match (vhash-assoc name (find-newest-available-packages))
((_ candidate-version pkg . rest)
(case (version-compare candidate-version current-version)
((>) #t)
@@ -970,15 +974,17 @@ more information.~%"))
profile))
((string-null? pattern)
(let ((numbers (generation-numbers profile)))
- (if (equal? numbers '(0))
- (exit 0)
- (for-each list-generation numbers))))
+ (leave-on-EPIPE
+ (if (equal? numbers '(0))
+ (exit 0)
+ (for-each list-generation numbers)))))
((matching-generations pattern profile)
=>
(lambda (numbers)
(if (null-list? numbers)
(exit 1)
- (for-each list-generation numbers))))
+ (leave-on-EPIPE
+ (for-each list-generation numbers)))))
(else
(leave (_ "invalid syntax: ~a~%")
pattern)))
@@ -988,15 +994,16 @@ more information.~%"))
(let* ((regexp (and regexp (make-regexp regexp)))
(manifest (profile-manifest profile))
(installed (manifest-entries manifest)))
- (for-each (match-lambda
- (($ <manifest-entry> 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))))
-
- ;; Show most recently installed packages last.
- (reverse installed))
+ (leave-on-EPIPE
+ (for-each (match-lambda
+ (($ <manifest-entry> 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))))
+
+ ;; Show most recently installed packages last.
+ (reverse installed)))
#t))
(('list-available regexp)
@@ -1010,16 +1017,17 @@ more information.~%"))
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)
- (string<? (package-name p1)
- (package-name p2)))))
+ (leave-on-EPIPE
+ (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)
+ (string<? (package-name p1)
+ (package-name p2))))))
#t))
(('search regexp)
diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 0da29d435b..901b3fb064 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -72,21 +72,6 @@
;; How often we want to remove files corresponding to expired cache entries.
(* 7 24 3600))
-(define (with-atomic-file-output file proc)
- "Call PROC with an output port for the file that is going to replace FILE.
-Upon success, FILE is atomically replaced by what has been written to the
-output port, and PROC's result is returned."
- (let* ((template (string-append file ".XXXXXX"))
- (out (mkstemp! template)))
- (with-throw-handler #t
- (lambda ()
- (let ((result (proc out)))
- (close out)
- (rename-file template file)
- result))
- (lambda (key . args)
- (false-if-exception (delete-file template))))))
-
;; In Guile 2.0.9, `regexp-exec' is thread-unsafe, so work around it.
;; See <http://bugs.gnu.org/14404>.
(set! regexp-exec
@@ -594,7 +579,6 @@ Internal tool to substitute a pre-built binary to a local build.\n"))
;;; Local Variables:
-;;; eval: (put 'with-atomic-file-output 'scheme-indent-function 1)
;;; eval: (put 'with-timeout 'scheme-indent-function 1)
;;; End:
diff --git a/guix/store.scm b/guix/store.scm
index 08b0671b29..1012480b39 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -80,6 +80,8 @@
dead-paths
collect-garbage
delete-paths
+ import-paths
+ export-paths
current-build-output-port
@@ -156,8 +158,7 @@
(delete-specific 3))
(define %default-socket-path
- (string-append (or (getenv "NIX_STATE_DIR") %state-directory)
- "/daemon-socket/socket"))
+ (string-append %state-directory "/daemon-socket/socket"))
(define %daemon-socket-file
;; File name of the socket the daemon listens too.
@@ -323,7 +324,30 @@ operate, should the disk become full. Return a server object."
;; The port where build output is sent.
(make-parameter (current-error-port)))
-(define (process-stderr server)
+(define* (dump-port in out
+ #:optional len
+ #:key (buffer-size 16384))
+ "Read LEN bytes from IN (or as much as possible if LEN is #f) and write it
+to OUT, using chunks of BUFFER-SIZE bytes."
+ (define buffer
+ (make-bytevector buffer-size))
+
+ (let loop ((total 0)
+ (bytes (get-bytevector-n! in buffer 0
+ (if len
+ (min len buffer-size)
+ buffer-size))))
+ (or (eof-object? bytes)
+ (and len (= total len))
+ (let ((total (+ total bytes)))
+ (put-bytevector out buffer 0 bytes)
+ (loop total
+ (get-bytevector-n! in buffer 0
+ (if len
+ (min (- len total) buffer-size)
+ buffer-size)))))))
+
+(define* (process-stderr server #:optional user-port)
"Read standard output and standard error from SERVER, writing it to
CURRENT-BUILD-OUTPUT-PORT. Return #t when SERVER is done sending data, and
#f otherwise; in the latter case, the caller should call `process-stderr'
@@ -344,17 +368,30 @@ encoding conversion errors."
(let ((k (read-int p)))
(cond ((= k %stderr-write)
- (read-latin1-string p)
+ ;; Write a byte stream to USER-PORT.
+ (let* ((len (read-int p))
+ (m (modulo len 8)))
+ (dump-port p user-port len)
+ (unless (zero? m)
+ ;; Consume padding, as for strings.
+ (get-bytevector-n p (- 8 m))))
#f)
((= k %stderr-read)
- (let ((len (read-int p)))
- (read-latin1-string p) ; FIXME: what to do?
+ ;; Read a byte stream from USER-PORT.
+ (let* ((max-len (read-int p))
+ (data (get-bytevector-n user-port max-len))
+ (len (bytevector-length data)))
+ (write-int len p)
+ (put-bytevector p data)
+ (write-padding len p)
#f))
((= k %stderr-next)
+ ;; Log a string.
(let ((s (read-latin1-string p)))
(display s (current-build-output-port))
#f))
((= k %stderr-error)
+ ;; Report an error.
(let ((error (read-latin1-string p))
;; Currently the daemon fails to send a status code for early
;; errors like DB schema version mismatches, so check for EOF.
@@ -624,6 +661,39 @@ MIN-FREED bytes have been collected. Return the paths that were
collected, and the number of bytes freed."
(run-gc server (gc-action delete-specific) paths min-freed))
+(define (import-paths server port)
+ "Import the set of store paths read from PORT into SERVER's store. An error
+is raised if the set of paths read from PORT is not signed (as per
+'export-path #:sign? #t'.) Return the list of store paths imported."
+ (let ((s (nix-server-socket server)))
+ (write-int (operation-id import-paths) s)
+ (let loop ((done? (process-stderr server port)))
+ (or done? (loop (process-stderr server port))))
+ (read-store-path-list s)))
+
+(define* (export-path server path port #:key (sign? #t))
+ "Export PATH to PORT. When SIGN? is true, sign it."
+ (let ((s (nix-server-socket server)))
+ (write-int (operation-id export-path) s)
+ (write-store-path path s)
+ (write-arg boolean sign? s)
+ (let loop ((done? (process-stderr server port)))
+ (or done? (loop (process-stderr server port))))
+ (= 1 (read-int s))))
+
+(define* (export-paths server paths port #:key (sign? #t))
+ "Export the store paths listed in PATHS to PORT, signing them if SIGN?
+is true."
+ (let ((s (nix-server-socket server)))
+ (let loop ((paths paths))
+ (match paths
+ (()
+ (write-int 0 port))
+ ((head tail ...)
+ (write-int 1 port)
+ (and (export-path server head port #:sign? sign?)
+ (loop tail)))))))
+
;;;
;;; Store paths.
@@ -631,8 +701,7 @@ collected, and the number of bytes freed."
(define %store-prefix
;; Absolute path to the Nix store.
- (make-parameter (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path)
- %store-directory)))
+ (make-parameter %store-directory))
(define (store-path? path)
"Return #t if PATH is a store path."
@@ -678,16 +747,16 @@ syntactically valid store path."
(define (log-file store file)
"Return the build log file for FILE, or #f if none could be found. FILE
must be an absolute store file name, or a derivation file name."
- (define state-dir ; XXX: factorize
- (or (getenv "NIX_STATE_DIR") %state-directory))
-
(cond ((derivation-path? file)
- (let* ((base (basename file))
- (log (string-append (dirname state-dir) ; XXX: ditto
- "/log/nix/drvs/"
- (string-take base 2) "/"
- (string-drop base 2) ".bz2")))
- (and (file-exists? log) log)))
+ (let* ((base (basename file))
+ (log (string-append (dirname %state-directory) ; XXX
+ "/log/nix/drvs/"
+ (string-take base 2) "/"
+ (string-drop base 2)))
+ (log.bz2 (string-append log ".bz2")))
+ (cond ((file-exists? log.bz2) log.bz2)
+ ((file-exists? log) log)
+ (else #f))))
(else
(match (valid-derivers store file)
((derivers ...)
diff --git a/guix/utils.scm b/guix/utils.scm
index b730340eda..04a74ee29a 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -67,6 +67,7 @@
file-extension
file-sans-extension
call-with-temporary-output-file
+ with-atomic-file-output
fold2
filtered-port))
@@ -426,6 +427,21 @@ call."
(false-if-exception (close out))
(false-if-exception (delete-file template))))))
+(define (with-atomic-file-output file proc)
+ "Call PROC with an output port for the file that is going to replace FILE.
+Upon success, FILE is atomically replaced by what has been written to the
+output port, and PROC's result is returned."
+ (let* ((template (string-append file ".XXXXXX"))
+ (out (mkstemp! template)))
+ (with-throw-handler #t
+ (lambda ()
+ (let ((result (proc out)))
+ (close out)
+ (rename-file template file)
+ result))
+ (lambda (key . args)
+ (false-if-exception (delete-file template))))))
+
(define fold2
(case-lambda
((proc seed1 seed2 lst)
diff --git a/nix/libutil/gcrypt-hash.cc b/nix/libutil/gcrypt-hash.cc
index 553f633b93..c4ae7bfcc2 100644
--- a/nix/libutil/gcrypt-hash.cc
+++ b/nix/libutil/gcrypt-hash.cc
@@ -45,6 +45,7 @@ guix_hash_final (void *resbuf, struct guix_hash_context *ctx,
memcpy (resbuf, gcry_md_read (ctx->md_handle, algo),
gcry_md_get_algo_dlen (algo));
gcry_md_close (ctx->md_handle);
+ ctx->md_handle = NULL;
}
}
diff --git a/nix/libutil/gcrypt-hash.hh b/nix/libutil/gcrypt-hash.hh
index d93a6eb881..11f061159f 100644
--- a/nix/libutil/gcrypt-hash.hh
+++ b/nix/libutil/gcrypt-hash.hh
@@ -23,17 +23,28 @@
#include <gcrypt.h>
#include <unistd.h>
-extern "C" {
-
struct guix_hash_context
{
+ /* This copy constructor is needed in 'HashSink::currentHash()' where we
+ expect the copy of a 'Ctx' object to yield a truly different context. */
+ guix_hash_context (guix_hash_context &ref)
+ {
+ if (ref.md_handle == NULL)
+ md_handle = NULL;
+ else
+ gcry_md_copy (&md_handle, ref.md_handle);
+ }
+
+ /* Make sure 'md_handle' is always initialized. */
+ guix_hash_context (): md_handle (NULL) { };
+
gcry_md_hd_t md_handle;
};
+extern "C" {
extern void guix_hash_init (struct guix_hash_context *ctx, int algo);
extern void guix_hash_update (struct guix_hash_context *ctx, const void *buffer,
size_t len);
extern void guix_hash_final (void *resbuf, struct guix_hash_context *ctx,
int algo);
-
}
diff --git a/nix/nix-daemon/guix-daemon.cc b/nix/nix-daemon/guix-daemon.cc
index 4f9fa4c525..cf87e39354 100644
--- a/nix/nix-daemon/guix-daemon.cc
+++ b/nix/nix-daemon/guix-daemon.cc
@@ -195,6 +195,10 @@ main (int argc, char *argv[])
exit (EXIT_FAILURE);
}
+ /* Tell Libgcrypt that initialization has completed, as per the Libgcrypt
+ 1.6.0 manual (although this does not appear to be strictly needed.) */
+ gcry_control (GCRYCTL_INITIALIZATION_FINISHED, 0);
+
/* Set the umask so that the daemon does not end up creating group-writable
files, which would lead to "suspicious ownership or permission" errors.
See <http://lists.gnu.org/archive/html/bug-guix/2013-07/msg00033.html>. */
@@ -212,6 +216,12 @@ main (int argc, char *argv[])
{
settings.processEnvironment ();
+ /* Hackily help 'local-store.cc' find our 'guix-authenticate' program, which
+ is known as 'OPENSSL_PATH' here. */
+ std::string search_path (getenv ("PATH"));
+ search_path = settings.nixLibexecDir + ":" + search_path;
+ setenv ("PATH", search_path.c_str (), 1);
+
/* Use our substituter by default. */
settings.substituters.clear ();
settings.useSubstitutes = true;
diff --git a/nix/scripts/guix-authenticate.in b/nix/scripts/guix-authenticate.in
new file mode 100644
index 0000000000..5ce57915f0
--- /dev/null
+++ b/nix/scripts/guix-authenticate.in
@@ -0,0 +1,11 @@
+#!@SHELL@
+# A shorthand for "guix authenticate", for use by the daemon.
+
+if test "x$GUIX_UNINSTALLED" = "x"
+then
+ prefix="@prefix@"
+ exec_prefix="@exec_prefix@"
+ exec "@bindir@/guix" authenticate "$@"
+else
+ exec guix authenticate "$@"
+fi
diff --git a/nix/sync-with-upstream b/nix/sync-with-upstream
index 535763d602..720fae132e 100755
--- a/nix/sync-with-upstream
+++ b/nix/sync-with-upstream
@@ -70,3 +70,11 @@ cp -v "$top_srcdir/nix-upstream/AUTHORS" "$top_srcdir/nix"
# Substitutions.
sed -i "$top_srcdir/nix/libstore/gc.cc" \
-e 's|/nix/find-runtime-roots\.pl|/guix/list-runtime-roots|g'
+
+# Our 'guix_hash_context' structure has a copy constructor, specifically to
+# handle the use case in 'HashSink::currentHash()' where the copy of the
+# context is expected to truly copy the underlying hash context. The copy
+# constructor cannot be used in 'Ctx' if that's a union, so turn it into a
+# structure (we can afford to two wasted words.)
+sed -i "$top_srcdir/nix/libutil/hash.cc" "$top_srcdir/nix/libutil/hash.hh" \
+ -e 's|union Ctx|struct Ctx|g'
diff --git a/po/POTFILES.in b/po/POTFILES.in
index 0e30bb0880..beefdc901b 100644
--- a/po/POTFILES.in
+++ b/po/POTFILES.in
@@ -11,6 +11,7 @@ guix/scripts/gc.scm
guix/scripts/hash.scm
guix/scripts/pull.scm
guix/scripts/substitute-binary.scm
+guix/scripts/authenticate.scm
guix/gnu-maintenance.scm
guix/ui.scm
guix/http-client.scm
diff --git a/test-env.in b/test-env.in
index 9224a80537..df73ecdc7a 100644
--- a/test-env.in
+++ b/test-env.in
@@ -40,6 +40,22 @@ then
# Currently, in Nix builds, we're at ~106 chars...
NIX_STATE_DIR="@GUIX_TEST_ROOT@/var/$$"
+ # The configuration directory, for import/export signing keys.
+ NIX_CONF_DIR="@GUIX_TEST_ROOT@/etc"
+ if [ ! -d "$NIX_CONF_DIR" ]
+ then
+ # Copy the keys so that the secret key has the right permissions (the
+ # daemon errors out when this is not the case.)
+ mkdir -p "$NIX_CONF_DIR"
+ cp "@abs_top_srcdir@/tests/signing-key.sec" \
+ "@abs_top_srcdir@/tests/signing-key.pub" \
+ "$NIX_CONF_DIR"
+ chmod 400 "$NIX_CONF_DIR/signing-key.sec"
+ fi
+
+ # For 'guix-authenticate'.
+ NIX_LIBEXEC_DIR="@abs_top_builddir@/nix/scripts"
+
# 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"
@@ -51,7 +67,7 @@ then
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 GUIX_BINARY_SUBSTITUTE_URL \
- XDG_CACHE_HOME
+ NIX_CONF_DIR NIX_LIBEXEC_DIR XDG_CACHE_HOME
# Do that because store.scm calls `canonicalize-path' on it.
mkdir -p "$NIX_STORE_DIR"
diff --git a/tests/guix-archive.sh b/tests/guix-archive.sh
new file mode 100644
index 0000000000..0de7395145
--- /dev/null
+++ b/tests/guix-archive.sh
@@ -0,0 +1,66 @@
+# GNU Guix --- Functional package management for GNU
+# Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+#
+# 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 <http://www.gnu.org/licenses/>.
+
+#
+# Test the 'guix archive' command-line utility.
+#
+
+guix archive --version
+
+archive="t-archive-$$"
+archive_alt="t-archive-alt-$$"
+rm -f "$archive" "$archive_alt"
+
+trap 'rm -f "$archive" "$archive_alt"' EXIT
+
+guix archive --export guile-bootstrap > "$archive"
+guix archive --export guile-bootstrap:out > "$archive_alt"
+cmp "$archive" "$archive_alt"
+
+guix archive --export \
+ -e '(@ (gnu packages bootstrap) %bootstrap-guile)' > "$archive_alt"
+cmp "$archive" "$archive_alt"
+
+guix archive --export `guix build guile-bootstrap` > "$archive_alt"
+cmp "$archive" "$archive_alt"
+
+guix archive --import < "$archive" 2>&1 | grep "import.*guile-bootstrap"
+
+if guix archive something-that-does-not-exist
+then false; else true; fi
+
+# This one must not be listed as missing.
+guix build guile-bootstrap > "$archive"
+guix archive --missing < "$archive"
+test "`guix archive --missing < "$archive"`" = ""
+
+# Two out of three should be listed as missing.
+echo "$NIX_STORE_DIR/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo" >> "$archive"
+echo "$NIX_STORE_DIR/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-bar" >> "$archive"
+guix archive --missing < "$archive" > "$archive_alt"
+echo "$NIX_STORE_DIR/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo" > "$archive"
+echo "$NIX_STORE_DIR/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-bar" >> "$archive"
+cmp "$archive" "$archive_alt"
+
+# This is not a valid store file name, so an error.
+echo something invalid > "$archive"
+if guix archive --missing < "$archive"
+then false; else true; fi
+
+if echo foo | guix archive --authorize
+then false; else true; fi
diff --git a/tests/guix-authenticate.sh b/tests/guix-authenticate.sh
new file mode 100644
index 0000000000..aa6f9e9f01
--- /dev/null
+++ b/tests/guix-authenticate.sh
@@ -0,0 +1,63 @@
+# GNU Guix --- Functional package management for GNU
+# Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+#
+# 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 <http://www.gnu.org/licenses/>.
+
+#
+# Test the 'guix authenticate' command-line utility.
+#
+
+guix authenticate --version
+
+sig="t-signature-$$"
+hash="t-hash-$$"
+rm -f "$sig" "$hash"
+
+trap 'rm -f "$sig" "$hash"' EXIT
+
+# A hexadecimal string as long as a sha256 hash.
+echo "2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb" \
+ > "$hash"
+
+guix authenticate rsautl -sign \
+ -inkey "$abs_top_srcdir/tests/signing-key.sec" \
+ -in "$hash" > "$sig"
+test -f "$sig"
+
+hash2="`guix authenticate rsautl -verify \
+ -inkey $abs_top_srcdir/tests/signing-key.pub \
+ -pubin -in $sig`"
+test "$hash2" = `cat "$hash"`
+
+# Detect corrupt signatures.
+if guix authenticate rsautl -verify \
+ -inkey "$abs_top_srcdir/tests/signing-key.pub" \
+ -pubin -in /dev/null
+then false
+else true
+fi
+
+# Detect invalid signatures.
+# The signature has (payload (data ... (hash sha256 #...#))). We proceed by
+# modifying this hash.
+sed -i "$sig" \
+ -e's|#[A-Z0-9]\{64\}#|#0000000000000000000000000000000000000000000000000000000000000000#|g'
+if guix authenticate rsautl -verify \
+ -inkey "$abs_top_srcdir/tests/signing-key.pub" \
+ -pubin -in "$sig"
+then false
+else true
+fi
diff --git a/tests/guix-package.sh b/tests/guix-package.sh
index 47a2d06cb3..b79c4951d8 100644
--- a/tests/guix-package.sh
+++ b/tests/guix-package.sh
@@ -1,5 +1,5 @@
# GNU Guix --- Functional package management for GNU
-# Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
# Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
#
# This file is part of GNU Guix.
@@ -218,3 +218,10 @@ done
# Extraneous argument.
if guix package install foo-bar;
then false; else true; fi
+
+# Make sure the "broken pipe" doesn't yield an error.
+# Note: 'pipefail' is a Bash-specific option.
+set -o pipefail || true
+guix package -A g | head -1 2> "$HOME/err1"
+guix package -I | head -1 2> "$HOME/err2"
+test "`cat "$HOME/err1" "$HOME/err2"`" = ""
diff --git a/tests/pk-crypto.scm b/tests/pk-crypto.scm
new file mode 100644
index 0000000000..6774dd4157
--- /dev/null
+++ b/tests/pk-crypto.scm
@@ -0,0 +1,230 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(define-module (test-pk-crypto)
+ #:use-module (guix pk-crypto)
+ #:use-module (guix utils)
+ #:use-module (guix hash)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-64)
+ #:use-module (rnrs bytevectors)
+ #:use-module (rnrs io ports)
+ #:use-module (ice-9 match))
+
+;; Test the (guix pk-crypto) module.
+
+(define %key-pair
+ ;; Key pair that was generated with:
+ ;; (generate-key (string->canonical-sexp "(genkey (rsa (nbits 4:1024)))"))
+ ;; which takes a bit of time.
+ "(key-data
+ (public-key
+ (rsa
+ (n #00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45#)
+ (e #010001#)))
+ (private-key
+ (rsa
+ (n #00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45#)
+ (e #010001#)
+ (d #58CAD84653D0046A8EC3F9AA82D9C829B145422109FC3F12DA01A694B92FA296E70D366FB166454D30E632CEE3A033B4C41781BA10325F69FCDC0250CA19C8EEB352FA085992494098DB133E682ED38A931701F0DED1A1E508F4341A4FB446A04F019427C7CB3C44F251EEA9D386100DA80F125E0FD5CE1B0DFEC6D21516EACD#)
+ (p #00D47F185147EC39393CCDA4E7323FFC20FC8B8073E2A54DD63BA392A66975E4204CA48572496A9DFD7522436B852C07472A5AB25B7706F7C14E6F33FBC420FF3B#)
+ (q #00E9AD22F158060BC9AE3601DA623AFC60FFF3058795802CA92371C00097335CF9A23D7782DE353C9DBA93D7BB99E6A24A411107605E722481C5C191F80D7EB77F#)
+ (u #59B45B95AE01A7A7370FAFDB08FE73A4793CE37F228961B09B1B1E7DDAD9F8D3E28F5C5E8B4B067E6B8E0BBF3F690B42991A79E46108DDCDA2514323A66964DE#))))")
+
+(test-begin "pk-crypto")
+
+(let ((sexps '("(foo bar)"
+
+ ;; In Libgcrypt 1.5.3 the following integer is rendered as
+ ;; binary, whereas in 1.6.0 it's rendered as is (hexadecimal.)
+ ;;"#C0FFEE#"
+
+ "(genkey \n (rsa \n (nbits \"1024\")\n )\n )")))
+ (test-equal "string->canonical-sexp->string"
+ sexps
+ (let ((sexps (map string->canonical-sexp sexps)))
+ (and (every canonical-sexp? sexps)
+ (map (compose string-trim-both canonical-sexp->string) sexps)))))
+
+(gc) ; stress test!
+
+(let ((sexps `(("(foo bar)" foo -> "(foo bar)")
+ ("(foo (bar (baz 3:123)))" baz -> "(baz \"123\")")
+ ("(foo (bar 3:123))" baz -> #f))))
+ (test-equal "find-sexp-token"
+ (map (match-lambda
+ ((_ _ '-> expected)
+ expected))
+ sexps)
+ (map (match-lambda
+ ((input token '-> _)
+ (let ((sexp (find-sexp-token (string->canonical-sexp input) token)))
+ (and sexp
+ (string-trim-both (canonical-sexp->string sexp))))))
+ sexps)))
+
+(gc)
+
+(test-equal "canonical-sexp-length"
+ '(0 1 2 4 0 0)
+ (map (compose canonical-sexp-length string->canonical-sexp)
+ '("()" "(a)" "(a b)" "(a #616263# b #C001#)" "a" "#123456#")))
+
+(test-equal "canonical-sexp-list?"
+ '(#t #f #t #f)
+ (map (compose canonical-sexp-list? string->canonical-sexp)
+ '("()" "\"abc\"" "(a b c)" "#123456#")))
+
+(gc)
+
+(test-equal "canonical-sexp-car + cdr"
+ '("(b \n (c xyz)\n )")
+ (let ((lst (string->canonical-sexp "(a (b (c xyz)))")))
+ (map (lambda (sexp)
+ (and sexp (string-trim-both (canonical-sexp->string sexp))))
+ ;; Note: 'car' returns #f when the first element is an atom.
+ (list (canonical-sexp-car (canonical-sexp-cdr lst))))))
+
+(gc)
+
+(test-equal "canonical-sexp-nth"
+ '("(b pqr)" "(c \"456\")" "(d xyz)" #f #f)
+
+ (let ((lst (string->canonical-sexp "(a (b 3:pqr) (c 3:456) (d 3:xyz))")))
+ ;; XXX: In Libgcrypt 1.5.3, (canonical-sexp-nth lst 0) returns LST, whereas in
+ ;; 1.6.0 it returns #f.
+ (map (lambda (sexp)
+ (and sexp (string-trim-both (canonical-sexp->string sexp))))
+ (unfold (cut > <> 5)
+ (cut canonical-sexp-nth lst <>)
+ 1+
+ 1))))
+
+(gc)
+
+(test-equal "canonical-sexp-nth-data"
+ `(Name Otto Meier #f ,(base16-string->bytevector "123456") #f)
+ (let ((lst (string->canonical-sexp
+ "(Name Otto Meier (address Burgplatz) #123456#)")))
+ (unfold (cut > <> 5)
+ (cut canonical-sexp-nth-data lst <>)
+ 1+
+ 0)))
+
+(gc)
+
+;; XXX: The test below is typically too long as it needs to gather enough entropy.
+
+;; (test-assert "generate-key"
+;; (let ((key (generate-key (string->canonical-sexp
+;; "(genkey (rsa (nbits 3:128)))"))))
+;; (and (canonical-sexp? key)
+;; (find-sexp-token key 'key-data)
+;; (find-sexp-token key 'public-key)
+;; (find-sexp-token key 'private-key))))
+
+(test-assert "bytevector->hash-data->bytevector"
+ (let* ((bv (sha256 (string->utf8 "Hello, world.")))
+ (data (bytevector->hash-data bv "sha256")))
+ (and (canonical-sexp? data)
+ (let-values (((value algo) (hash-data->bytevector data)))
+ (and (string=? algo "sha256")
+ (bytevector=? value bv))))))
+
+(test-assert "sign + verify"
+ (let* ((pair (string->canonical-sexp %key-pair))
+ (secret (find-sexp-token pair 'private-key))
+ (public (find-sexp-token pair 'public-key))
+ (data (bytevector->hash-data
+ (sha256 (string->utf8 "Hello, world."))))
+ (sig (sign data secret)))
+ (and (verify sig data public)
+ (not (verify sig
+ (bytevector->hash-data
+ (sha256 (string->utf8 "Hi!")))
+ public)))))
+
+(gc)
+
+(test-equal "canonical-sexp->sexp"
+ `((data
+ (flags pkcs1)
+ (hash sha256
+ ,(base16-string->bytevector
+ "2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb")))
+
+ (public-key
+ (rsa
+ (n ,(base16-string->bytevector
+ (string-downcase
+ "00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45")))
+ (e ,(base16-string->bytevector
+ "010001")))))
+
+ (list (canonical-sexp->sexp
+ (string->canonical-sexp
+ "(data
+ (flags pkcs1)
+ (hash \"sha256\"
+ #2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb#))"))
+
+ (canonical-sexp->sexp
+ (find-sexp-token (string->canonical-sexp %key-pair)
+ 'public-key))))
+
+
+(let ((lst
+ `((data
+ (flags pkcs1)
+ (hash sha256
+ ,(base16-string->bytevector
+ "2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb")))
+
+ (public-key
+ (rsa
+ (n ,(base16-string->bytevector
+ (string-downcase
+ "00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45")))
+ (e ,(base16-string->bytevector
+ "010001"))))
+
+ ,(base16-string->bytevector
+ "2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb"))))
+ (test-equal "sexp->canonical-sexp->sexp"
+ lst
+ (map (compose canonical-sexp->sexp sexp->canonical-sexp)
+ lst)))
+
+(let ((sexp `(signature
+ (public-key
+ (rsa
+ (n ,(make-bytevector 1024 1))
+ (e ,(base16-string->bytevector "010001")))))))
+ (test-equal "https://bugs.g10code.com/gnupg/issue1594"
+ ;; The gcrypt bug above was primarily affecting our uses in
+ ;; 'canonical-sexp->sexp', typically when applied to a signature sexp (in
+ ;; 'guix authenticate -verify') with a "big" RSA key, such as 4096 bits.
+ sexp
+ (canonical-sexp->sexp (sexp->canonical-sexp sexp))))
+
+(test-end)
+
+
+(exit (= (test-runner-fail-count (test-runner-current)) 0))
diff --git a/tests/pki.scm b/tests/pki.scm
new file mode 100644
index 0000000000..04d5a5311b
--- /dev/null
+++ b/tests/pki.scm
@@ -0,0 +1,51 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(define-module (test-pki)
+ #:use-module (guix pki)
+ #:use-module (guix pk-crypto)
+ #:use-module (rnrs io ports)
+ #:use-module (srfi srfi-64))
+
+;; Test the (guix pki) module.
+
+(define %public-key
+ (call-with-input-file %public-key-file
+ (compose string->canonical-sexp
+ get-string-all)))
+
+(test-begin "pki")
+
+(test-assert "current-acl"
+ (not (not (member (canonical-sexp->sexp %public-key)
+ (map canonical-sexp->sexp
+ (acl->public-keys (current-acl)))))))
+
+(test-assert "authorized-key? public-key current-acl"
+ (authorized-key? %public-key))
+
+(test-assert "authorized-key? public-key empty-acl"
+ (not (authorized-key? %public-key (public-keys->acl '()))))
+
+(test-assert "authorized-key? public-key singleton"
+ (authorized-key? %public-key (public-keys->acl (list %public-key))))
+
+(test-end)
+
+
+(exit (= (test-runner-fail-count (test-runner-current)) 0))
diff --git a/tests/signing-key.pub b/tests/signing-key.pub
new file mode 100644
index 0000000000..092424a15d
--- /dev/null
+++ b/tests/signing-key.pub
@@ -0,0 +1,4 @@
+(public-key
+ (rsa
+ (n #00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45#)
+ (e #010001#)))
diff --git a/tests/signing-key.sec b/tests/signing-key.sec
new file mode 100644
index 0000000000..558e189102
--- /dev/null
+++ b/tests/signing-key.sec
@@ -0,0 +1,8 @@
+(private-key
+ (rsa
+ (n #00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45#)
+ (e #010001#)
+ (d #58CAD84653D0046A8EC3F9AA82D9C829B145422109FC3F12DA01A694B92FA296E70D366FB166454D30E632CEE3A033B4C41781BA10325F69FCDC0250CA19C8EEB352FA085992494098DB133E682ED38A931701F0DED1A1E508F4341A4FB446A04F019427C7CB3C44F251EEA9D386100DA80F125E0FD5CE1B0DFEC6D21516EACD#)
+ (p #00D47F185147EC39393CCDA4E7323FFC20FC8B8073E2A54DD63BA392A66975E4204CA48572496A9DFD7522436B852C07472A5AB25B7706F7C14E6F33FBC420FF3B#)
+ (q #00E9AD22F158060BC9AE3601DA623AFC60FFF3058795802CA92371C00097335CF9A23D7782DE353C9DBA93D7BB99E6A24A411107605E722481C5C191F80D7EB77F#)
+ (u #59B45B95AE01A7A7370FAFDB08FE73A4793CE37F228961B09B1B1E7DDAD9F8D3E28F5C5E8B4B067E6B8E0BBF3F690B42991A79E46108DDCDA2514323A66964DE#)))
diff --git a/tests/store.scm b/tests/store.scm
index 281b923c28..4bd739e7f6 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -28,10 +28,12 @@
#:use-module (gnu packages)
#:use-module (gnu packages bootstrap)
#:use-module (ice-9 match)
+ #:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
#:use-module (web uri)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-64))
@@ -344,6 +346,49 @@ Deriver: ~a~%"
(build-derivations s (list d))
#f))))
+(test-assert "export/import several paths"
+ (let* ((texts (unfold (cut >= <> 10)
+ (lambda _ (random-text))
+ 1+
+ 0))
+ (files (map (cut add-text-to-store %store "text" <>) texts))
+ (dump (call-with-bytevector-output-port
+ (cut export-paths %store files <>))))
+ (delete-paths %store files)
+ (and (every (negate file-exists?) files)
+ (let* ((source (open-bytevector-input-port dump))
+ (imported (import-paths %store source)))
+ (and (equal? imported files)
+ (every file-exists? files)
+ (equal? texts
+ (map (lambda (file)
+ (call-with-input-file file
+ get-string-all))
+ files)))))))
+
+(test-assert "import corrupt path"
+ (let* ((text (random-text))
+ (file (add-text-to-store %store "text" text))
+ (dump (call-with-bytevector-output-port
+ (cut export-paths %store (list file) <>))))
+ (delete-paths %store (list file))
+
+ ;; Flip a bit in the stream's payload.
+ (let* ((index (quotient (bytevector-length dump) 4))
+ (byte (bytevector-u8-ref dump index)))
+ (bytevector-u8-set! dump index (logxor #xff byte)))
+
+ (and (not (file-exists? file))
+ (guard (c ((nix-protocol-error? c)
+ (pk 'c c)
+ (and (not (zero? (nix-protocol-error-status c)))
+ (string-contains (nix-protocol-error-message c)
+ "corrupt"))))
+ (let* ((source (open-bytevector-input-port dump))
+ (imported (import-paths %store source)))
+ (pk 'corrupt-imported imported)
+ #f)))))
+
(test-end "store")