Merge branch 'master' into core-updates

2014-01-08 22:06:54 +01:00 · 2014-01-08 22:06:54 +01:00 · 2f265602ff
parent aa6b0d6bf0 1d6816f98c
commit 2f265602ff
62 changed files with 2509 additions and 429 deletions
--- 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))
--- a/.gitignore
+++ b/.gitignore
@ -84,3 +84,4 @@ GPATH
 GRTAGS
 GTAGS
 /nix-setuid-helper
 /nix/scripts/guix-authenticate
--- 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					\
--- a/14
+++ b/14
@ -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)
--- a/2
+++ b/2
@ -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>
--- a/73
+++ b/73
@ -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
-* synchronize package descriptions with GSRC and/or the [[http://directory.fsf.org][FSD]]
+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 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
--- 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"])
--- 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";;
--- 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			\
--- 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.
--- 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		\
--- 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)
+(define find-newest-available-packages
-  "Return a vhash keyed by package names, and with
+  (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
+     ;; FIXME: Currently, the preferred package is whichever one
-  ;; was found last by 'fold-packages'.  Find a better solution.
+     ;; was found last by 'fold-packages'.  Find a better solution.
-  (fold-packages (lambda (p r)
+     (fold-packages (lambda (p r)
-                   (let ((name    (package-name p))
+                      (let ((name    (package-name p))
-                         (version (package-version p)))
+                            (version (package-version p)))
-                     (match (vhash-assoc name r)
+                        (match (vhash-assoc name r)
-                       ((_ newest-so-far . pkgs)
+                          ((_ newest-so-far . pkgs)
-                        (case (version-compare version newest-so-far)
+                           (case (version-compare version newest-so-far)
-                          ((>) (vhash-cons name `(,version ,p) r))
+                             ((>) (vhash-cons name `(,version ,p) r))
-                          ((=) (vhash-cons name `(,version ,p ,@pkgs) r))
+                             ((=) (vhash-cons name `(,version ,p ,@pkgs) r))
-                          ((<) r)))
+                             ((<) r)))
-                       (#f (vhash-cons name `(,version ,p) r)))))
+                          (#f (vhash-cons name `(,version ,p) r)))))
-                 vlist-null))
+                    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 '()))))
--- 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)
--- 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)
--- a/gnu/packages/games.scm
+++ 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+)))
--- 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/")
--- 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)))
--- 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+)))
--- 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.
--- 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")
--- 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))
--- 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)
--- 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
+    (source (origin
-     (origin
+              (method url-fetch)
-      (method url-fetch)
+              (uri (string-append "mirror://gnu/lsh/lsh-"
-      (uri (string-append "mirror://gnu/lsh/lsh-"
+                                  version ".tar.gz"))
-                          version ".tar.gz"))
+              (sha256
-      (sha256
+               (base32
-       (base32
+                "1qqjy9zfzgny0rkb27c8c7dfsylvb6n0ld8h3an2r83pmaqr9gwb"))
-        "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)
+       ("gmp" ,gmp)))
       ("guile" ,guile-final)
       ("gperf" ,gperf)
       ("psmisc" ,psmisc)                         ; for `killall'
       ))
    (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
+        'configure 'pre-configure
-        (lambda _
+        (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"))))
          ;; Tests rely on $USER being set.
-          (setenv "USER" "guix")
+          (setenv "USER" "guix"))
          (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"))))
        %standard-phases)))
    (home-page "http://www.lysator.liu.se/~nisse/lsh/")
    (synopsis "GNU implementation of the Secure Shell (ssh) protocols")
--- 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")
--- 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/")
--- a/gnu/packages/patches/gtkglext-disable-disable-deprecated.patch
+++ 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 = \
--- a/gnu/packages/patches/gtkglext-remove-pangox-dependency.patch
+++ 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@
--- a/gnu/packages/patches/pulseaudio-volume-test.patch
+++ 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
--- 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)
+                 %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)
             '())))
    (inputs
     ;; TODO: Add optional inputs (GTK+?).
     `(;; ("sbc" ,sbc)
--- 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")
--- 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))
--- 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
--- 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
--- 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")
--- 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.
+                           ;; Leave a valid RUNPATH upon install.
-                                     "-DCMAKE_SKIP_BUILD_RPATH=ON")
+                           "-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
--- 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"
--- 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
--- 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@")
--- a/guix/pk-crypto.scm
+++ 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
--- a/guix/pki.scm
+++ 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
--- a/guix/scripts/archive.scm
+++ 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~%")))))))))))
--- a/guix/scripts/authenticate.scm
+++ 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
--- 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
+  #:autoload   (gnu packages) (find-best-packages-by-name)
-                               find-newest-available-packages)
+  #:export (derivation-from-expression
-  #:export (guix-build))
+            guix-build))
-(define %store
+(define (derivation-from-expression store str package-derivation
  (make-parameter #f))
 (define (derivation-from-expression 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)))
@ -90,6 +133,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
      --fallback         fall back to building when the substituter fails"))
  (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"))
@ -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)))
+      (let* ((opts  (parse-options))
-        (define package->derivation
+             (store (open-connection))
-          (match (assoc-ref opts 'target)
+             (drv   (options->derivations store opts))
-            (#f package-derivation)
+             (roots (filter-map (match-lambda
-            (triplet
+                                 (('gc-root . root) root)
-             (cut package-cross-derivation <> <> triplet <>))))
+                                 (_ #f))
                                opts)))
-        (parameterize ((%store (open-connection)))
+        (unless (assoc-ref opts 'log-file?)
-          (let* ((src? (assoc-ref opts 'source?))
+          (show-what-to-build store drv
-                 (sys  (assoc-ref opts 'system))
+                              #:use-substitutes? (assoc-ref opts 'substitutes?)
-                 (drv  (filter-map (match-lambda
+                              #:dry-run? (assoc-ref opts 'dry-run?)))
                                    (('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)))
-            (unless (assoc-ref opts 'log-file?)
+        ;; TODO: Add more options.
-              (show-what-to-build (%store) drv
+        (set-build-options store
-                                  #:use-substitutes? (assoc-ref opts 'substitutes?)
+                           #:keep-failed? (assoc-ref opts 'keep-failed?)
-                                  #:dry-run? (assoc-ref opts 'dry-run?)))
+                           #: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))
-            ;; TODO: Add more options.
+        (cond ((assoc-ref opts 'log-file?)
-            (set-build-options (%store)
+               (for-each (lambda (file)
-                               #:keep-failed? (assoc-ref opts 'keep-failed?)
+                           (let ((log (log-file store file)))
-                               #:build-cores (or (assoc-ref opts 'cores) 0)
+                             (if log
-                               #:fallback? (assoc-ref opts 'fallback?)
+                                 (format #t "~a~%" log)
-                               #:use-substitutes? (assoc-ref opts 'substitutes?)
+                                 (leave (_ "no build log for '~a'~%")
-                               #:max-silent-time (assoc-ref opts 'max-silent-time)
+                                        file))))
-                               #:verbosity (assoc-ref opts 'verbosity))
+                         (delete-duplicates
-
+                          (append (map derivation-file-name drv)
-            (cond ((assoc-ref opts 'log-file?)
+                                  (filter-map (match-lambda
-                   (for-each (lambda (file)
+                                               (('argument
-                               (let ((log (log-file (%store) file)))
+                                                 . (? store-path? file))
-                                 (if log
+                                                file)
-                                     (format #t "~a~%" log)
+                                               (_ #f))
-                                     (leave (_ "no build log for '~a'~%")
+                                              opts)))))
-                                            file))))
+              ((assoc-ref opts 'derivations-only?)
-                             (delete-duplicates
+               (format #t "~{~a~%~}" (map derivation-file-name drv))
-                              (append (map derivation-file-name drv)
+               (for-each (cut register-root store <> <>)
-                                      (filter-map (match-lambda
+                         (map (compose list derivation-file-name) drv)
-                                                   (('argument
+                         roots))
-                                                     . (? store-path? file))
+              ((not (assoc-ref opts 'dry-run?))
-                                                    file)
+               (and (build-derivations store drv)
-                                                   (_ #f))
+                    (for-each (lambda (d)
-                                                  opts)))))
+                                (format #t "~{~a~%~}"
-                  ((assoc-ref opts 'derivations-only?)
+                                        (map (match-lambda
-                   (format #t "~{~a~%~}" (map derivation-file-name drv))
+                                              ((out-name . out)
-                   (for-each (cut register-root <> <>)
+                                               (derivation->output-path
-                             (map (compose list derivation-file-name) drv)
+                                                d out-name)))
-                             roots))
+                                             (derivation-outputs d))))
-                  ((not (assoc-ref opts 'dry-run?))
+                              drv)
-                   (and (build-derivations (%store) drv)
+                    (for-each (cut register-root store <> <>)
-                        (for-each (lambda (d)
+                              (map (lambda (drv)
-                                    (format #t "~{~a~%~}"
+                                     (map cdr
-                                            (map (match-lambda
+                                          (derivation->output-paths drv)))
-                                                  ((out-name . out)
+                                   drv)
-                                                   (derivation->output-path
+                              roots))))))))
                                                    d out-name)))
                                                 (derivation-outputs d))))
                                  drv)
                        (for-each (cut register-root <> <>)
                                  (map (lambda (drv)
                                         (map cdr
                                              (derivation->output-paths drv)))
                                       drv)
                                  roots))))))))))
--- 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
+(define-syntax-rule (leave-on-EPIPE exp ...)
-  (memoize find-newest-available-packages))
+  "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
-(define (find-best-packages-by-name name version)
+may lead to EPIPE, because the standard output is piped through 'head' or
-  "If version is #f, return the list of packages named NAME with the highest
+similar."
-version numbers; otherwise, return the list of packages named NAME and at
+  (catch 'system-error
-VERSION."
+    (lambda ()
-  (if version
+      exp ...)
-      (find-packages-by-name name version)
+    (lambda args
-      (match (vhash-assoc name (newest-available-packages))
+      ;; We really have to exit this brutally, otherwise Guile eventually
-        ((_ version pkgs ...) pkgs)
+      ;; attempts to flush all the ports, leading to an uncaught EPIPE down
-        (#f '()))))
+      ;; 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))
+                  (leave-on-EPIPE
-                      (exit 0)
+                   (if (equal? numbers '(0))
-                      (for-each list-generation numbers))))
+                       (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
+           (leave-on-EPIPE
-                      (($ <manifest-entry> name version output path _)
+            (for-each (match-lambda
-                       (when (or (not regexp)
+                       (($ <manifest-entry> name version output path _)
-                                 (regexp-exec regexp name))
+                        (when (or (not regexp)
-                         (format #t "~a\t~a\t~a\t~a~%"
+                                  (regexp-exec regexp name))
-                                 name (or version "?") output path))))
+                          (format #t "~a\t~a\t~a\t~a~%"
                                  name (or version "?") output path))))
-                     ;; Show most recently installed packages last.
+                      ;; Show most recently installed packages last.
-                     (reverse installed))
+                      (reverse installed)))
           #t))
        (('list-available regexp)
@ -1010,16 +1017,17 @@ more information.~%"))
                                        r)
                                    (cons p r))))
                            '())))
-           (for-each (lambda (p)
+           (leave-on-EPIPE
-                       (format #t "~a\t~a\t~a\t~a~%"
+            (for-each (lambda (p)
-                               (package-name p)
+                        (format #t "~a\t~a\t~a\t~a~%"
-                               (package-version p)
+                                (package-name p)
-                               (string-join (package-outputs p) ",")
+                                (package-version p)
-                               (location->string (package-location p))))
+                                (string-join (package-outputs p) ",")
-                     (sort available
+                                (location->string (package-location p))))
-                           (lambda (p1 p2)
+                      (sort available
-                             (string<? (package-name p1)
+                            (lambda (p1 p2)
-                                       (package-name p2)))))
+                              (string<? (package-name p1)
                                        (package-name p2))))))
           #t))
        (('search regexp)
--- 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:
--- 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)
+  (string-append %state-directory "/daemon-socket/socket"))
                 "/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 a byte stream from USER-PORT.
-             (read-latin1-string p)               ; FIXME: what to do?
+           (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)
+  (make-parameter %store-directory))
                      %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))
+         (let* ((base    (basename file))
-                (log  (string-append (dirname state-dir) ; XXX: ditto
+                (log     (string-append (dirname %state-directory) ; XXX
-                                     "/log/nix/drvs/"
+                                        "/log/nix/drvs/"
-                                     (string-take base 2) "/"
+                                        (string-take base 2) "/"
-                                     (string-drop base 2) ".bz2")))
+                                        (string-drop base 2)))
-           (and (file-exists? log) log)))
+                (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 ...)
--- 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)
--- 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;
 }
 }
--- 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);
 }
--- 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;
--- a/nix/scripts/guix-authenticate.in
+++ 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
--- 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'
--- 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
--- 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"
--- a/tests/guix-archive.sh
+++ 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
--- a/tests/guix-authenticate.sh
+++ 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
--- 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"`" = ""
--- a/tests/pk-crypto.scm
+++ 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))
--- a/tests/pki.scm
+++ 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))
--- a/tests/signing-key.pub
+++ b/tests/signing-key.pub
@ -0,0 +1,4 @@
 (public-key
 (rsa
  (n #00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45#)
  (e #010001#)))
--- a/tests/signing-key.sec
+++ b/tests/signing-key.sec
@ -0,0 +1,8 @@
 (private-key
 (rsa
  (n #00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45#)
  (e #010001#)
  (d #58CAD84653D0046A8EC3F9AA82D9C829B145422109FC3F12DA01A694B92FA296E70D366FB166454D30E632CEE3A033B4C41781BA10325F69FCDC0250CA19C8EEB352FA085992494098DB133E682ED38A931701F0DED1A1E508F4341A4FB446A04F019427C7CB3C44F251EEA9D386100DA80F125E0FD5CE1B0DFEC6D21516EACD#)
  (p #00D47F185147EC39393CCDA4E7323FFC20FC8B8073E2A54DD63BA392A66975E4204CA48572496A9DFD7522436B852C07472A5AB25B7706F7C14E6F33FBC420FF3B#)
  (q #00E9AD22F158060BC9AE3601DA623AFC60FFF3058795802CA92371C00097335CF9A23D7782DE353C9DBA93D7BB99E6A24A411107605E722481C5C191F80D7EB77F#)
  (u #59B45B95AE01A7A7370FAFDB08FE73A4793CE37F228961B09B1B1E7DDAD9F8D3E28F5C5E8B4B067E6B8E0BBF3F690B42991A79E46108DDCDA2514323A66964DE#)))
--- 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")