Merge branch 'master' into core-updates

.gitignore

@@ -76,3 +76,4 @@ stamp-h[0-9]
 /nix/scripts/substitute-binary
 /doc/images/bootstrap-graph.png
 /doc/images/bootstrap-graph.eps
+/guix-register

Makefile.am

@@ -117,6 +117,13 @@ SH_TESTS =					\
   tests/guix-hash.sh				\
   tests/guix-package.sh
 
+if BUILD_DAEMON
+
+SH_TESTS += tests/guix-register.sh
+
+endif BUILD_DAEMON
+
+
 TESTS = $(SCM_TESTS) $(SH_TESTS)
 
 TEST_EXTENSIONS = .scm .sh

THANKS

@@ -15,6 +15,9 @@ infrastructure help:
       Rafael Ferreira <rafael.f.f1@gmail.com>
    Christian Grothoff <christian@grothoff.org>
      Matthew Lien <bluet@bluet.org>
+      Yutaka Niibe <gniibe@fsij.org>
         Alex Sassmannshausen <alex.sassmannshausen@gmail.com>
+      Cyrill Schenkel <cyrill.schenkel@gmail.com>
        Jason Self <jself@gnu.org>
         Alen Skondro <askondro@gmail.com>
+    Matthias Wachs <wachs@net.in.tum.de>

build-aux/check-available-binaries.scm

@@ -49,7 +49,7 @@
             #f))))
 
   (let ((result (every (compose (warn (cut has-substitutes? store <>))
-                                derivation-path->output-path)
+                                derivation->output-path)
                        total)))
     (when result
       (format (current-error-port) "~a packages found substitutable~%"

build-aux/hydra/gnu-system.scm

@@ -38,6 +38,7 @@
 
 (use-modules (guix store)
              (guix packages)
+             (guix derivations)
              ((guix utils) #:select (%current-system))
              (gnu packages)
              (gnu packages base)
@@ -58,7 +59,8 @@
 (define* (package->alist store package system
                          #:optional (package-derivation package-derivation))
   "Convert PACKAGE to an alist suitable for Hydra."
-  `((derivation . ,(package-derivation store package system))
+  `((derivation . ,(derivation-file-name
+                    (package-derivation store package system)))
     (description . ,(package-synopsis package))
     (long-description . ,(package-description package))
     (license . ,(package-license package))

build-aux/hydra/guix.scm

@@ -40,6 +40,7 @@
 (use-modules (guix store)
              (guix packages)
              (guix utils)
+             (guix derivations)
              (guix build-system gnu)
              (gnu packages version-control)
              (gnu packages package-management)
@@ -56,14 +57,15 @@
 (define* (package->alist store package system
                          #:optional (package-derivation package-derivation))
   "Convert PACKAGE to an alist suitable for Hydra."
-  `((derivation . ,(package-derivation store package system))
+  `((derivation . ,(derivation-file-name
+                    (package-derivation store package system)))
     (description . ,(package-synopsis package))
     (long-description . ,(package-description package))
     (license . ,(package-license package))
     (home-page . ,(package-home-page package))
     (maintainers . ("bug-guix@gnu.org"))))
 
-(define (tarball-package checkout)
+(define (tarball-package checkout nix-checkout)
   "Return a package that does `make distcheck' from CHECKOUT, a directory
 containing a Git checkout of Guix."
   (let ((dist (dist-package guix checkout)))
@@ -72,12 +74,12 @@ containing a Git checkout of Guix."
       (arguments (substitute-keyword-arguments (package-arguments dist)
                    ((#:phases p)
                     `(alist-cons-before
-                      'autoreconf 'patch-bootstrap-script
+                      'autoreconf 'set-nix-submodule
                       (lambda _
-                        ;; Comment out `git' invocations, since Hydra provides
+                        ;; Tell Git to use the Nix checkout that Hydra gave us.
-                        ;; us with a checkout that includes sub-modules.
+                        (zero?
-                        (substitute* "bootstrap"
+                         (system* "git" "config" "submodule.nix-upstream.url"
-                          (("git ") "true git ")))
+                                  ,nix-checkout)))
                       ,p))))
       (native-inputs `(("git" ,git)
                        ("graphviz" ,graphviz)
@@ -96,11 +98,16 @@ containing a Git checkout of Guix."
       (_
        (list (%current-system)))))
 
-  (define checkout
+  (define guix-checkout
     (assq-ref arguments 'guix))
 
-  (format (current-error-port) "using checkout ~s~%" checkout)
+  (define nix-checkout
-  (let ((directory (assq-ref checkout 'file-name)))
+    (assq-ref arguments 'nix))
+
+  (format (current-error-port) "using checkout ~s (Nix: ~s)~%"
+          guix-checkout nix-checkout)
+  (let ((guix (assq-ref guix-checkout 'file-name))
+        (nix  (assq-ref nix-checkout 'file-name)))
     `((tarball . ,(cute package->alist store
-                        (tarball-package directory)
+                        (tarball-package guix nix)
                         (%current-system))))))

daemon.am

@@ -25,6 +25,8 @@ CLEANFILES += $(BUILT_SOURCES)
 
 noinst_LIBRARIES = libformat.a libutil.a libstore.a
 
+AM_CXXFLAGS = -Wall
+
 libformat_a_SOURCES =				\
   nix/boost/format/free_funcs.cc		\
   nix/boost/format/parsing.cc			\
@@ -119,6 +121,7 @@ libstore_a_CXXFLAGS =				\
   $(SQLITE3_CFLAGS) $(LIBGCRYPT_CFLAGS)
 
 bin_PROGRAMS = guix-daemon
+sbin_PROGRAMS = guix-register
 
 guix_daemon_SOURCES =				\
   nix/nix-daemon/nix-daemon.cc			\
@@ -135,6 +138,21 @@ guix_daemon_LDADD =				\
 guix_daemon_headers =				\
   nix/nix-daemon/shared.hh
 
+
+guix_register_SOURCES =				\
+  nix/guix-register/guix-register.cc
+
+guix_register_CPPFLAGS =			\
+  $(libutil_a_CPPFLAGS)				\
+  $(libstore_a_CPPFLAGS)			\
+  -I$(top_srcdir)/nix/libstore
+
+# XXX: Should we start using shared libs?
+guix_register_LDADD =				\
+  libstore.a libutil.a libformat.a -lbz2	\
+  $(SQLITE3_LIBS) $(LIBGCRYPT_LIBS)
+
+
 libexec_PROGRAMS = nix-setuid-helper
 nix_setuid_helper_SOURCES =			\
   nix/nix-setuid-helper/nix-setuid-helper.cc

doc/guix.texi

@@ -659,9 +659,9 @@ version: 7.2alpha6
 
 @item --list-installed[=@var{regexp}]
 @itemx -I [@var{regexp}]
-List currently installed packages in the specified profile.  When
+List the currently installed packages in the specified profile, with the
-@var{regexp} is specified, list only installed packages whose name
+most recently installed packages shown last.  When @var{regexp} is
-matches @var{regexp}.
+specified, list only installed packages whose name matches @var{regexp}.
 
 For each installed package, print the following items, separated by
 tabs: the package name, its version string, the part of the package that
@@ -679,6 +679,41 @@ For each package, print the following items separated by tabs: its name,
 its version string, the parts of the package (@pxref{Packages with
 Multiple Outputs}), and the source location of its definition.
 
+@item --list-generations[=@var{pattern}]
+@itemx -l [@var{pattern}]
+Return a list of generations along with their creation dates; for each
+generation, show the installed packages, with the most recently
+installed packages shown last.
+
+For each installed package, print the following items, separated by
+tabs: the name of a package, its version string, the part of the package
+that is installed (@pxref{Packages with Multiple Outputs}), and the
+location of this package in the store.
+
+When @var{pattern} is used, the command returns only matching
+generations.  Valid patterns include:
+
+@itemize
+@item @emph{Integers and comma-separated integers}.  Both patterns denote
+generation numbers.  For instance, @code{--list-generations=1} returns
+the first one.
+
+And @code{--list-generations=1,8,2} outputs three generations in the
+specified order.  Neither spaces nor trailing commas are allowed.
+
+@item @emph{Ranges}.  @code{--list-generations=2..9} prints the
+specified generations and everything in between.  Note that the start of
+a range must be lesser than its end.
+
+It is also possible to omit the endpoint.  For example,
+@code{--list-generations=2..}, returns all generations starting from the
+second one.
+
+@item @emph{Durations}.  You can also get the last @emph{N}@tie{}days, weeks,
+or months by passing an integer along with the first letter of the
+duration, e.g., @code{--list-generations=20d}.
+@end itemize
+
 @end table
 
 @node Packages with Multiple Outputs
@@ -987,8 +1022,8 @@ The build actions it prescribes may then be realized by using the
 @code{build-derivations} procedure (@pxref{The Store}).
 
 @deffn {Scheme Procedure} package-derivation @var{store} @var{package} [@var{system}]
-Return the derivation path and corresponding @code{<derivation>} object
+Return the @code{<derivation>} object of @var{package} for @var{system}
-of @var{package} for @var{system} (@pxref{Derivations}).
+(@pxref{Derivations}).
 
 @var{package} must be a valid @code{<package>} object, and @var{system}
 must be a string denoting the target system type---e.g.,
@@ -1004,8 +1039,8 @@ package for some other system:
 
 @deffn {Scheme Procedure} package-cross-derivation @var{store} @
             @var{package} @var{target} [@var{system}]
-Return the derivation path and corresponding @code{<derivation>} object
+Return the @code{<derivation>} object of @var{package} cross-built from
-of @var{package} cross-built from @var{system} to @var{target}.
+@var{system} to @var{target}.
 
 @var{target} must be a valid GNU triplet denoting the target hardware
 and operating system, such as @code{"mips64el-linux-gnu"}
@@ -1061,15 +1096,16 @@ argument.
 Return @code{#t} when @var{path} is a valid store path.
 @end deffn
 
-@deffn {Scheme Procedure} add-text-to-store @var{server} @var{name} @var{text} @var{references}
+@deffn {Scheme Procedure} add-text-to-store @var{server} @var{name} @var{text} [@var{references}]
 Add @var{text} under file @var{name} in the store, and return its store
 path.  @var{references} is the list of store paths referred to by the
 resulting store path.
 @end deffn
 
 @deffn {Scheme Procedure} build-derivations @var{server} @var{derivations}
-Build @var{derivations} (a list of derivation paths), and return when
+Build @var{derivations} (a list of @code{<derivation>} objects or
-the worker is done building them.  Return @code{#t} on success.
+derivation paths), and return when the worker is done building them.
+Return @code{#t} on success.
 @end deffn
 
 @c FIXME
@@ -1119,8 +1155,8 @@ otherwise manipulate derivations.  The lowest-level primitive to create
 a derivation is the @code{derivation} procedure:
 
 @deffn {Scheme Procedure} derivation @var{store} @var{name} @var{builder} @var{args} [#:outputs '("out")] [#:hash #f] [#:hash-algo #f] [#:hash-mode #f] [#:inputs '()] [#:env-vars '()] [#:system (%current-system)] [#:references-graphs #f]
-Build a derivation with the given arguments.  Return the resulting store
+Build a derivation with the given arguments, and return the resulting
-path and @code{<derivation>} object.
+@code{<derivation>} object.
 
 When @var{hash}, @var{hash-algo}, and @var{hash-mode} are given, a
 @dfn{fixed-output derivation} is created---i.e., one whose result is
@@ -1142,16 +1178,13 @@ to a Bash executable in the store:
              (guix store)
              (guix derivations))
 
-(call-with-values
+(let ((builder   ; add the Bash script to the store
-  (lambda ()
+        (add-text-to-store store "my-builder.sh"
-    (let ((builder   ; add the Bash script to the store
+                           "echo hello world > $out\n" '())))
-           (add-text-to-store store "my-builder.sh"
+  (derivation store "foo"
-                              "echo hello world > $out\n" '())))
+              bash `("-e" ,builder)
-      (derivation store "foo"
+              #:env-vars '(("HOME" . "/homeless"))))
-                  bash `("-e" ,builder)
+@result{} #<derivation /nix/store/@dots{}-foo.drv => /nix/store/@dots{}-foo>
-                  #:env-vars '(("HOME" . "/homeless")))))
-  list)
-@result{} ("/nix/store/@dots{}-foo.drv" #<<derivation> @dots{}>)
 @end lisp
 
 As can be guessed, this primitive is cumbersome to use directly.  An
@@ -1196,8 +1229,7 @@ containing one file:
   (build-expression->derivation store "goo" (%current-system)
                                 builder '()))
 
-@result{} "/nix/store/@dots{}-goo.drv"
+@result{} #<derivation /nix/store/@dots{}-goo.drv => @dots{}>
-@result{} #<<derivation> @dots{}>
 @end lisp
 
 @cindex strata of code

gnu-system.am

@@ -69,6 +69,7 @@ GNU_SYSTEM_MODULES =				\
   gnu/packages/gkrellm.scm			\
   gnu/packages/glib.scm				\
   gnu/packages/global.scm			\
+  gnu/packages/gnome.scm			\
   gnu/packages/gnunet.scm			\
   gnu/packages/gnupg.scm			\
   gnu/packages/gnutls.scm			\
@@ -79,6 +80,7 @@ GNU_SYSTEM_MODULES =				\
   gnu/packages/grub.scm				\
   gnu/packages/grue-hunter.scm			\
   gnu/packages/gsasl.scm			\
+  gnu/packages/gstreamer.scm			\
   gnu/packages/gtk.scm				\
   gnu/packages/guile.scm			\
   gnu/packages/gv.scm				\
@@ -113,7 +115,7 @@ GNU_SYSTEM_MODULES =				\
   gnu/packages/lua.scm				\
   gnu/packages/lvm.scm				\
   gnu/packages/m4.scm				\
-  gnu/packages/mailutils.scm			\
+  gnu/packages/mail.scm				\
   gnu/packages/make-bootstrap.scm		\
   gnu/packages/maths.scm			\
   gnu/packages/mit-krb5.scm			\
@@ -179,17 +181,24 @@ GNU_SYSTEM_MODULES =				\
   gnu/packages/yasm.scm				\
   gnu/packages/zile.scm				\
   gnu/packages/zip.scm				\
+						\
+  gnu/system/dmd.scm				\
+  gnu/system/grub.scm				\
+  gnu/system/linux.scm				\
+  gnu/system/shadow.scm				\
   gnu/system/vm.scm
 
 patchdir = $(guilemoduledir)/gnu/packages/patches
 dist_patch_DATA =						\
   gnu/packages/patches/apr-skip-getservbyname-test.patch	\
   gnu/packages/patches/automake-skip-amhello-tests.patch	\
+  gnu/packages/patches/avahi-localstatedir.patch		\
   gnu/packages/patches/bigloo-gc-shebangs.patch			\
   gnu/packages/patches/binutils-ld-new-dtags.patch		\
   gnu/packages/patches/cdparanoia-fpic.patch			\
   gnu/packages/patches/cmake-fix-tests.patch			\
   gnu/packages/patches/cpio-gets-undeclared.patch		\
+  gnu/packages/patches/dbus-localstatedir.patch			\
   gnu/packages/patches/diffutils-gets-undeclared.patch		\
   gnu/packages/patches/emacs-configure-sh.patch			\
   gnu/packages/patches/findutils-absolute-paths.patch		\
@@ -203,7 +212,6 @@ dist_patch_DATA =						\
   gnu/packages/patches/glibc-bootstrap-system.patch		\
   gnu/packages/patches/glibc-ldd-x86_64.patch			\
   gnu/packages/patches/glibc-no-ld-so-cache.patch		\
-  gnu/packages/patches/gnutls-fix-tests-on-32-bits-system.patch	\
   gnu/packages/patches/grub-gets-undeclared.patch		\
   gnu/packages/patches/guile-1.8-cpp-4.5.patch			\
   gnu/packages/patches/guile-default-utf8.patch			\

gnu/packages/avahi.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 gdbm)
   #:use-module (gnu packages libdaemon)
   #:use-module (gnu packages pkg-config)
@@ -42,13 +43,15 @@
     (build-system gnu-build-system)
     (arguments
      '(#:configure-flags '("--with-distro=none"
+                           "--localstatedir=/var" ; for the DBus socket
                            "--disable-python"
                            "--disable-mono"
                            "--disable-doxygen-doc"
                            "--disable-xmltoman"
                            "--enable-tests"
                            "--disable-qt3" "--disable-qt4"
-                           "--disable-gtk" "--disable-gtk3")))
+                           "--disable-gtk" "--disable-gtk3")
+       #:patches (list (assoc-ref %build-inputs "patch/localstatedir"))))
     (inputs
      `(("expat" ,expat)
        ("glib" ,glib)
@@ -56,7 +59,10 @@
        ("libdaemon" ,libdaemon)
        ("intltool" ,intltool)
        ("pkg-config" ,pkg-config)
-       ("gdbm" ,gdbm)))
+       ("gdbm" ,gdbm)
+
+       ("patch/localstatedir"
+        ,(search-patch "avahi-localstatedir.patch"))))
     (synopsis "Avahi, an mDNS/DNS-SD implementation")
     (description
      "Avahi is a system which facilitates service discovery on a local

gnu/packages/cryptsetup.scm

@@ -45,7 +45,7 @@
     `(("libgcrypt" ,libgcrypt)
       ("lvm2" ,lvm2)
       ("popt" ,popt)
-      ("python" ,python)
+      ("python" ,python-wrapper)
       ("util-linux" ,util-linux)))
    (synopsis "hard disk encryption tool")
    (description

gnu/packages/gdb.scm

@@ -53,7 +53,7 @@
        ("gmp" ,gmp)
        ("readline" ,readline)
        ("ncurses" ,ncurses)
-       ("python" ,python)
+       ("python" ,python-wrapper)
        ("texinfo" ,texinfo)
        ("dejagnu" ,dejagnu)))
     (home-page "http://www.gnu.org/software/gdb/")

gnu/packages/ghostscript.scm

@@ -136,7 +136,7 @@ printing, and psresize, for adjusting page sizes.")
              ("libtiff" ,libtiff)
              ("perl" ,perl)
              ("pkg-config" ,pkg-config) ; needed to find libtiff
-             ("python" ,python)
+             ("python" ,python-wrapper)
              ("tcl" ,tcl)
              ("zlib" ,zlib)))
    (arguments

gnu/packages/glib.scm

@@ -35,9 +35,18 @@
   #:use-module (gnu packages python)
   #:use-module (gnu packages xml)
   #:use-module (gnu packages bash)
-  #:use-module (gnu packages file))
+  #:use-module (gnu packages file)
+  #:use-module (gnu packages xorg)
 
-(define-public dbus
+  ;; Export variables up-front to allow circular dependency with the 'xorg'
+  ;; module.
+  #:export (dbus
+            glib
+            dbus-glib
+            intltool
+            itstool))
+
+(define dbus
   (package
     (name "dbus")
     (version "1.6.4")
@@ -50,9 +59,26 @@
               (base32
                "1wacqyfkcpayg7f8rvx9awqg275n5pksxq5q7y21lxjx85x6pfjz"))))
     (build-system gnu-build-system)
+    (arguments
+     '(#:configure-flags (list ;; Install the system bus socket under /var.
+                               "--localstatedir=/var"
+
+                               ;; XXX: Fix the following to allow system-wide
+                               ;; config.
+                               ;; "--sysconfdir=/etc"
+
+                               "--with-session-socket-dir=/tmp")
+       #:patches (list (assoc-ref %build-inputs "patch/localstatedir"))))
     (inputs
      `(("expat" ,expat)
-       ("pkg-config" ,pkg-config)))
+       ("pkg-config" ,pkg-config)
+       ("patch/localstatedir"
+        ,(search-patch "dbus-localstatedir.patch"))
+
+       ;; Add a dependency on libx11 so that 'dbus-launch' has support for
+       ;; '--autolaunch'.
+       ("libx11" ,libx11)))
+
     (home-page "http://dbus.freedesktop.org/")
     (synopsis "Message bus for inter-process communication (IPC)")
     (description
@@ -73,7 +99,7 @@ or through unencrypted TCP/IP suitable for use behind a firewall with
 shared NFS home directories.")
     (license license:gpl2+)))                     ; or Academic Free License 2.1
 
-(define-public glib
+(define glib
   (package
    (name "glib")
    (version "2.37.1")
@@ -92,7 +118,7 @@ shared NFS home directories.")
       ("gettext" ,guix:gettext)
       ("libffi" ,libffi)
       ("pkg-config" ,pkg-config)
-      ("python" ,python)
+      ("python" ,python-wrapper)
       ("zlib" ,zlib)
       ("perl" ,perl)                              ; needed by GIO tests
       ("dbus" ,dbus)                              ; for GDBus tests
@@ -145,7 +171,7 @@ dynamic loading, and an object system.")
    (home-page "http://developer.gnome.org/glib/")
    (license license:lgpl2.0+)))                        ; some files are under lgpl2.1+
 
-(define-public intltool
+(define intltool
   (package
     (name "intltool")
     (version "0.50.2")
@@ -186,7 +212,7 @@ The intltool collection can be used to do these things:
     oaf files. This merge step will happen at build resp. installation time.")
     (license license:gpl2+)))
 
-(define-public itstool
+(define itstool
   (package
     (name "itstool")
     (version "1.2.0")
@@ -220,7 +246,7 @@ information in their documents, such as whether a particular element should be
 translated.")
     (license license:gpl3+)))
 
-(define-public dbus-glib
+(define dbus-glib
   (package
     (name "dbus-glib")
     (version "0.100.2")

gnu/packages/gnome.scm

@@ -0,0 +1,57 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
+;;;
+;;; 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 gnome)
+  #:use-module ((guix licenses) #:select (gpl2+))
+  #:use-module (guix packages)
+  #:use-module (guix download)
+  #:use-module (guix build-system gnu)
+  #:use-module (gnu packages glib)
+  #:use-module (gnu packages pkg-config)
+  #:use-module (gnu packages python)
+  #:use-module (gnu packages xml))
+
+(define-public gnome-doc-utils
+  (package
+    (name "gnome-doc-utils")
+    (version "0.20.10")
+    (source
+     (origin
+      (method url-fetch)
+      (uri (string-append "mirror://gnome/sources/" name "/0.20/"
+                          name "-" version ".tar.xz"))
+      (sha256
+       (base32
+        "19n4x25ndzngaciiyd8dd6s2mf9gv6nv3wv27ggns2smm7zkj1nb"))))
+    (build-system gnu-build-system)
+    (inputs
+     `(("intltool" ,intltool)
+       ("libxml2" ,libxml2)
+       ("libxslt" ,libxslt)
+       ("pkg-config" ,pkg-config)
+       ("python-2" ,python-2)))
+    (arguments
+     `(#:tests? #f)) ; tries to load http://www.oasis-open.org/docbook/xml/4.4/docbookx.dtd
+    (home-page "https://wiki.gnome.org/GnomeDocUtils")
+    (synopsis
+     "Documentation utilities for the Gnome project")
+    (description
+     "Gnome-doc-utils is a collection of documentation utilities for the
+Gnome project.  It includes xml2po tool which makes it easier to translate
+and keep up to date translations of documentation.")
+    (license gpl2+))) ; xslt under lgpl

gnu/packages/gnupg.scm

@@ -191,7 +191,7 @@ S/MIME.")
                      "1g1jly3wl4ks6h8ydkygyl2c4i7v3z91rg42005m6vm70y1d8b3d"))))
    (build-system gnu-build-system)
    (inputs `(("perl" ,perl)
-             ("python" ,python)
+             ("python" ,python-wrapper)
              ("gpg" ,gnupg)))
    (arguments
     `(#:tests? #f

gnu/packages/gnutls.scm

@@ -54,7 +54,7 @@ portable, and only require an ANSI C89 platform.")
 (define-public gnutls
   (package
     (name "gnutls")
-    (version "3.2.1")
+    (version "3.2.4")
     (source (origin
              (method url-fetch)
              (uri
@@ -64,20 +64,14 @@ portable, and only require an ANSI C89 platform.")
                              version ".tar.xz"))
              (sha256
               (base32
-               "1zi2kq3vcbqdy9khl7r6pgk4hgwibniasm9k6siasdvqjijq3ymb"))))
+               "0zvhzy87v9dfxfvmg1pl951kw55rp647cqdza8942fxq7spp158i"))))
     (build-system gnu-build-system)
-    (arguments
-      `(#:patches (list (assoc-ref %build-inputs
-                                   "patch/fix-tests"))
-        #:patch-flags '("-p0")))
     (native-inputs
      `(("pkg-config" ,pkg-config)))
     (inputs
      `(("guile" ,guile-2.0)
        ("zlib" ,guix:zlib)
-       ("perl" ,perl)
+       ("perl" ,perl)))
-       ("patch/fix-tests"
-        ,(search-patch "gnutls-fix-tests-on-32-bits-system.patch"))))
     (propagated-inputs
      `(("libtasn1" ,libtasn1)
        ("nettle" ,nettle)

gnu/packages/grub.scm

@@ -19,9 +19,6 @@
 (define-module (gnu packages grub)
   #:use-module (guix download)
   #:use-module (guix packages)
-  #:use-module (guix records)
-  #:use-module (guix store)
-  #:use-module (guix derivations)
   #:use-module ((guix licenses) #:select (gpl3+))
   #:use-module (guix build-system gnu)
   #:use-module (gnu packages)
@@ -33,11 +30,7 @@
   #:use-module (gnu packages qemu)
   #:use-module (gnu packages ncurses)
   #:use-module (gnu packages cdrom)
-  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-1))
-  #:use-module (ice-9 match)
-  #:export (menu-entry
-            menu-entry?
-            grub-configuration-file))
 
 (define qemu-for-tests
   ;; Newer QEMU versions, such as 1.5.1, no longer support the 'shutdown'
@@ -117,56 +110,3 @@ computer starts.  It is responsible for loading and transferring control to
 the operating system kernel software (such as the Hurd or the Linux).  The
 kernel, in turn, initializes the rest of the operating system (e.g., GNU).")
     (license gpl3+)))
-
-
-;;;
-;;; Configuration.
-;;;
-
-(define-record-type* <menu-entry>
-  menu-entry make-menu-entry
-  menu-entry?
-  (label           menu-entry-label)
-  (linux           menu-entry-linux)
-  (linux-arguments menu-entry-linux-arguments
-                   (default '()))
-  (initrd          menu-entry-initrd))
-
-(define* (grub-configuration-file store entries
-                                  #:key (default-entry 1) (timeout 5)
-                                  (system (%current-system)))
-  "Return the GRUB configuration file in STORE for ENTRIES, a list of
-<menu-entry> objects, defaulting to DEFAULT-ENTRY and with the given TIMEOUT."
-  (define prologue
-    (format #f "
-set default=~a
-set timeout=~a
-search.file ~a~%"
-            default-entry timeout
-            (any (match-lambda
-                  (($ <menu-entry> _ linux)
-                   (let* ((drv (package-derivation store linux system))
-                          (out (derivation-path->output-path drv)))
-                     (string-append out "/bzImage"))))
-                 entries)))
-
-  (define entry->text
-    (match-lambda
-     (($ <menu-entry> label linux arguments initrd)
-      (let ((linux-drv  (package-derivation store linux system))
-            (initrd-drv (package-derivation store initrd system)))
-        ;; XXX: Assume that INITRD is a directory containing an 'initrd' file.
-        (format #f "menuentry ~s {
-  linux ~a/bzImage ~a
-  initrd ~a/initrd
-}~%"
-                label
-                (derivation-path->output-path linux-drv)
-                (string-join arguments)
-                (derivation-path->output-path initrd-drv))))))
-
-  (add-text-to-store store "grub.cfg"
-                     (string-append prologue
-                                    (string-concatenate
-                                     (map entry->text entries)))
-                     '()))

gnu/packages/gstreamer.scm

@@ -0,0 +1,109 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
+;;;
+;;; 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 gstreamer)
+  #:use-module ((guix licenses) #:select (lgpl2.0+))
+  #:use-module (guix packages)
+  #:use-module (guix download)
+  #:use-module (guix build-system gnu)
+  #:use-module (gnu packages bison)
+  #:use-module (gnu packages flex)
+  #:use-module (gnu packages glib)
+  #:use-module (gnu packages perl)
+  #:use-module (gnu packages pkg-config)
+  #:use-module (gnu packages python))
+
+(define-public gstreamer
+  (package
+    (name "gstreamer")
+    (version "1.0.10")
+    (source
+     (origin
+      (method url-fetch)
+      (uri (string-append "http://gstreamer.freedesktop.org/src/gstreamer/gstreamer-"
+                          version ".tar.xz"))
+      (sha256
+       (base32
+        "0c0irk85jd2cihm5pmf4zxhlpg08qpxjcqv1l9qn2n3h2gsaj2lf"))))
+    (build-system gnu-build-system)
+    (inputs
+     `(("bison" ,bison)
+       ("flex" ,flex)
+       ("glib" ,glib)
+       ("perl" ,perl)
+       ("pkg-config" ,pkg-config)
+       ("python-wrapper" ,python-wrapper)))
+    (home-page "http://gstreamer.freedesktop.org/")
+    (synopsis
+     "Multimedia library")
+    (description
+     "GStreamer is a library for constructing graphs of media-handling
+components.  The applications it supports range from simple Ogg/Vorbis
+playback, audio/video streaming to complex audio (mixing) and video
+(non-linear editing) processing.
+
+Applications can take advantage of advances in codec and filter technology
+transparently.  Developers can add new codecs and filters by writing a
+simple plugin with a clean, generic interface.
+
+This package provides the core library and elements.")
+    (license lgpl2.0+)))
+
+(define-public gst-plugins-base
+  (package
+    (name "gst-plugins-base")
+    (version "1.0.10")
+    (source
+     (origin
+      (method url-fetch)
+      (uri (string-append "http://gstreamer.freedesktop.org/src/gst-plugins-base/gst-plugins-base-"
+                          version ".tar.xz"))
+      (sha256
+       (base32
+        "1s4pphbb5kpdh4rrmb8rala4sp499k4by59925k15xiz58xyhm4p"))))
+    (build-system gnu-build-system)
+    ;; FIXME: Add more dependencies for further plugins.
+    (inputs
+     `(("glib" ,glib)
+       ("gstreamer" ,gstreamer)
+       ("pkg-config" ,pkg-config)
+       ("python-wrapper" ,python-wrapper)))
+    (arguments
+     `(#:tests? #f))
+      ;; All tests pass except for one:
+      ;; Running suite(s): pbutils library
+      ;; 85%: Checks: 7, Failures: 1, Errors: 0
+      ;; libs/pbutils.c:522:F:general:test_pb_utils_install_plugins:0: gst_install_plugins_sync() failed ;; with unexpected ret 201, which is neither HELPER_MISSING nor 1
+      ;; FAIL: libs/pbutils
+      ;; According to the documentation, "gst_install_plugins_sync (...)
+      ;; should almost never be used".
+    (home-page "http://gstreamer.freedesktop.org/")
+    (synopsis
+     "Plugins for the gstreamer multimedia library")
+    (description
+     "GStreamer is a library for constructing graphs of media-handling
+components.  The applications it supports range from simple Ogg/Vorbis
+playback, audio/video streaming to complex audio (mixing) and video
+(non-linear editing) processing.
+
+Applications can take advantage of advances in codec and filter technology
+transparently.  Developers can add new codecs and filters by writing a
+simple plugin with a clean, generic interface.
+
+This package provides an essential exemplary set of elements.")
+    (license lgpl2.0+)))

gnu/packages/gtk.scm

@@ -83,7 +83,7 @@ tools have full access to view and control running applications.")
       ("libspectre" ,libspectre)
       ("pkg-config" ,pkg-config)
       ("poppler" ,poppler)
-      ("python" ,python)
+      ("python" ,python-wrapper)
       ("xextproto" ,xextproto)
       ("zlib" ,zlib)))
     (arguments
@@ -123,7 +123,7 @@ affine transformation (scale, rotation, shear, etc.)")
     `(("cairo" ,cairo)
       ("icu4c" ,icu4c)
       ("pkg-config" ,pkg-config)
-      ("python" ,python)))
+      ("python" ,python-wrapper)))
    (synopsis "opentype text shaping engine")
    (description
     "HarfBuzz is an OpenType text shaping engine.")

gnu/packages/libevent.scm

@@ -44,7 +44,7 @@
 
        ;; Dependencies used for the tests and for `event_rpcgen.py'.
        ("which" ,which)
-       ("python" ,python)))
+       ("python" ,python-wrapper)))
     (arguments
      '(#:patches (list (assoc-ref %build-inputs "patch/dns-tests"))))
     (home-page "http://libevent.org/")

gnu/packages/linux-initrd.scm

@@ -386,7 +386,8 @@ the Linux kernel.")
               (chroot "/root")
               (primitive-load to-load)
               (format (current-error-port)
-                      "boot program '~a' terminated, rebooting~%")
+                      "boot program '~a' terminated, rebooting~%"
+                      to-load)
               (sleep 2)
               (reboot))
             (begin

gnu/packages/linux.scm

@@ -214,6 +214,11 @@
     (license gpl2)
     (home-page "http://www.gnu.org/software/linux-libre/"))))
 
+
+;;;
+;;; Pluggable authentication modules (PAM).
+;;;
+
 (define-public linux-pam
   (package
     (name "linux-pam")
@@ -255,6 +260,11 @@ be used through the PAM API to perform tasks, like authenticating a user
 at login.  Local and dynamic reconfiguration are its key features")
     (license bsd-3)))
 
+
+;;;
+;;; Miscellaneous.
+;;;
+
 (define-public psmisc
   (package
     (name "psmisc")

gnu/packages/mail.scm

@@ -16,20 +16,23 @@
 ;;; 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 mailutils)
+(define-module (gnu packages mail)
   #:use-module (gnu packages)
-  #:use-module (gnu packages linux)
-  #:use-module (gnu packages gnutls)
-  #:use-module (gnu packages gdbm)
-  #:use-module (gnu packages guile)
-  #:use-module (gnu packages ncurses)
-  #:use-module (gnu packages readline)
-  #:use-module (gnu packages dejagnu)
-  #:use-module (gnu packages m4)
-  #:use-module (gnu packages texinfo)
-  #:use-module (gnu packages mysql)
   #:use-module (gnu packages autotools)
-  #:use-module (guix licenses)
+  #:use-module (gnu packages dejagnu)
+  #:use-module (gnu packages gdbm)
+  #:use-module (gnu packages gnutls)
+  #:use-module (gnu packages guile)
+  #:use-module (gnu packages linux)
+  #:use-module (gnu packages m4)
+  #:use-module (gnu packages mysql)
+  #:use-module (gnu packages ncurses)
+  #:use-module (gnu packages openssl)
+  #:use-module (gnu packages perl)
+  #:use-module (gnu packages readline)
+  #:use-module (gnu packages texinfo)
+  #:use-module ((guix licenses)
+                #:select (gpl2+ gpl3+ lgpl3+))
   #:use-module (guix packages)
   #:use-module (guix download)
   #:use-module (guix build-system gnu))
@@ -104,3 +107,67 @@ message handling system.")
     (license
      ;; Libraries are under LGPLv3+, and programs under GPLv3+.
      (list gpl3+ lgpl3+))))
+
+(define-public fetchmail
+  (package
+    (name "fetchmail")
+    (version "6.3.26")
+    (source (origin
+             (method url-fetch)
+             (uri (string-append "mirror://sourceforge/fetchmail/branch_6.3/fetchmail-"
+                                 version ".tar.xz"))
+             (sha256
+              (base32
+               "0l78ayvi9dm8hd190gl139cs2xqsrf7r9ncilslw20mgvd6cbd3r"))))
+    (build-system gnu-build-system)
+    (inputs
+     `(("openssl" ,openssl)))
+    (arguments
+     `(#:configure-flags (list (string-append "--with-ssl="
+                                              (assoc-ref %build-inputs "openssl")))))
+    (home-page "http://fetchmail.berlios.de/")
+    (synopsis "Remote-mailr etrieval and forwarding utility")
+    (description
+     "Fetchmail is a full-featured, robust, well-documented remote-mail
+retrieval and forwarding utility intended to be used over on-demand
+TCP/IP links (such as SLIP or PPP connections).  It supports every
+remote-mail protocol now in use on the Internet: POP2, POP3, RPOP, APOP,
+KPOP, all flavors of IMAP, ETRN, and ODMR.  It can even support IPv6
+and IPSEC.
+
+Fetchmail retrieves mail from remote mail servers and forwards it via SMTP,
+so it can then be read by normal mail user agents such as mutt, elm
+or BSD Mail.  It allows all your system MTA's filtering, forwarding, and
+aliasing facilities to work just as they would on normal mail.")
+    (license gpl2+))) ; most files are actually public domain or x11
+
+(define-public mutt
+  (package
+    (name "mutt")
+    (version "1.5.21")
+    (source (origin
+             (method url-fetch)
+             (uri (string-append "ftp://ftp.mutt.org/mutt/devel/mutt-"
+                                 version ".tar.gz"))
+             (sha256
+              (base32
+               "1864cwz240gh0zy56fb47qqzwyf6ghg01037rb4p2kqgimpg6h91"))))
+    (build-system gnu-build-system)
+    (inputs
+     `(("ncurses" ,ncurses)
+       ("openssl" ,openssl)
+       ("perl" ,perl)))
+    (arguments
+     `(#:configure-flags '("--enable-smtp"
+                           "--enable-imap"
+                           "--enable-pop"
+                           "--with-ssl"
+                           ;; so that mutt does not check whether the path
+                           ;; exists, which it does not in the chroot
+                           "--with-mailpath=/var/mail")))
+    (home-page "http://www.mutt.org/")
+    (synopsis "Mail client")
+    (description
+     "Mutt is a small but very powerful text-based mail client for Unix
+operating systems.")
+    (license gpl2+)))

gnu/packages/netpbm.scm

@@ -57,7 +57,7 @@
              ("libxml2" ,libxml2)
              ("perl" ,perl)
              ("pkg-config" ,pkg-config)
-             ("python" ,python)
+             ("python" ,python-wrapper)
              ("zlib" ,zlib)))
    (arguments
     `(#:phases

gnu/packages/oggvorbis.scm

@@ -191,7 +191,7 @@ meaning that audio is compressed in FLAC without any loss in quality.")
              ("libogg" ,libogg)
              ("libpng" ,libpng)
              ("pkg-config" ,pkg-config)
-             ("python" ,python)
+             ("python" ,python-wrapper)
              ("zlib" ,zlib)))
    (synopsis "kate, a karaoke and text codec for embedding in ogg")
    (description

gnu/packages/patches/avahi-localstatedir.patch

@@ -0,0 +1,12 @@
+Don't "mkdir $(localstatedir)" since we can't do it (/var).
+
+--- avahi-0.6.27/avahi-daemon/Makefile.in	2010-07-13 05:06:35.000000000 +0200
++++ avahi-0.6.27/avahi-daemon/Makefile.in	2010-07-13 18:03:45.000000000 +0200
+@@ -1554,7 +1554,6 @@ xmllint:
+ 	done
+ 
+ install-data-local:
+-	test -z "$(localstatedir)/run" || $(mkdir_p) "$(DESTDIR)$(localstatedir)/run"
+ 
+ update-systemd:
+ 	curl http://cgit.freedesktop.org/systemd/plain/src/sd-daemon.c > sd-daemon.c

gnu/packages/patches/dbus-localstatedir.patch

@@ -0,0 +1,30 @@
+Do not try to create $localstatedir and $sysconfdir since we cannot do this
+when they are /var and /etc.
+
+--- dbus-1.6.4/bus/Makefile.in	2013-09-11 16:15:13.000000000 +0200
++++ dbus-1.6.4/bus/Makefile.in	2013-09-11 16:15:15.000000000 +0200
+@@ -1510,9 +1510,6 @@ clean-local:
+ 	/bin/rm *.bb *.bbg *.da *.gcov || true
+ 
+ install-data-hook:
+-	$(mkinstalldirs) $(DESTDIR)$(localstatedir)/run/dbus
+-	$(mkinstalldirs) $(DESTDIR)$(configdir)/system.d
+-	$(mkinstalldirs) $(DESTDIR)$(configdir)/session.d
+ 	$(mkinstalldirs) $(DESTDIR)$(datadir)/dbus-1/services
+ 	$(mkinstalldirs) $(DESTDIR)$(datadir)/dbus-1/system-services
+ # Install dbus.socket as default implementation of a D-Bus stack.
+
+--- dbus-1.6.4/tools/Makefile.in	2013-09-11 16:10:31.000000000 +0200
++++ dbus-1.6.4/tools/Makefile.in	2013-09-11 16:10:32.000000000 +0200
+@@ -757,11 +757,6 @@ uninstall-am: uninstall-binPROGRAMS
+ 
+ 
+ # create the /var/lib/dbus directory for dbus-uuidgen
+-install-data-local:
+-	$(MKDIR_P) $(DESTDIR)$(localstatedir)/lib/dbus
+-
+-installcheck-local:
+-	test -d $(DESTDIR)$(localstatedir)/lib/dbus
+ 
+ # Tell versions [3.59,3.63) of GNU make to not export all variables.
+ # Otherwise a system limit (for SysV at least) may be exceeded.

gnu/packages/patches/gnutls-fix-tests-on-32-bits-system.patch

@@ -1,36 +0,0 @@
-From b12040aeab5fbaf02677571db1d8bf1995bd5ee0 Mon Sep 17 00:00:00 2001
-From: Nikos Mavrogiannopoulos <nmav@gnutls.org>
-Date: Sun, 2 Jun 2013 12:10:06 +0200
-Subject: [PATCH] Avoid comparing the expiration date to prevent false positive
-error in 32-bit systems.
-
----
- tests/cert-tests/pem-decoding |    6 ++++--
- 1 files changed, 4 insertions(+), 2 deletions(-)
-
-diff --git a/tests/cert-tests/pem-decoding b/tests/cert-tests/pem-decoding
-index fe769ec..f8c6372 100755
---- tests/cert-tests/pem-decoding
-+++ tests/cert-tests/pem-decoding
-@@ -61,7 +61,9 @@ if test "$rc" != "0"; then
-   exit $rc
- fi
- 
--diff $srcdir/complex-cert.pem tmp-pem.pem
-+cat $srcdir/complex-cert.pem |grep -v "Not After:" >tmp1
-+cat $srcdir/tmp-pem.pem |grep -v "Not After:" >tmp2
-+diff tmp1 tmp2
- rc=$?
- 
- if test "$rc" != "0"; then
-@@ -69,6 +71,6 @@ if test "$rc" != "0"; then
-   exit $rc
- fi
- 
--rm -f tmp-pem.pem
-+rm -f tmp-pem.pem tmp1 tmp2
- 
- exit 0
--- 
-1.7.1
-

gnu/packages/python.scm

@@ -19,19 +19,25 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu packages python)
-  #:use-module ((guix licenses) #:select (bsd-3 psfl x11))
+  #:use-module ((guix licenses) #:select (bsd-3 bsd-style psfl x11))
+  #:use-module ((guix licenses) #:select (zlib)
+                                #:renamer (symbol-prefix-proc 'license:))
   #:use-module (gnu packages)
   #:use-module (gnu packages compression)
   #:use-module (gnu packages gdbm)
+  #:use-module (gnu packages icu4c)
   #:use-module (gnu packages readline)
   #:use-module (gnu packages openssl)
   #:use-module (gnu packages patchelf)
+  #:use-module (gnu packages sqlite)
   #:use-module (guix packages)
   #:use-module (guix download)
+  #:use-module (guix utils)
   #:use-module (guix build-system gnu)
-  #:use-module (guix build-system python))
+  #:use-module (guix build-system python)
+  #:use-module (guix build-system trivial))
 
-(define-public python
+(define-public python-2
   (package
     (name "python")
     (version "2.7.5")
@@ -151,8 +157,8 @@ packages; exception-based error handling; and very high level dynamic
 data types.")
     (license psfl)))
 
-(define-public python-3
+(define-public python
-  (package (inherit python)
+  (package (inherit python-2)
     (version "3.3.2")
     (source
      (origin
@@ -167,9 +173,34 @@ data types.")
             (variable "PYTHONPATH")
             (directories '("lib/python3.3/site-packages")))))))
 
-(define-public pytz
+(define-public python-wrapper
+  (package (inherit python)
+    (name "python-wrapper")
+    (source #f)
+    (build-system trivial-build-system)
+    (inputs `(("python" ,python)))
+    (arguments
+     `(#:modules ((guix build utils))
+       #:builder
+         (begin
+           (use-modules (guix build utils))
+           (let ((bin (string-append (assoc-ref %outputs "out") "/bin"))
+                 (python (string-append (assoc-ref %build-inputs "python") "/bin/")))
+                (mkdir-p bin)
+                (for-each
+                  (lambda (old new)
+                    (symlink (string-append python old)
+                             (string-append bin "/" new)))
+                  `("python3", "pydoc3", "idle3")
+                  `("python",  "pydoc",  "idle"))))))
+    (description (string-append (package-description python)
+     "\n\nThis wrapper package provides symbolic links to the python binaries
+      without version suffix."))))
+
+
+(define-public python-pytz
   (package
-    (name "pytz")
+    (name "python-pytz")
     (version "2013b")
     (source
      (origin
@@ -180,6 +211,7 @@ data types.")
        (base32
         "19giwgfcrg0nr1gdv49qnmf2jb2ilkcfc7qyqvfpz4dp0p64ksv5"))))
     (build-system python-build-system)
+    (arguments `(#:tests? #f)) ; no test target
     (home-page "https://launchpad.net/pytz")
     (synopsis "The Python timezone library.")
     (description
@@ -187,22 +219,28 @@ data types.")
 using Python 2.4 or higher and provides access to the Olson timezone database.")
     (license x11)))
 
-(define-public babel
+(define-public python2-pytz
+  (package-with-python2 python-pytz))
+
+
+(define-public python-babel
   (package
-    (name "babel")
+    (name "python-babel")
-    (version "0.9.6")
+    (version "1.3")
     (source
      (origin
       (method url-fetch)
-      (uri (string-append "http://ftp.edgewall.com/pub/babel/Babel-"
+      (uri (string-append "https://pypi.python.org/packages/source/B/Babel/Babel-"
                           version ".tar.gz"))
       (sha256
        (base32
-        "03vmr54jq5vf3qw6kpdv7cdk7x7i2jhzyf1mawv2gk8zrxg0hfja"))))
+        "0bnin777lc53nxd1hp3apq410jj5wx92n08h7h4izpl4f4sx00lz"))))
     (build-system python-build-system)
     (inputs
-     `(("pytz" ,pytz)))
+     `(("python-pytz" ,python-pytz)
-    (home-page "http://babel.edgewall.org/")
+       ("python-setuptools" ,python-setuptools)))
+    (arguments `(#:tests? #f)) ; no test target
+    (home-page "http://babel.pocoo.org/")
     (synopsis
      "Tools for internationalizing Python applications")
     (description
@@ -212,3 +250,191 @@ using Python 2.4 or higher and provides access to the Olson timezone database.")
 access to various locale display names, localized number and date formatting,
 etc. ")
     (license bsd-3)))
+
+(define-public python2-babel
+  (package-with-python2 python-babel))
+
+
+(define-public python-setuptools
+  (package
+    (name "python-setuptools")
+    (version "1.1.4")
+    (source
+     (origin
+      (method url-fetch)
+      (uri (string-append "https://pypi.python.org/packages/source/s/setuptools/setuptools-"
+                          version ".tar.gz"))
+      (sha256
+       (base32
+        "0hl9sa5xr9bi2ifq51wy1bawsjv5nzvpbac7m9z1ciz778874csf"))))
+    (build-system python-build-system)
+    (arguments
+     `(#:tests? #f))
+         ;;FIXME: test_sdist_with_utf8_encoded_filename fails in
+         ;; /tmp/nix-build-python2-setuptools-1.1.4.drv-0/setuptools-1.1.4/setuptools/tests/test_sdist.py"
+         ;; line 354
+         ;; The tests pass with Python 2.7.5.
+    (home-page "https://pypi.python.org/pypi/setuptools")
+    (synopsis
+     "Library designed to facilitate packaging Python projects")
+    (description
+     "Setuptools is a fully-featured, stable library designed to facilitate
+packaging Python projects, where packaging includes:
+Python package and module definitions,
+distribution package metadata,
+test hooks,
+project installation,
+platform-specific details,
+Python 3 support.")
+    (license psfl)))
+
+(define-public python2-setuptools
+  (package-with-python2 python-setuptools))
+
+
+(define-public python-dateutil
+  (package
+    (name "python-dateutil")
+    (version "1.5") ; last version for python < 3
+    (source
+     (origin
+      (method url-fetch)
+      (uri (string-append "http://labix.org/download/python-dateutil/python-dateutil-"
+                          version ".tar.gz"))
+      (sha256
+       (base32
+        "0fqfglhy5khbvsipr3x7m6bcaqljh8xl5cw33vbfxy7qhmywm2n0"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)))
+    (home-page "http://labix.org/python-dateutil")
+    (synopsis
+     "Extensions to the standard datetime module, available in Python 2.3+")
+    (description
+     "The dateutil module provides powerful extensions to the standard
+datetime module, available in Python 2.3+.")
+    (license psfl)))
+
+(define-public python2-dateutil
+  (package-with-python2 python-dateutil))
+
+
+(define-public python2-pysqlite
+  (package
+    (name "python2-pysqlite")
+    (version "2.6.3")
+    (source
+     (origin
+      (method url-fetch)
+      (uri (string-append "http://pysqlite.googlecode.com/files/pysqlite-"
+                          version ".tar.gz"))
+      (sha256
+       (base32
+        "0nsqqfp072rgqbls100rdvbzkjkin7li3kprhfxlfqvzf608hlqd"))))
+    (build-system python-build-system)
+    (inputs
+     `(("sqlite" ,sqlite)))
+    (arguments
+     `(#:python ,python-2 ; incompatible with Python 3
+       #:tests? #f)) ; no test target
+    (home-page "http://labix.org/python-dateutil")
+    (synopsis
+     "SQLite bindings for Python.")
+    (description
+     "Pysqlite provides SQLite bindings for Python that comply to the
+Database API 2.0T.")
+    (license license:zlib)))
+
+
+(define-public python2-mechanize
+  (package
+    (name "python2-mechanize")
+    (version "0.2.5")
+    (source
+     (origin
+      (method url-fetch)
+      (uri (string-append "https://pypi.python.org/packages/source/m/mechanize/mechanize-"
+                          version ".tar.gz"))
+      (sha256
+       (base32
+        "0rj7r166i1dyrq0ihm5rijfmvhs8a04im28lv05c0c3v206v4rrf"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python2-setuptools" ,python2-setuptools)))
+    (arguments
+     `(#:python ,python-2 ; apparently incompatible with Python 3
+       #:tests? #f))
+         ;; test fails with message
+         ;; AttributeError: 'module' object has no attribute 'test_pullparser'
+         ;; (python-3.3.2) or
+         ;; AttributeError: 'module' object has no attribute 'test_urllib2_localnet'
+         ;; (python-2.7.5).
+         ;; The source code is from March 2011 and probably not up-to-date
+         ;; with respect to python unit tests.
+    (home-page "http://wwwsearch.sourceforge.net/mechanize/")
+    (synopsis
+     "Stateful programmatic web browsing in Python")
+    (description
+     "Mechanize implements stateful programmatic web browsing in Python,
+after Andy Lester’s Perl module WWW::Mechanize.")
+    (license (bsd-style "file://COPYING"
+                        "See COPYING in the distribution."))))
+
+
+(define-public python-simplejson
+  (package
+    (name "python-simplejson")
+    (version "3.3.0")
+    (source
+     (origin
+      (method url-fetch)
+      (uri (string-append "https://pypi.python.org/packages/source/s/simplejson/simplejson-"
+                          version ".tar.gz"))
+      (sha256
+       (base32
+        "07wsry5j44l5zzm74l4j2bvasiq8n5m32f31n2p7c68i5vc6p2ks"))))
+    (build-system python-build-system)
+    (home-page "http://simplejson.readthedocs.org/en/latest/")
+    (synopsis
+     "Json library for Python")
+    (description
+     "JSON (JavaScript Object Notation) is a subset of JavaScript syntax
+(ECMA-262 3rd edition) used as a lightweight data interchange format.
+
+Simplejson exposes an API familiar to users of the standard library marshal
+and pickle modules.  It is the externally maintained version of the json
+library contained in Python 2.6, but maintains compatibility with Python 2.5
+and (currently) has significant performance advantages, even without using
+the optional C extension for speedups.  Simplejson is also supported on
+Python 3.3+.")
+    (license x11)))
+
+(define-public python2-simplejson
+  (package-with-python2 python-simplejson))
+
+
+(define-public python2-pyicu
+  (package
+    (name "python2-pyicu")
+    (version "1.5")
+    (source
+     (origin
+      (method url-fetch)
+      (uri (string-append "https://pypi.python.org/packages/source/P/PyICU/PyICU-"
+                          version ".tar.gz"))
+      (sha256
+       (base32
+        "011vwflpir8wvh48mvi6d9a7vw0f43bkwv0w6bzxbzmvz20ax5vm"))))
+    (build-system python-build-system)
+    (inputs
+     `(("icu4c" ,icu4c)))
+    (arguments
+     `(#:python ,python-2 ; Python 3 works also, but needs special care for
+                          ; linking with libpython3.3m
+       #:tests? #f)) ; no check target
+    (home-page "http://pyicu.osafoundation.org/")
+    (synopsis
+     "Python extension wrapping the ICU C++ API.")
+    (description
+     "PyICU is a python extension wrapping the ICU C++ API.")
+    (license x11)))

gnu/packages/qemu.scm

@@ -94,7 +94,7 @@
      `(;; ("mesa" ,mesa)
        ;; ("libaio" ,libaio)
        ("glib" ,glib)
-       ("python" ,python)
+       ("python" ,python-2) ; incompatible with Python 3 according to error message
        ("ncurses" ,ncurses)
        ("libpng" ,libpng)
        ("libjpeg" ,libjpeg-8)

gnu/packages/samba.scm

@@ -150,7 +150,7 @@ anywhere.")
        ("patchelf" ,patchelf)))                   ; for (guix build rpath)
     (native-inputs                                ; for the test suite
      `(("perl" ,perl)
-       ("python" ,python)))
+       ("python" ,python-wrapper)))
     (home-page "http://www.samba.org/")
     (synopsis
      "The standard Windows interoperability suite of programs for GNU and Unix")

gnu/packages/system.scm

@@ -25,7 +25,39 @@
   #:use-module (guix build-system gnu)
   #:use-module (gnu packages)
   #:use-module (gnu packages ncurses)
-  #:use-module (gnu packages linux))
+  #:use-module (gnu packages linux)
+  #:use-module (gnu packages guile)
+  #:use-module (gnu packages pkg-config))
+
+(define-public dmd
+  (package
+    (name "dmd")
+    (version "-0.4")
+    (source (origin
+             (method url-fetch)
+
+             ;; XXX: Temporary location until dmd gets back home.
+             (uri (string-append
+                   "http://www.fdn.fr/~lcourtes/software/guix/dmd-"
+                   version ".tar.gz"))
+             (sha256
+              (base32
+               "094ja3xvk9ljghhxmy39if67cfjd1hy6m4svnp399n0wpxvaryvy"))))
+    (build-system gnu-build-system)
+    (arguments
+     '(#:configure-flags '("--localstatedir=/var")))
+    (inputs `(("pkg-config" ,pkg-config)
+              ("guile" ,guile-2.0)))
+    (synopsis "Daemon managing daemons")
+    (description "'DMD' is a \"Daemon managing Daemons\" (or
+\"Daemons-managing Daemon\"?)---i.e. a service manager that provides a
+replacement for the service-managing capabilities of SysV-init (or any other
+init) with a both powerful and beautiful dependency-based system with a
+convenient interface.  It is intended for use on GNU/Hurd, but it is supposed
+to work on every POSIX-like system where Guile is available.  In particular,
+it has been tested on GNU/Linux.")
+    (license gpl3+)
+    (home-page "http://www.gnu.org/software/dmd/")))
 
 (define-public dfc
   (package

gnu/packages/texlive.scm

@@ -81,7 +81,7 @@
              ("pkg-config" ,pkg-config)
              ;; FIXME: Add interpreters fontforge and ruby,
              ;; once they are available.
-             ("python" ,python)
+             ("python" ,python-2) ; incompatible with Python 3 (print syntax)
              ("tcsh" ,tcsh)
              ("teckit" ,teckit)
              ("t1lib" ,t1lib)
@@ -202,7 +202,7 @@ world.")
     (build-system gnu-build-system)
     (arguments '(#:tests? #f))                    ; no `check' target
     (inputs `(("texinfo" ,texinfo)
-              ("python" ,python)
+              ("python" ,python-2) ; incompatible with Python 3 (print syntax)
               ("which" ,which)))
     (home-page "https://launchpad.net/rubber")
     (synopsis "Rubber, a wrapper for LaTeX and friends")

gnu/packages/version-control.scm

@@ -58,7 +58,9 @@
      ;; require Zsh.
      `(("gettext" ,guix:gettext)))
     (arguments
-     `(#:tests? #f)) ; no test target
+     `(#:tests? #f ; no test target
+       #:python ,python-2)) ; Python 3 apparently not yet supported, see
+                            ; https://answers.launchpad.net/bzr/+question/229048
     (home-page "https://gnu.org/software/bazaar")
     (synopsis "Decentralized revision control system")
     (description
@@ -86,7 +88,7 @@ from a command line or use a GUI application.")
       ("gettext" ,guix:gettext)
       ("openssl" ,openssl)
       ("perl" ,perl)
-      ("python" ,python) ; CAVEAT: incompatible with python-3 according to INSTALL
+      ("python" ,python-2) ; CAVEAT: incompatible with python-3 according to INSTALL
       ("zlib" ,zlib)))
    (arguments
     `(#:make-flags `("V=1") ; more verbose compilation
@@ -126,7 +128,7 @@ everything from small to very large projects with speed and efficiency.")
       `(("apr" ,apr)
         ("apr-util" ,apr-util)
         ("perl" ,perl)
-        ("python" ,python)
+        ("python" ,python-2) ; incompatible with Python 3 (print syntax)
         ("sqlite" ,sqlite)
         ("zlib" ,zlib)))
     (home-page "http://subversion.apache.org/")

gnu/packages/xml.scm

@@ -66,7 +66,7 @@ things the parser might find in the XML document (like start tags).")
     (home-page "http://www.xmlsoft.org/")
     (synopsis "libxml2, a C parser for XML")
     (inputs `(("perl" ,perl)
-              ("python" ,python)
+              ("python" ,python-2) ; incompatible with Python 3 (print syntax)
               ("zlib" ,zlib)))
     (arguments
      `(#:phases
@@ -102,7 +102,7 @@ things the parser might find in the XML document (like start tags).")
     (synopsis "libxslt, a C library for applying XSLT stylesheets to XML documents")
     (inputs `(("libgcrypt" ,libgcrypt)
               ("libxml2" ,libxml2)
-              ("python" ,python)
+              ("python" ,python-wrapper)
               ("zlib" ,zlib)))
     (description
      "Libxslt is an XSLT C library developed for the GNOME project. It is

gnu/packages/xorg.scm

@@ -1857,7 +1857,7 @@ tracking.")
             "0ds4qg6slidrzyz6q9ckq0a19hn6blzpnvciy4brh741gn49jpdd"))))
     (build-system gnu-build-system)
     (inputs
-      `(("pkg-config" ,pkg-config) ("python" ,python)))
+      `(("pkg-config" ,pkg-config) ("python" ,python-wrapper)))
     (home-page "http://www.x.org/wiki/")
     (synopsis "xorg implementation of the X Window System")
     (description "X.org provides an implementation of the X Window System")
@@ -1929,6 +1929,11 @@ tracking.")
       `(("libxcursor" ,libxcursor)
         ("pkg-config" ,pkg-config)
         ("xcursorgen" ,xcursorgen)))
+    (arguments
+     `(#:configure-flags
+       (list (string-append "--with-cursordir="
+                            (assoc-ref %outputs "out")
+                            "/share/icons"))))
     (home-page "http://www.x.org/wiki/")
     (synopsis "xorg implementation of the X Window System")
     (description "X.org provides an implementation of the X Window System")
@@ -4169,7 +4174,7 @@ tracking.")
         ("libxml2" ,libxml2)
         ("makedepend" ,makedepend)
         ("pkg-config" ,pkg-config)
-        ("python" ,python)))
+        ("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
@@ -4215,7 +4220,7 @@ emulation to complete hardware acceleration for modern GPUs.")
       `(("xcb-proto" ,xcb-proto)
         ("libxslt" ,libxslt)
         ("pkg-config" ,pkg-config)
-        ("python" ,python)))
+        ("python" ,python-wrapper)))
     (home-page "http://www.x.org/wiki/")
     (synopsis "xorg implementation of the X Window System")
     (description "X.org provides an implementation of the X Window System")
@@ -4270,7 +4275,7 @@ emulation to complete hardware acceleration for modern GPUs.")
         ("mesa" ,mesa)
         ("openssl" ,openssl)
         ("pkg-config" ,pkg-config)
-        ("python" ,python)
+        ("python" ,python-wrapper)
         ("recordproto" ,recordproto)
         ("resourceproto" ,resourceproto)
         ("scrnsaverproto" ,scrnsaverproto)

gnu/packages/yasm.scm

@@ -40,7 +40,7 @@
         "0cfg7ji3ia2in628w42wrfvw2ixmmm4rghwmv2k202mraysgm3vn"))))
     (build-system gnu-build-system)
     (inputs
-     `(("python" ,python)
+     `(("python" ,python-wrapper)
        ("xmlto" ,xmlto)))
     (home-page "http://yasm.tortall.net/")
     (synopsis "Rewrite of the NASM assembler")

gnu/packages/zip.scm

@@ -120,7 +120,8 @@ UnZip recreates the stored directory structure by default.")
     (build-system gnu-build-system)
     (inputs `(("perl" ,perl)     ; for the documentation
               ("pkg-config" ,pkg-config)
-              ("python" ,python) ; for the documentation
+              ("python" ,python-2) ; for the documentation; Python 3 not supported,
+                ; http://forums.gentoo.org/viewtopic-t-863161-start-0.html
               ("zip" ,zip) ; to create test files
               ("zlib" ,zlib)))
     (arguments

gnu/system/dmd.scm

@@ -0,0 +1,126 @@
+;;; 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 (gnu system dmd)
+  #:use-module (guix store)
+  #:use-module (guix packages)
+  #:use-module (guix derivations)
+  #:use-module (guix records)
+  #:use-module ((gnu packages system)
+                #:select (mingetty inetutils))
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:export (service?
+            service
+            service-provision
+            service-requirement
+            service-respawn?
+            service-start
+            service-stop
+            service-inputs
+
+            syslog-service
+            mingetty-service
+            dmd-configuration-file))
+
+;;; Commentary:
+;;;
+;;; System services as cajoled by dmd.
+;;;
+;;; Code:
+
+(define-record-type* <service>
+  service make-service
+  service?
+  (provision     service-provision)               ; list of symbols
+  (requirement   service-requirement              ; list of symbols
+                 (default '()))
+  (respawn?      service-respawn?                 ; Boolean
+                 (default #t))
+  (start         service-start)                   ; expression
+  (stop          service-stop                     ; expression
+                 (default #f))
+  (inputs        service-inputs                   ; list of inputs
+                 (default '())))
+
+(define (mingetty-service store tty)
+  "Return a service to run mingetty on TTY."
+  (let* ((mingetty-drv (package-derivation store mingetty))
+         (mingetty-bin (string-append (derivation->output-path mingetty-drv)
+                                      "/sbin/mingetty")))
+    (service
+     (provision (list (symbol-append 'term- (string->symbol tty))))
+     (start `(make-forkexec-constructor ,mingetty-bin "--noclear" ,tty))
+     (inputs `(("mingetty" ,mingetty))))))
+
+(define (syslog-service store)
+  "Return a service that runs 'syslogd' with reasonable default settings."
+
+  (define syslog.conf
+    ;; Snippet adapted from the GNU inetutils manual.
+    (add-text-to-store store "syslog.conf" "
+     # Log all kernel messages, authentication messages of
+     # level notice or higher and anything of level err or
+     # higher to the console.
+     # Don't log private authentication messages!
+     *.err;kern.*;auth.notice;authpriv.none  /dev/console
+
+     # Log anything (except mail) of level info or higher.
+     # Don't log private authentication messages!
+     *.info;mail.none;authpriv.none          /var/log/messages
+
+     # Same, in a different place.
+     *.info;mail.none;authpriv.none          /dev/tty12
+
+     # The authpriv file has restricted access.
+     authpriv.*                              /var/log/secure
+
+     # Log all the mail messages in one place.
+     mail.*                                  /var/log/maillog
+"))
+
+  (let* ((inetutils-drv (package-derivation store inetutils))
+         (syslogd       (string-append (derivation->output-path inetutils-drv)
+                                       "/libexec/syslogd")))
+    (service
+     (provision '(syslogd))
+     (start `(make-forkexec-constructor ,syslogd
+                                        "--rcfile" ,syslog.conf))
+     (inputs `(("inetutils" ,inetutils)
+               ("syslog.conf" ,syslog.conf))))))
+
+(define (dmd-configuration-file store services)
+  "Return the dmd configuration file for SERVICES."
+  (define config
+    `(begin
+       (register-services
+        ,@(map (match-lambda
+                (($ <service> provision requirement respawn? start stop)
+                 `(make <service>
+                    #:provides ',provision
+                    #:requires ',requirement
+                    #:respawn? ,respawn?
+                    #:start ,start
+                    #:stop ,stop)))
+               services))
+       (for-each start ',(append-map service-provision services))))
+
+  (add-text-to-store store "dmd.conf"
+                     (object->string config)))
+
+;;; dmd.scm ends here

gnu/system/grub.scm

@@ -0,0 +1,84 @@
+;;; 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 (gnu system grub)
+  #:use-module (guix store)
+  #:use-module (guix packages)
+  #:use-module (guix derivations)
+  #:use-module (guix records)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:export (menu-entry
+            menu-entry?
+            grub-configuration-file))
+
+;;; Commentary:
+;;;
+;;; Configuration of GNU GRUB.
+;;;
+;;; Code:
+
+(define-record-type* <menu-entry>
+  menu-entry make-menu-entry
+  menu-entry?
+  (label           menu-entry-label)
+  (linux           menu-entry-linux)
+  (linux-arguments menu-entry-linux-arguments
+                   (default '()))
+  (initrd          menu-entry-initrd))
+
+(define* (grub-configuration-file store entries
+                                  #:key (default-entry 1) (timeout 5)
+                                  (system (%current-system)))
+  "Return the GRUB configuration file in STORE for ENTRIES, a list of
+<menu-entry> objects, defaulting to DEFAULT-ENTRY and with the given TIMEOUT."
+  (define prologue
+    (format #f "
+set default=~a
+set timeout=~a
+search.file ~a~%"
+            default-entry timeout
+            (any (match-lambda
+                  (($ <menu-entry> _ linux)
+                   (let* ((drv (package-derivation store linux system))
+                          (out (derivation->output-path drv)))
+                     (string-append out "/bzImage"))))
+                 entries)))
+
+  (define entry->text
+    (match-lambda
+     (($ <menu-entry> label linux arguments initrd)
+      (let ((linux-drv  (package-derivation store linux system))
+            (initrd-drv (package-derivation store initrd system)))
+        ;; XXX: Assume that INITRD is a directory containing an 'initrd' file.
+        (format #f "menuentry ~s {
+  linux ~a/bzImage ~a
+  initrd ~a/initrd
+}~%"
+                label
+                (derivation->output-path linux-drv)
+                (string-join arguments)
+                (derivation->output-path initrd-drv))))))
+
+  (add-text-to-store store "grub.cfg"
+                     (string-append prologue
+                                    (string-concatenate
+                                     (map entry->text entries)))
+                     '()))
+
+;;; grub.scm ends here

gnu/system/linux.scm

@@ -0,0 +1,145 @@
+;;; 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 (gnu system linux)
+  #:use-module (guix store)
+  #:use-module (guix records)
+  #:use-module (guix derivations)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module ((guix utils) #:select (%current-system))
+  #:export (pam-service
+            pam-entry
+            pam-services->directory
+            %pam-other-services
+            unix-pam-service))
+
+;;; Commentary:
+;;;
+;;; Configuration of Linux-related things, including pluggable authentication
+;;; modules (PAM).
+;;;
+;;; Code:
+
+;; PAM services (see
+;; <http://www.linux-pam.org/Linux-PAM-html/sag-configuration-file.html>.)
+(define-record-type* <pam-service> pam-service
+  make-pam-service
+  pam-service?
+  (name       pam-service-name)                   ; string
+
+  ;; The four "management groups".
+  (account    pam-service-account                 ; list of <pam-entry>
+              (default '()))
+  (auth       pam-service-auth
+              (default '()))
+  (password   pam-service-password
+              (default '()))
+  (session    pam-service-session
+              (default '())))
+
+(define-record-type* <pam-entry> pam-entry
+  make-pam-entry
+  pam-entry?
+  (control    pam-entry-control)                  ; string
+  (module     pam-entry-module)                   ; file name
+  (arguments  pam-entry-arguments                 ; list of strings
+              (default '())))
+
+(define (pam-service->configuration service)
+  "Return the configuration string for SERVICE, to be dumped in
+/etc/pam.d/NAME, where NAME is the name of SERVICE."
+  (define (entry->string type entry)
+    (match entry
+      (($ <pam-entry> control module (arguments ...))
+       (string-append type "  "
+                      control " " module " "
+                      (string-join arguments)
+                      "\n"))))
+
+  (match service
+    (($ <pam-service> name account auth password session)
+     (string-concatenate
+      (append (map (cut entry->string "account" <>) account)
+              (map (cut entry->string "auth" <>) auth)
+              (map (cut entry->string "password" <>) password)
+              (map (cut entry->string "session" <>) session))))))
+
+(define (pam-services->directory store services)
+  "Return the derivation to build the configuration directory to be used as
+/etc/pam.d for SERVICES."
+  (let ((names (map pam-service-name services))
+        (files (map (match-lambda
+                     ((and service ($ <pam-service> name))
+                      (let ((config (pam-service->configuration service)))
+                        (add-text-to-store store
+                                           (string-append name ".pam")
+                                           config '()))))
+                    services)))
+    (define builder
+      '(begin
+         (use-modules (ice-9 match))
+
+         (let ((out (assoc-ref %outputs "out")))
+           (mkdir out)
+           (for-each (match-lambda
+                      ((name . file)
+                       (symlink file (string-append out "/" name))))
+                     %build-inputs)
+           #t)))
+
+    (build-expression->derivation store "pam.d" (%current-system)
+                                  builder
+                                  (zip names files))))
+
+(define %pam-other-services
+  ;; The "other" PAM configuration, which denies everything (see
+  ;; <http://www.linux-pam.org/Linux-PAM-html/sag-configuration-example.html>.)
+  (let ((deny (pam-entry
+               (control "required")
+               (module "pam_deny.so"))))
+    (pam-service
+     (name "other")
+     (account (list deny))
+     (auth (list deny))
+     (password (list deny))
+     (session (list deny)))))
+
+(define unix-pam-service
+  (let ((unix (pam-entry
+               (control "required")
+               (module "pam_unix.so"))))
+    (lambda* (name #:key allow-empty-passwords?)
+      "Return a standard Unix-style PAM service for NAME.  When
+ALLOW-EMPTY-PASSWORDS? is true, allow empty passwords."
+      ;; See <http://www.linux-pam.org/Linux-PAM-html/sag-configuration-example.html>.
+      (let ((name* name))
+        (pam-service
+         (name name*)
+         (account (list unix))
+         (auth (list (if allow-empty-passwords?
+                         (pam-entry
+                          (control "required")
+                          (module "pam_unix.so")
+                          (arguments '("nullok")))
+                         unix)))
+         (password (list unix))
+         (session (list unix)))))))
+
+;;; linux.scm ends here

gnu/system/shadow.scm

@@ -0,0 +1,57 @@
+;;; 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 (gnu system shadow)
+  #:use-module (guix store)
+  #:use-module (ice-9 match)
+  #:export (passwd-file))
+
+;;; Commentary:
+;;;
+;;; Utilities for configuring the Shadow tool suite ('login', 'passwd', etc.)
+;;;
+;;; Code:
+
+(define* (passwd-file store accounts #:key shadow?)
+  "Return a password file for ACCOUNTS, a list of vectors as returned by
+'getpwnam'.  If SHADOW? is true, then it is a /etc/shadow file, otherwise it
+is a /etc/passwd file."
+  ;; XXX: The resulting file is world-readable, so beware when SHADOW? is #t!
+  (define contents
+    (let loop ((accounts accounts)
+               (result   '()))
+      (match accounts
+        ((#(name pass uid gid comment home-dir shell) rest ...)
+         (loop rest
+               (cons (if shadow?
+                         (string-append name
+                                        ":"       ; XXX: use (crypt PASS …)?
+                                        ":::::::")
+                         (string-append name
+                                        ":" "x"
+                                        ":" (number->string uid)
+                                        ":" (number->string gid)
+                                        ":" comment ":" home-dir ":" shell))
+                     result)))
+        (()
+         (string-join (reverse result) "\n" 'suffix)))))
+
+  (add-text-to-store store (if shadow? "shadow" "passwd")
+                     contents '()))
+
+;;; shadow.scm ends here

gnu/system/vm.scm

@@ -33,13 +33,20 @@
   #:use-module (gnu packages linux-initrd)
   #:use-module ((gnu packages make-bootstrap)
                 #:select (%guile-static-stripped))
-  #:use-module ((gnu packages system)
+  #:use-module (gnu packages system)
-                #:select (mingetty))
+
+  #:use-module (gnu system shadow)
+  #:use-module (gnu system linux)
+  #:use-module (gnu system grub)
+  #:use-module (gnu system dmd)
+
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
+
   #:export (expression->derivation-in-linux-vm
-            qemu-image))
+            qemu-image
+            system-qemu-image))
 
 
 ;;; Commentary:
@@ -75,6 +82,9 @@ DISK-IMAGE-SIZE bytes and return it.
 When REFERENCES-GRAPHS is true, it must be a list of file name/store path
 pairs, as for `derivation'.  The files containing the reference graphs are
 made available under the /xchg CIFS share."
+  ;; FIXME: Allow use of macros from other modules, as done in
+  ;; `build-expression->derivation'.
+
   (define input-alist
     (map (match-lambda
           ((input (? package? package))
@@ -197,10 +207,10 @@ It can be used to provide additional files, such as /etc files."
   (define input->name+derivation
     (match-lambda
      ((name (? package? package))
-      `(,name . ,(derivation-path->output-path
+      `(,name . ,(derivation->output-path
                   (package-derivation store package system))))
      ((name (? package? package) sub-drv)
-      `(,name . ,(derivation-path->output-path
+      `(,name . ,(derivation->output-path
                   (package-derivation store package system)
                   sub-drv)))
      ((input (and (? string?) (? store-path?) file))
@@ -294,6 +304,19 @@ It can be used to provide additional files, such as /etc files."
                                (primitive-load populate)
                                (chdir "/")))
 
+                      (display "clearing file timestamps...\n")
+                      (for-each (lambda (file)
+                                  (let ((s (lstat file)))
+                                    ;; XXX: Guile uses libc's 'utime' function
+                                    ;; (not 'futime'), so the timestamp of
+                                    ;; symlinks cannot be changed, and there
+                                    ;; are symlinks here pointing to
+                                    ;; /nix/store, which is the host,
+                                    ;; read-only store.
+                                    (unless (eq? (stat:type s) 'symlink)
+                                      (utime file 0 0 0 0))))
+                                (find-files "/fs" ".*"))
+
                       (and (zero?
                             (system* grub "--no-floppy"
                                      "--boot-directory" "/fs/boot"
@@ -327,100 +350,88 @@ It can be used to provide additional files, such as /etc files."
 
 
 ;;;
-;;; Guile 2.0 potluck examples.
+;;; Stand-alone VM image.
 ;;;
 
-(define (example1)
+(define (system-qemu-image store)
-  (let ((store #f))
+  "Return the derivation of a QEMU image of the GNU system."
-    (dynamic-wind
+  (define %pam-services
-      (lambda ()
+    ;; Services known to PAM.
-        (set! store (open-connection)))
+    (list %pam-other-services
-      (lambda ()
+          (unix-pam-service "login" #:allow-empty-passwords? #t)))
-        (parameterize ((%guile-for-build (package-derivation store guile-final)))
-          (expression->derivation-in-linux-vm
-           store "vm-test"
-           '(begin
-              (display "hello from boot!\n")
-              (call-with-output-file "/xchg/hello"
-                (lambda (p)
-                  (display "world" p)))))))
-      (lambda ()
-        (close-connection store)))))
 
-(define (/etc/shadow store accounts)
+  (define %dmd-services
-  "Return a /etc/shadow file for ACCOUNTS."
+    ;; Services run by dmd.
-  (define contents
+    (list (mingetty-service store "tty1")
-    (let loop ((accounts accounts)
+          (mingetty-service store "tty2")
-               (result   '()))
+          (mingetty-service store "tty3")
-      (match accounts
+          (syslog-service store)))
-        (((name uid gid comment home-dir shell) rest ...)
-         (loop rest
-               (cons (string-append name "::" (number->string uid)
-                                    ":" (number->string gid)
-                                    comment ":" home-dir ":" shell)
-                     result)))
-        (()
-         (string-concatenate-reverse result)))))
 
-  (add-text-to-store store "shadow" contents '()))
+  (parameterize ((%guile-for-build (package-derivation store guile-final)))
+    (let* ((bash-drv  (package-derivation store bash))
+           (bash-file (string-append (derivation->output-path bash-drv)
+                                     "/bin/bash"))
+           (dmd-drv   (package-derivation store dmd))
+           (dmd-file  (string-append (derivation->output-path dmd-drv)
+                                     "/bin/dmd"))
+           (dmd-conf  (dmd-configuration-file store %dmd-services))
+           (accounts  (list (vector "root" "" 0 0 "System administrator"
+                                    "/" bash-file)))
+           (passwd    (passwd-file store accounts))
+           (shadow    (passwd-file store accounts #:shadow? #t))
+           (group     (add-text-to-store store "group"
+                                         "root:x:0:\n"))
+           (pam.d-drv (pam-services->directory store %pam-services))
+           (pam.d     (derivation->output-path pam.d-drv))
+           (populate
+            (add-text-to-store store "populate-qemu-image"
+                               (object->string
+                                `(begin
+                                   (mkdir-p "etc")
+                                   (mkdir-p "var/log") ; for dmd
+                                   (symlink ,shadow "etc/shadow")
+                                   (symlink ,passwd "etc/passwd")
+                                   (symlink ,group "etc/group")
+                                   (symlink "/dev/null"
+                                            "etc/login.defs")
+                                   (symlink ,pam.d "etc/pam.d")
+                                   (mkdir-p "var/run")))
+                               (list passwd)))
+           (out     (derivation->output-path
+                     (package-derivation store mingetty)))
+           (boot    (add-text-to-store store "boot"
+                                       (object->string
+                                        `(execl ,dmd-file "dmd"
+                                                "--config" ,dmd-conf))
+                                       (list out)))
+           (entries  (list (menu-entry
+                            (label "Boot-to-Guile! (GNU System technology preview)")
+                            (linux linux-libre)
+                            (linux-arguments `("--root=/dev/vda1"
+                                               ,(string-append "--load=" boot)))
+                            (initrd gnu-system-initrd))))
+           (grub.cfg (grub-configuration-file store entries)))
+      (build-derivations store (list pam.d-drv))
+      (qemu-image store
+                  #:grub-configuration grub.cfg
+                  #:populate populate
+                  #:disk-image-size (* 400 (expt 2 20))
+                  #:inputs-to-copy `(("boot" ,boot)
+                                     ("linux" ,linux-libre)
+                                     ("initrd" ,gnu-system-initrd)
+                                     ("coreutils" ,coreutils)
+                                     ("bash" ,bash)
+                                     ("guile" ,guile-2.0)
+                                     ("mingetty" ,mingetty)
+                                     ("dmd" ,dmd)
 
-(define (example2)
+                                     ;; Configuration.
-  (let ((store #f))
+                                     ("dmd.conf" ,dmd-conf)
-    (dynamic-wind
+                                     ("etc-pam.d" ,pam.d)
-      (lambda ()
+                                     ("etc-passwd" ,passwd)
-        (set! store (open-connection)))
+                                     ("etc-shadow" ,shadow)
-      (lambda ()
+                                     ("etc-group" ,group)
-        (parameterize ((%guile-for-build (package-derivation store guile-final)))
+                                     ,@(append-map service-inputs
-          (let* ((bash-drv  (package-derivation store bash))
+                                                   %dmd-services))))))
-                 (bash-file (string-append (derivation-path->output-path bash-drv)
-                                           "/bin/bash"))
-                 (passwd    (/etc/shadow store
-                                         `(("root" 0 0 "System administrator" "/"
-                                            ,bash-file))))
-                 (populate
-                  (add-text-to-store store "populate-qemu-image"
-                                     (object->string
-                                      `(begin
-                                         (mkdir-p "etc")
-                                         (symlink ,(substring passwd 1)
-                                                  "etc/shadow")))
-                                     (list passwd)))
-                 (out   (derivation-path->output-path
-                         (package-derivation store mingetty)))
-                 (getty (string-append out "/sbin/mingetty"))
-                 (boot  (add-text-to-store store "boot"
-                                           (object->string
-                                            `(begin
-                                               ;; Become the session leader,
-                                               ;; so that mingetty can do
-                                               ;; 'TIOCSCTTY'.
-                                               (setsid)
-
-                                               ;; Directly into mingetty.
-                                               (execl ,getty "mingetty"
-                                                      "--noclear" "tty1")))
-                                           (list out)))
-                 (entries  (list (menu-entry
-                                  (label "Boot-to-Guile! (GNU System technology preview)")
-                                  (linux linux-libre)
-                                  (linux-arguments `("--root=/dev/vda1"
-                                                     ,(string-append "--load=" boot)))
-                                  (initrd gnu-system-initrd))))
-                 (grub.cfg (grub-configuration-file store entries)))
-           (qemu-image store
-                       #:grub-configuration grub.cfg
-                       #:populate populate
-                       #:disk-image-size (* 400 (expt 2 20))
-                       #:inputs-to-copy `(("boot" ,boot)
-                                          ("linux" ,linux-libre)
-                                          ("initrd" ,gnu-system-initrd)
-                                          ("coreutils" ,coreutils)
-                                          ("bash" ,bash)
-                                          ("guile" ,guile-2.0)
-                                          ("mingetty" ,mingetty)
-
-                                          ("shadow" ,passwd))))))
-      (lambda ()
-        (close-connection store)))))
 
 ;;; vm.scm ends here

guix/build-system/cmake.scm

@@ -72,9 +72,9 @@ provides a 'CMakeLists.txt' file as its build system."
   (define builder
     `(begin
        (use-modules ,@modules)
-       (cmake-build #:source ,(if (and source (derivation-path? source))
+       (cmake-build #:source ,(if (derivation? source)
-                                 (derivation-path->output-path source)
+                                  (derivation->output-path source)
-                                 source)
+                                  source)
                     #:system ,system
                     #:outputs %outputs
                     #:inputs %build-inputs

guix/build-system/gnu.scm

@@ -291,8 +291,8 @@ which could lead to gratuitous input divergence."
   (define builder
     `(begin
        (use-modules ,@modules)
-       (gnu-build #:source ,(if (and source (derivation-path? source))
+       (gnu-build #:source ,(if (derivation? source)
-                                (derivation-path->output-path source)
+                                (derivation->output-path source)
                                 source)
                   #:system ,system
                   #:outputs %outputs
@@ -319,8 +319,8 @@ which could lead to gratuitous input divergence."
     (match guile
       ((? package?)
        (package-derivation store guile system))
-      ((and (? string?) (? derivation-path?))
+      ;; ((and (? string?) (? derivation-path?))
-       guile)
+      ;;  guile)
       (#f                                         ; the default
        (let* ((distro (resolve-interface '(gnu packages base)))
               (guile  (module-ref distro 'guile-final)))
@@ -438,6 +438,8 @@ platform."
        (let ()
          (define %build-host-inputs
            ',(map (match-lambda
+                   ((name (? derivation? drv) sub ...)
+                    `(,name . ,(apply derivation->output-path drv sub)))
                    ((name (? derivation-path? drv-path) sub ...)
                     `(,name . ,(apply derivation-path->output-path
                                       drv-path sub)))
@@ -447,6 +449,8 @@ platform."
 
          (define %build-target-inputs
            ',(map (match-lambda
+                   ((name (? derivation? drv) sub ...)
+                    `(,name . ,(apply derivation->output-path drv sub)))
                    ((name (? derivation-path? drv-path) sub ...)
                     `(,name . ,(apply derivation-path->output-path
                                       drv-path sub)))
@@ -454,8 +458,8 @@ platform."
                     `(,name . ,path)))
                   (append (or implicit-target-inputs '()) inputs)))
 
-         (gnu-build #:source ,(if (and source (derivation-path? source))
+         (gnu-build #:source ,(if (derivation? source)
-                                  (derivation-path->output-path source)
+                                  (derivation->output-path source)
                                   source)
                     #:system ,system
                     #:target ,target
@@ -488,8 +492,8 @@ platform."
     (match guile
       ((? package?)
        (package-derivation store guile system))
-      ((and (? string?) (? derivation-path?))
+      ;; ((and (? string?) (? derivation-path?))
-       guile)
+      ;;  guile)
       (#f                                         ; the default
        (let* ((distro (resolve-interface '(gnu packages base)))
               (guile  (module-ref distro 'guile-final)))

guix/build-system/perl.scm

@@ -62,8 +62,8 @@ provides a `Makefile.PL' file as its build system."
     `(begin
        (use-modules ,@modules)
        (perl-build #:name ,name
-                   #:source ,(if (and source (derivation-path? source))
+                   #:source ,(if (derivation? source)
-                                 (derivation-path->output-path source)
+                                 (derivation->output-path source)
                                  source)
                    #:search-paths ',(map search-path-specification->sexp
                                          (append perl-search-paths

guix/build-system/python.scm

@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -25,7 +26,9 @@
   #:use-module (guix build-system)
   #:use-module (guix build-system gnu)
   #:use-module (ice-9 match)
-  #:export (python-build
+  #:use-module (srfi srfi-26)
+  #:export (package-with-python2
+            python-build
             python-build-system))
 
 ;; Commentary:
@@ -39,13 +42,60 @@
   "Return the default Python package."
   ;; Lazily resolve the binding to avoid a circular dependency.
   (let ((python (resolve-interface '(gnu packages python))))
-    (module-ref python 'python)))
+    (module-ref python 'python-wrapper)))
+
+(define (default-python2)
+  "Return the default Python 2 package."
+  (let ((python (resolve-interface '(gnu packages python))))
+    (module-ref python 'python-2)))
+
+(define (package-with-explicit-python p python old-prefix new-prefix)
+  "Create a package with the same fields as P, which is assumed to use
+PYTHON-BUILD-SYSTEM, such that it is compiled with PYTHON instead.  The
+inputs are changed recursively accordingly.  If the name of P starts with
+OLD-PREFIX, this is replaced by NEW-PREFIX; otherwise, NEW-PREFIX is
+prepended to the name."
+  (let* ((build-system (package-build-system p))
+         (rewrite-if-package
+          (lambda (content)
+            ;; CONTENT may be a string (e.g., for patches), in which case it
+            ;; is returned, or a package, which is rewritten with the new
+            ;; PYTHON and NEW-PREFIX.
+            (if (package? content)
+                (package-with-explicit-python content python
+                                              old-prefix new-prefix)
+                content)))
+         (rewrite
+           (match-lambda
+             ((name content . rest)
+              (append (list name (rewrite-if-package content)) rest)))))
+    (package (inherit p)
+      (name
+        (let ((name (package-name p)))
+          (if (eq? build-system python-build-system)
+              (string-append new-prefix
+                             (if (string-prefix? old-prefix name)
+                                 (substring name (string-length old-prefix))
+                                 name))
+              name)))
+      (arguments
+        (let ((arguments (package-arguments p)))
+          (if (eq? build-system python-build-system)
+              (if (member #:python arguments)
+                  (substitute-keyword-arguments arguments ((#:python p) python))
+                  (append arguments `(#:python ,python)))
+              arguments)))
+      (inputs
+        (map rewrite (package-inputs p)))
+      (native-inputs
+        (map rewrite (package-native-inputs p))))))
+
+(define package-with-python2
+  (cut package-with-explicit-python <> (default-python2) "python-" "python2-"))
 
 (define* (python-build store name source inputs
                        #:key
                        (python (default-python))
-                       (python-version
-                        (string-take (package-version (default-python)) 3))
                        (tests? #t)
                        (configure-flags ''())
                        (phases '(@ (guix build python-build-system)
@@ -58,10 +108,10 @@
                                            (guix build gnu-build-system)
                                            (guix build utils)))
                        (modules '((guix build python-build-system)
-                                  (guix build gnu-build-system)
                                   (guix build utils))))
   "Build SOURCE using PYTHON, and with INPUTS.  This assumes that SOURCE
 provides a 'setup.py' file as its build system."
+
   (define python-search-paths
     (append (package-native-search-paths python)
             (standard-search-paths)))
@@ -70,15 +120,15 @@ provides a 'setup.py' file as its build system."
     `(begin
        (use-modules ,@modules)
        (python-build #:name ,name
-                     #:source ,(if (and source (derivation-path? source))
+                     #:source ,(if (derivation? source)
-                                   (derivation-path->output-path source)
+                                   (derivation->output-path source)
                                    source)
                      #:configure-flags ,configure-flags
                      #:system ,system
                      #:test-target "test"
                      #:tests? ,tests?
+                     #:phases ,phases
                      #:outputs %outputs
-                     #:python-version ,python-version
                      #:search-paths ',(map search-path-specification->sexp
                                            (append python-search-paths
                                                    search-paths))

guix/build/linux-initrd.scm

@@ -89,6 +89,10 @@
                   (device-number 4 n))
            (loop (+ 1 n)))))
 
+  ;; Rendez-vous point for syslogd.
+  (mknod (scope "dev/log") 'socket #o666 0)
+  (mknod (scope "dev/kmsg") 'char-special #o600 (device-number 1 11))
+
   ;; Other useful nodes.
   (mknod (scope "dev/null") 'char-special #o666 (device-number 1 3))
   (mknod (scope "dev/zero") 'char-special #o666 (device-number 1 5)))

guix/build/python-build-system.scm

@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -34,26 +35,49 @@
 ;;
 ;; Code:
 
-(define* (install #:key outputs (configure-flags '())
-                  #:allow-other-keys)
-  "Install a given Python package."
-  (let ((out (assoc-ref outputs "out")))
-    (if (file-exists? "setup.py")
-        (let ((args `("setup.py" "install" ,(string-append "--prefix=" out)
-                      ,@configure-flags)))
-          (format #t "running 'python' with arguments ~s~%" args)
-          (zero? (apply system* "python" args)))
-        (error "no setup.py found"))))
 
-(define* (check #:key outputs #:allow-other-keys)
+(define (call-setuppy command params)
-  "Run the test suite of a given Python package."
   (if (file-exists? "setup.py")
-      (let ((args `("setup.py" "check")))
+      (begin
-        (format #t "running 'python' with arguments ~s~%" args)
+         (format #t "running \"python setup.py\" with command ~s and parameters ~s~%"
-        (zero? (apply system* "python" args)))
+                command params)
+         (zero? (apply system* "python" "setup.py" command params)))
       (error "no setup.py found")))
 
-(define* (wrap #:key outputs python-version #:allow-other-keys)
+(define* (build #:rest empty)
+  "Build a given Python package."
+  (call-setuppy "build" '()))
+
+(define* (check #:key tests? test-target #:allow-other-keys)
+  "Run the test suite of a given Python package."
+  (if tests?
+    (call-setuppy test-target '())
+    #t))
+
+(define (get-python-version python)
+  (string-take (string-take-right python 5) 3))
+
+(define* (install #:key outputs inputs (configure-flags '())
+                  #:allow-other-keys)
+  "Install a given Python package."
+  (let* ((out (assoc-ref outputs "out"))
+         (params (append (list (string-append "--prefix=" out))
+                         configure-flags))
+         (python-version (get-python-version (assoc-ref inputs "python")))
+         (old-path (getenv "PYTHONPATH"))
+         (add-path (string-append out "/lib/python" python-version
+                                  "/site-packages/")))
+        ;; create the module installation directory and add it to PYTHONPATH
+        ;; to make setuptools happy
+        (mkdir-p add-path)
+        (setenv "PYTHONPATH"
+                (string-append (if old-path
+                                   (string-append old-path ":")
+                                   "")
+                               add-path))
+        (call-setuppy "install" params)))
+
+(define* (wrap #:key inputs outputs #:allow-other-keys)
   (define (list-of-files dir)
     (map (cut string-append dir "/" <>)
          (or (scandir dir (lambda (f)
@@ -69,9 +93,11 @@
                 outputs))
 
   (let* ((out  (assoc-ref outputs "out"))
+         (python (assoc-ref inputs "python"))
          (var `("PYTHONPATH" prefix
                 ,(cons (string-append out "/lib/python"
-                                      python-version "/site-packages")
+                                      (get-python-version python)
+                                      "/site-packages")
                        (search-path-as-string->list
                         (or (getenv "PYTHONPATH") ""))))))
     (for-each (lambda (dir)
@@ -87,11 +113,12 @@
    'install 'wrap
    wrap
    (alist-replace
-    'check check
+    'build build
-    (alist-replace 'install install
+    (alist-replace
-                   (alist-delete 'configure
+     'check check
-                                (alist-delete 'build
+     (alist-replace 'install install
-                                              gnu:%standard-phases))))))
+                    (alist-delete 'configure
+                                               gnu:%standard-phases))))))
 
 (define* (python-build #:key inputs (phases %standard-phases)
                        #:allow-other-keys #:rest args)

guix/derivations.scm

@@ -19,6 +19,7 @@
 (define-module (guix derivations)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-26)
   #:use-module (rnrs io ports)
   #:use-module (rnrs bytevectors)
@@ -36,6 +37,7 @@
             derivation-system
             derivation-builder-arguments
             derivation-builder-environment-vars
+            derivation-file-name
             derivation-prerequisites
             derivation-prerequisites-to-build
 
@@ -56,6 +58,8 @@
 
             read-derivation
             write-derivation
+            derivation->output-path
+            derivation->output-paths
             derivation-path->output-path
             derivation-path->output-paths
             derivation
@@ -64,14 +68,16 @@
             imported-modules
             compiled-modules
             build-expression->derivation
-            imported-files))
+            imported-files)
+  #:replace (build-derivations))
 
 ;;;
 ;;; Nix derivations, as implemented in Nix's `derivations.cc'.
 ;;;
 
 (define-record-type <derivation>
-  (make-derivation outputs inputs sources system builder args env-vars)
+  (make-derivation outputs inputs sources system builder args env-vars
+                   file-name)
   derivation?
   (outputs  derivation-outputs)      ; list of name/<derivation-output> pairs
   (inputs   derivation-inputs)       ; list of <derivation-input>
@@ -79,7 +85,8 @@
   (system   derivation-system)       ; string
   (builder  derivation-builder)      ; store path
   (args     derivation-builder-arguments)         ; list of strings
-  (env-vars derivation-builder-environment-vars)) ; list of name/value pairs
+  (env-vars derivation-builder-environment-vars)  ; list of name/value pairs
+  (file-name derivation-file-name))               ; the .drv file name
 
 (define-record-type <derivation-output>
   (make-derivation-output path hash-algo hash)
@@ -94,6 +101,17 @@
   (path            derivation-input-path)             ; store path
   (sub-derivations derivation-input-sub-derivations)) ; list of strings
 
+(set-record-type-printer! <derivation>
+                          (lambda (drv port)
+                            (format port "#<derivation ~a => ~a ~a>"
+                                    (derivation-file-name drv)
+                                    (string-join
+                                     (map (match-lambda
+                                           ((_ . output)
+                                            (derivation-output-path output)))
+                                          (derivation-outputs drv)))
+                                    (number->string (object-address drv) 16))))
+
 (define (fixed-output-derivation? drv)
   "Return #t if DRV is a fixed-output derivation, such as the result of a
 download with a fixed hash (aka. `fetchurl')."
@@ -262,7 +280,8 @@ that second value is the empty list."
                              (make-input-drvs input-drvs)
                              input-srcs
                              system builder args
-                             (fold-right alist-cons '() var value)))
+                             (fold-right alist-cons '() var value)
+                             (port-filename drv-port)))
            (_
             (error "failed to parse derivation" drv-port result)))))
       ((? (cut eq? <> comma))
@@ -404,25 +423,30 @@ that form."
                  port)
      (display ")" port))))
 
+(define* (derivation->output-path drv #:optional (output "out"))
+  "Return the store path of its output OUTPUT."
+  (let ((outputs (derivation-outputs drv)))
+    (and=> (assoc-ref outputs output) derivation-output-path)))
+
+(define (derivation->output-paths drv)
+  "Return the list of name/path pairs of the outputs of DRV."
+  (map (match-lambda
+        ((name . output)
+         (cons name (derivation-output-path output))))
+       (derivation-outputs drv)))
+
 (define derivation-path->output-path
   ;; This procedure is called frequently, so memoize it.
   (memoize
    (lambda* (path #:optional (output "out"))
      "Read the derivation from PATH (`/nix/store/xxx.drv'), and return the store
 path of its output OUTPUT."
-     (let* ((drv     (call-with-input-file path read-derivation))
+     (derivation->output-path (call-with-input-file path read-derivation)))))
-            (outputs (derivation-outputs drv)))
-       (and=> (assoc-ref outputs output) derivation-output-path)))))
 
 (define (derivation-path->output-paths path)
   "Read the derivation from PATH (`/nix/store/xxx.drv'), and return the
 list of name/path pairs of its outputs."
-  (let* ((drv     (call-with-input-file path read-derivation))
+  (derivation->output-paths (call-with-input-file path read-derivation)))
-         (outputs (derivation-outputs drv)))
-    (map (match-lambda
-          ((name . output)
-           (cons name (derivation-output-path output))))
-         outputs)))
 
 
 ;;;
@@ -470,7 +494,8 @@ in SIZE bytes."
                                (make-derivation-input hash sub-drvs))))
                            inputs))
               (drv    (make-derivation outputs inputs sources
-                                       system builder args env-vars)))
+                                       system builder args env-vars
+                                       #f)))
 
          ;; XXX: At this point this remains faster than `port-sha256', because
          ;; the SHA256 port's `write' method gets called for every single
@@ -505,10 +530,10 @@ the derivation called NAME with hash HASH."
                      (inputs '()) (outputs '("out"))
                      hash hash-algo hash-mode
                      references-graphs)
-  "Build a derivation with the given arguments.  Return the resulting
+  "Build a derivation with the given arguments, and return the resulting
-store path and <derivation> object.  When HASH, HASH-ALGO, and HASH-MODE
+<derivation> object.  When HASH, HASH-ALGO, and HASH-MODE are given, a
-are given, a fixed-output derivation is created---i.e., one whose result is
+fixed-output derivation is created---i.e., one whose result is known in
-known in advance, such as a file download.
+advance, such as a file download.
 
 When REFERENCES-GRAPHS is true, it must be a list of file name/store path
 pairs.  In that case, the reference graph of each store path is exported in
@@ -545,7 +570,8 @@ the build environment in the corresponding file, in a simple text format."
                                        (or (and=> (assoc-ref outputs name)
                                                   derivation-output-path)
                                            value))))
-                               env-vars))))))
+                               env-vars)
+                          #f)))))
 
   (define (user+system-env-vars)
     ;; Some options are passed to the build daemon via the env. vars of
@@ -578,12 +604,26 @@ the build environment in the corresponding file, in a simple text format."
             e
             outputs)))
 
+  (define (set-file-name drv file)
+    ;; Set FILE as the 'file-name' field of DRV.
+    (match drv
+      (($ <derivation> outputs inputs sources system builder
+          args env-vars)
+       (make-derivation outputs inputs sources system builder
+                        args env-vars file))))
+
   (let* ((outputs    (map (lambda (name)
                             ;; Return outputs with an empty path.
                             (cons name
                                   (make-derivation-output "" hash-algo hash)))
                           outputs))
          (inputs     (map (match-lambda
+                           (((? derivation? drv))
+                            (make-derivation-input (derivation-file-name drv)
+                                                   '("out")))
+                           (((? derivation? drv) sub-drvs ...)
+                            (make-derivation-input (derivation-file-name drv)
+                                                   sub-drvs))
                            (((? direct-store-path? input))
                             (make-derivation-input input '("out")))
                            (((? direct-store-path? input) sub-drvs ...)
@@ -604,17 +644,29 @@ the build environment in the corresponding file, in a simple text format."
                                                       (and (not (derivation-path? p))
                                                            p)))
                                                   inputs)
-                                      system builder args env-vars))
+                                      system builder args env-vars #f))
          (drv        (add-output-paths drv-masked)))
 
-    ;; (write-derivation drv-masked (current-error-port))
+    (let ((file (add-text-to-store store (string-append name ".drv")
-    ;; (newline (current-error-port))
+                                   (call-with-output-string
-    (values (add-text-to-store store (string-append name ".drv")
+                                    (cut write-derivation drv <>))
-                               (call-with-output-string
+                                   (map derivation-input-path
-                                (cut write-derivation drv <>))
+                                        inputs))))
-                               (map derivation-input-path
+      (set-file-name drv file))))
-                                    inputs))
+
-            drv)))
+
+;;;
+;;; Store compatibility layer.
+;;;
+
+(define (build-derivations store derivations)
+  "Build DERIVATIONS, a list of <derivation> objects or .drv file names."
+  (let ((build (@ (guix store) build-derivations)))
+    (build store (map (match-lambda
+                       ((? string? file) file)
+                       ((and drv ($ <derivation>))
+                        (derivation-file-name drv)))
+                      derivations))))
 
 
 ;;;
@@ -706,7 +758,7 @@ they can refer to each other."
                                        #:system system
                                        #:guile guile
                                        #:module-path module-path))
-         (module-dir (derivation-path->output-path module-drv))
+         (module-dir (derivation->output-path module-drv))
          (files      (map (lambda (m)
                             (let ((f (string-join (map symbol->string m)
                                                   "/")))
@@ -770,7 +822,7 @@ See the `derivation' procedure for the meaning of REFERENCES-GRAPHS."
     (or guile-for-build (%guile-for-build)))
 
   (define guile
-    (string-append (derivation-path->output-path guile-drv)
+    (string-append (derivation->output-path guile-drv)
                    "/bin/guile"))
 
   (define module-form?
@@ -782,6 +834,8 @@ See the `derivation' procedure for the meaning of REFERENCES-GRAPHS."
     ;; When passed an input that is a source, return its path; otherwise
     ;; return #f.
     (match-lambda
+     ((_ (? derivation?) _ ...)
+      #f)
      ((_ path _ ...)
       (and (not (derivation-path? path))
            path))))
@@ -806,10 +860,13 @@ See the `derivation' procedure for the meaning of REFERENCES-GRAPHS."
                                               (() "out")
                                               ((x) x))))
                                    (cons name
-                                         (if (derivation-path? drv)
+                                         (cond
-                                             (derivation-path->output-path drv
+                                          ((derivation? drv)
-                                                                           sub)
+                                           (derivation->output-path drv sub))
-                                             drv)))))
+                                          ((derivation-path? drv)
+                                           (derivation-path->output-path drv
+                                                                         sub))
+                                          (else drv))))))
                                inputs))
 
                       ,@(if (null? modules)
@@ -854,13 +911,13 @@ See the `derivation' procedure for the meaning of REFERENCES-GRAPHS."
                                           #:guile guile-drv
                                           #:system system)))
          (mod-dir  (and mod-drv
-                        (derivation-path->output-path mod-drv)))
+                        (derivation->output-path mod-drv)))
          (go-drv   (and (pair? modules)
                         (compiled-modules store modules
                                           #:guile guile-drv
                                           #:system system)))
          (go-dir   (and go-drv
-                        (derivation-path->output-path go-drv))))
+                        (derivation->output-path go-drv))))
     (derivation store name guile
                 `("--no-auto-compile"
                   ,@(if mod-dir `("-L" ,mod-dir) '())

guix/download.scm

@@ -25,7 +25,6 @@
   #:use-module ((guix build download) #:renamer (symbol-prefix-proc 'build:))
   #:use-module (guix utils)
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:export (%mirrors
             url-fetch
@@ -212,27 +211,22 @@ must be a list of symbol/URL-list pairs."
         ((url ...)
          (any https? url)))))
 
-  (let*-values (((gnutls-drv-path gnutls-drv)
+  (let* ((gnutls-drv (if need-gnutls?
-                 (if need-gnutls?
+                         (gnutls-derivation store system)
-                     (gnutls-derivation store system)
+                         (values #f #f)))
-                     (values #f #f)))
+         (gnutls     (and gnutls-drv
-                ((gnutls)
+                          (derivation->output-path gnutls-drv "out")))
-                 (and gnutls-drv
+         (env-vars   (if gnutls
-                      (derivation-output-path
+                         (let ((dir (string-append gnutls "/share/guile/site")))
-                       (assoc-ref (derivation-outputs gnutls-drv)
+                           ;; XXX: `GUILE_LOAD_COMPILED_PATH' is overridden
-                                  "out"))))
+                           ;; by `build-expression->derivation', so we can't
-                ((env-vars)
+                           ;; set it here.
-                 (if gnutls
+                           `(("GUILE_LOAD_PATH" . ,dir)))
-                     (let ((dir (string-append gnutls "/share/guile/site")))
+                         '())))
-                       ;; XXX: `GUILE_LOAD_COMPILED_PATH' is overridden
-                       ;; by `build-expression->derivation', so we can't
-                       ;; set it here.
-                       `(("GUILE_LOAD_PATH" . ,dir)))
-                     '())))
     (build-expression->derivation store (or name file-name) system
                                   builder
                                   (if gnutls-drv
-                                      `(("gnutls" ,gnutls-drv-path))
+                                      `(("gnutls" ,gnutls-drv))
                                       '())
                                   #:hash-algo hash-algo
                                   #:hash hash

guix/nar.scm

@@ -76,10 +76,11 @@
     ;; avoid stat'ing like crazy.
     (with-fluids ((%file-port-name-canonicalization #f))
       (let ((port (open-file file "rb")))
-        (catch #t (cut proc port)
+        (dynamic-wind
-          (lambda args
+          (const #t)
-            (close-port port)
+          (cut proc port)
-            (apply throw args))))))
+          (lambda ()
+            (close-port port))))))
 
   (write-string "contents" p)
   (write-long-long size p)

guix/packages.scm

@@ -26,7 +26,6 @@
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9 gnu)
-  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
@@ -370,8 +369,8 @@ information in exceptions."
 
 (define* (package-derivation store package
                              #:optional (system (%current-system)))
-  "Return the derivation path and corresponding <derivation> object of
+  "Return the <derivation> object of PACKAGE for SYSTEM."
-PACKAGE for SYSTEM."
+
   ;; Compute the derivation and cache the result.  Caching is important
   ;; because some derivations, such as the implicit inputs of the GNU build
   ;; system, will be queried many, many times in a row.
@@ -468,7 +467,5 @@ system identifying string)."
   "Return the output path of PACKAGE's OUTPUT for SYSTEM---where OUTPUT is the
 symbolic output name, such as \"out\".  Note that this procedure calls
 `package-derivation', which is costly."
-  (let-values (((_ drv)
+  (let ((drv (package-derivation store package system)))
-                (package-derivation store package system)))
+    (derivation->output-path drv output)))
-    (derivation-output-path
-     (assoc-ref (derivation-outputs drv) output))))

guix/scripts/build.scm

@@ -250,7 +250,7 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
                                    (derivations-from-package-expressions
                                     str package->derivation sys src?))
                                   (('argument . (? derivation-path? drv))
-                                   drv)
+                                   (call-with-input-file drv read-derivation))
                                   (('argument . (? string? x))
                                    (let ((p (find-package x)))
                                      (if src?
@@ -280,24 +280,23 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
 
           (if (assoc-ref opts 'derivations-only?)
               (begin
-                (format #t "~{~a~%~}" drv)
+                (format #t "~{~a~%~}" (map derivation-file-name drv))
                 (for-each (cut register-root <> <>)
-                          (map list drv) roots))
+                          (map (compose list derivation-file-name) drv)
+                          roots))
               (or (assoc-ref opts 'dry-run?)
                   (and (build-derivations (%store) drv)
                        (for-each (lambda (d)
-                                   (let ((drv (call-with-input-file d
+                                   (format #t "~{~a~%~}"
-                                                read-derivation)))
+                                           (map (match-lambda
-                                     (format #t "~{~a~%~}"
+                                                 ((out-name . out)
-                                             (map (match-lambda
+                                                  (derivation->output-path
-                                                   ((out-name . out)
+                                                   d out-name)))
-                                                    (derivation-path->output-path
+                                                (derivation-outputs d))))
-                                                     d out-name)))
-                                                  (derivation-outputs drv)))))
                                  drv)
                        (for-each (cut register-root <> <>)
                                  (map (lambda (drv)
                                         (map cdr
-                                             (derivation-path->output-paths drv)))
+                                             (derivation->output-paths drv)))
                                       drv)
                                  roots)))))))))

guix/scripts/package.scm

@@ -34,6 +34,7 @@
   #:use-module (ice-9 vlist)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-37)
@@ -95,8 +96,8 @@
   (make-regexp (string-append "^" (regexp-quote (basename profile))
                               "-([0-9]+)")))
 
-(define (profile-numbers profile)
+(define (generation-numbers profile)
-  "Return the list of generation numbers of PROFILE, or '(0) if no
+  "Return the sorted list of generation numbers of PROFILE, or '(0) if no
 former profiles were found."
   (define* (scandir name #:optional (select? (const #t))
                     (entry<? (@ (ice-9 i18n) string-locale<?)))
@@ -139,12 +140,13 @@ former profiles were found."
     (()                                         ; no profiles
      '(0))
     ((profiles ...)                             ; former profiles around
-     (map (compose string->number
+     (sort (map (compose string->number
-                   (cut match:substring <> 1)
+                         (cut match:substring <> 1)
-                   (cute regexp-exec (profile-regexp profile) <>))
+                         (cute regexp-exec (profile-regexp profile) <>))
-          profiles))))
+                profiles)
+           <))))
 
-(define (previous-profile-number profile number)
+(define (previous-generation-number profile number)
   "Return the number of the generation before generation NUMBER of
 PROFILE, or 0 if none exists.  It could be NUMBER - 1, but it's not the
 case when generations have been deleted (there are \"holes\")."
@@ -153,7 +155,7 @@ case when generations have been deleted (there are \"holes\")."
               candidate
               highest))
         0
-        (profile-numbers profile)))
+        (generation-numbers profile)))
 
 (define (profile-derivation store packages)
   "Return a derivation that builds a profile (a user environment) with
@@ -205,7 +207,7 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
                                             packages)
                                 #:modules '((guix build union))))
 
-(define (profile-number profile)
+(define (generation-number profile)
   "Return PROFILE's number or 0.  An absolute file name must be used."
   (or (and=> (false-if-exception (regexp-exec (profile-regexp profile)
                                               (basename (readlink profile))))
@@ -214,17 +216,17 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
 
 (define (roll-back profile)
   "Roll back to the previous generation of PROFILE."
-  (let* ((number           (profile-number profile))
+  (let* ((number              (generation-number profile))
-         (previous-number  (previous-profile-number profile number))
+         (previous-number     (previous-generation-number profile number))
-         (previous-profile (format #f "~a-~a-link"
+         (previous-generation (format #f "~a-~a-link"
-                                   profile previous-number))
+                                      profile previous-number))
-         (manifest         (string-append previous-profile "/manifest")))
+         (manifest            (string-append previous-generation "/manifest")))
 
     (define (switch-link)
-      ;; Atomically switch PROFILE to the previous profile.
+      ;; Atomically switch PROFILE to the previous generation.
       (format #t (_ "switching from generation ~a to ~a~%")
               number previous-number)
-      (switch-symlinks profile previous-profile))
+      (switch-symlinks profile previous-generation))
 
     (cond ((not (file-exists? profile))           ; invalid profile
            (leave (_ "profile `~a' does not exist~%")
@@ -233,19 +235,84 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
            (format (current-error-port)
                    (_ "nothing to do: already at the empty profile~%")))
           ((or (zero? previous-number)            ; going to emptiness
-               (not (file-exists? previous-profile)))
+               (not (file-exists? previous-generation)))
-           (let*-values (((drv-path drv)
+           (let* ((drv  (profile-derivation (%store) '()))
-                          (profile-derivation (%store) '()))
+                  (prof (derivation->output-path drv "out")))
-                         ((prof)
+             (when (not (build-derivations (%store) (list drv)))
-                          (derivation-output-path
-                           (assoc-ref (derivation-outputs drv) "out"))))
-             (when (not (build-derivations (%store) (list drv-path)))
                (leave (_ "failed to build the empty profile~%")))
 
-             (switch-symlinks previous-profile prof)
+             (switch-symlinks previous-generation prof)
              (switch-link)))
           (else (switch-link)))))                 ; anything else
 
+(define (generation-time profile number)
+  "Return the creation time of a generation in the UTC format."
+  (make-time time-utc 0
+             (stat:ctime (stat (format #f "~a-~a-link" profile number)))))
+
+(define* (matching-generations str #:optional (profile %current-profile))
+  "Return the list of available generations matching a pattern in STR.  See
+'string->generations' and 'string->duration' for the list of valid patterns."
+  (define (valid-generations lst)
+    (define (valid-generation? n)
+      (any (cut = n <>) (generation-numbers profile)))
+
+    (fold-right (lambda (x acc)
+                  (if (valid-generation? x)
+                      (cons x acc)
+                      acc))
+                '()
+                lst))
+
+  (define (filter-generations generations)
+    (match generations
+      (() '())
+      (('>= n)
+       (drop-while (cut > n <>)
+                   (generation-numbers profile)))
+      (('<= n)
+       (valid-generations (iota n 1)))
+      ((lst ..1)
+       (valid-generations lst))
+      (_ #f)))
+
+  (define (filter-by-duration duration)
+    (define (time-at-midnight time)
+      ;; Return TIME at midnight by setting nanoseconds, seconds, minutes, and
+      ;; hours to zeros.
+      (let ((d (time-utc->date time)))
+         (date->time-utc
+          (make-date 0 0 0 0
+                     (date-day d) (date-month d)
+                     (date-year d) (date-zone-offset d)))))
+
+    (define generation-ctime-alist
+      (map (lambda (number)
+             (cons number
+                   (time-second
+                    (time-at-midnight
+                     (generation-time profile number)))))
+           (generation-numbers profile)))
+
+    (match duration
+      (#f #f)
+      (res
+       (let ((s (time-second
+                 (subtract-duration (time-at-midnight (current-time))
+                                    duration))))
+         (delete #f (map (lambda (x)
+                           (and (<= s (cdr x))
+                                (first x)))
+                         generation-ctime-alist))))))
+
+  (cond ((string->generations str)
+         =>
+         filter-generations)
+        ((string->duration str)
+         =>
+         filter-by-duration)
+        (else #f)))
+
 (define (find-packages-by-description rx)
   "Search in SYNOPSIS and DESCRIPTION using RX.  Return a list of
 matching packages."
@@ -441,6 +508,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
       --roll-back        roll back to the previous generation"))
   (display (_ "
       --search-paths     display needed environment variable definitions"))
+  (display (_ "
+  -l, --list-generations[=PATTERN]
+                         list generations matching PATTERN"))
   (newline)
   (display (_ "
   -p, --profile=PROFILE  use PROFILE instead of the user's default profile"))
@@ -500,6 +570,10 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
         (option '("roll-back") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'roll-back? #t result)))
+        (option '(#\l "list-generations") #f #t
+                (lambda (opt name arg result)
+                  (cons `(query list-generations ,(or arg ""))
+                        result)))
         (option '("search-paths") #f #f
                 (lambda (opt name arg result)
                   (cons `(query search-paths) result)))
@@ -558,7 +632,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
 
   (define (guile-missing?)
     ;; Return #t if %GUILE-FOR-BUILD is not available yet.
-    (let ((out (derivation-path->output-path (%guile-for-build))))
+    (let ((out (derivation->output-path (%guile-for-build))))
       (not (valid-path? (%store) out))))
 
   (define newest-available-packages
@@ -617,7 +691,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
        (case (version-compare candidate-version current-version)
          ((>) #t)
          ((<) #f)
-         ((=) (let ((candidate-path (derivation-path->output-path
+         ((=) (let ((candidate-path (derivation->output-path
                                      (package-derivation (%store) pkg))))
                 (not (string=? current-path candidate-path))))))
       (#f #f)))
@@ -808,7 +882,7 @@ more information.~%"))
                                  (match tuple
                                    ((name version sub-drv _ (deps ...))
                                     (let ((output-path
-                                           (derivation-path->output-path
+                                           (derivation->output-path
                                             drv sub-drv)))
                                       `(,name ,version ,sub-drv ,output-path
                                               ,(canonicalize-deps deps))))))
@@ -841,12 +915,12 @@ more information.~%"))
           (or dry-run?
               (and (build-derivations (%store) drv)
                    (let* ((prof-drv (profile-derivation (%store) packages))
-                          (prof     (derivation-path->output-path prof-drv))
+                          (prof     (derivation->output-path prof-drv))
                           (old-drv  (profile-derivation
                                      (%store) (manifest-packages
                                                (profile-manifest profile))))
-                          (old-prof (derivation-path->output-path old-drv))
+                          (old-prof (derivation->output-path old-drv))
-                          (number   (profile-number profile))
+                          (number   (generation-number profile))
 
                           ;; Always use NUMBER + 1 for the new profile,
                           ;; possibly overwriting a "previous future
@@ -879,6 +953,40 @@ more information.~%"))
     ;; actually processed, #f otherwise.
     (let ((profile  (assoc-ref opts 'profile)))
       (match (assoc-ref opts 'query)
+        (('list-generations pattern)
+         (define (list-generation number)
+           (begin
+             (format #t (_ "Generation ~a\t~a~%") number
+                     (date->string
+                      (time-utc->date
+                       (generation-time profile number))
+                      "~b ~d ~Y ~T"))
+             (for-each (match-lambda
+                        ((name version output location _)
+                         (format #t "  ~a\t~a\t~a\t~a~%"
+                                 name version output location)))
+
+                       ;; Show most recently installed packages last.
+                       (reverse
+                        (manifest-packages
+                         (profile-manifest
+                          (format #f "~a-~a-link" profile number)))))
+             (newline)))
+
+         (cond ((not (file-exists? profile)) ; XXX: race condition
+                (leave (_ "profile '~a' does not exist~%")
+                       profile))
+               ((string-null? pattern)
+                (for-each list-generation
+                          (generation-numbers profile)))
+               ((matching-generations pattern profile)
+                =>
+                (cut for-each list-generation <>))
+               (else
+                (leave (_ "invalid syntax: ~a~%")
+                       pattern)))
+         #t)
+
         (('list-installed regexp)
          (let* ((regexp    (and regexp (make-regexp regexp)))
                 (manifest  (profile-manifest profile))
@@ -889,7 +997,9 @@ more information.~%"))
                                  (regexp-exec regexp name))
                          (format #t "~a\t~a\t~a\t~a~%"
                                  name (or version "?") output path))))
-                     installed)
+
+                     ;; Show most recently installed packages last.
+                     (reverse installed))
            #t))
 
         (('list-available regexp)

guix/scripts/pull.scm

@@ -29,7 +29,6 @@
   #:use-module (gnu packages compression)
   #:use-module (gnu packages gnupg)
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-37)
   #:export (guix-pull))
 
@@ -198,13 +197,9 @@ Download and deploy the latest version of Guix.\n"))
                         (if (assoc-ref opts 'verbose?)
                             (current-error-port)
                             (%make-void-port "w"))))
-          (let*-values (((config-dir)
+          (let* ((config-dir (config-directory))
-                         (config-directory))
+                 (source     (unpack store tarball))
-                        ((source drv)
+                 (source-dir (derivation->output-path source)))
-                         (unpack store tarball))
-                        ((source-dir)
-                         (derivation-output-path
-                          (assoc-ref (derivation-outputs drv) "out"))))
             (if (show-what-to-build store (list source))
                 (if (build-derivations store (list source))
                     (let ((latest (string-append config-dir "/latest")))

guix/scripts/substitute-binary.scm

@@ -444,6 +444,30 @@ PORT.  REPORT-PROGRESS is a two-argument procedure such as that returned by
          (leave (_ "host name lookup error: ~a~%")
                 (gai-strerror error)))))))
 
+
+;;;
+;;; Help.
+;;;
+
+(define (show-help)
+  (display (_ "Usage: guix substitute-binary [OPTION]...
+Internal tool to substitute a pre-built binary to a local build.\n"))
+  (display (_ "
+      --query            report on the availability of substitutes for the
+                         store file names passed on the standard input"))
+  (display (_ "
+      --substitute STORE-FILE DESTINATION
+                         download STORE-FILE and store it as a Nar in file
+                         DESTINATION"))
+  (newline)
+  (display (_ "
+  -h, --help             display this help and exit"))
+  (display (_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+
 
 ;;;
 ;;; Entry point.
@@ -536,7 +560,11 @@ PORT.  REPORT-PROGRESS is a two-argument procedure such as that returned by
           (restore-file input destination)
           (every (compose zero? cdr waitpid) pids))))
      (("--version")
-      (show-version-and-exit "guix substitute-binary")))))
+      (show-version-and-exit "guix substitute-binary"))
+     (("--help")
+      (show-help))
+     (opts
+      (leave (_ "~a: unrecognized options~%") opts)))))
 
 
 ;;; Local Variables:

guix/store.scm

@@ -452,7 +452,7 @@ encoding conversion errors."
                                        (string-list references))
                     #f
                     store-path)))
-    (lambda (server name text references)
+    (lambda* (server name text #:optional (references '()))
       "Add TEXT under file NAME in the store, and return its store path.
 REFERENCES is the list of store paths referred to by the resulting store
 path."

guix/ui.scm

@@ -28,12 +28,14 @@
   #:use-module ((guix licenses) #:select (license? license-name))
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-37)
   #:autoload   (ice-9 ftw)  (scandir)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
+  #:use-module (ice-9 regex)
   #:export (_
             N_
             leave
@@ -50,6 +52,8 @@
             fill-paragraph
             string->recutils
             package->recutils
+            string->generations
+            string->duration
             args-fold*
             run-guix-command
             program-name
@@ -210,27 +214,27 @@ derivations listed in DRV.  Return #t if there's something to build, #f
 otherwise.  When USE-SUBSTITUTES?, check and report what is prerequisites are
 available for download."
   (let*-values (((build download)
-                 (fold2 (lambda (drv-path build download)
+                 (fold2 (lambda (drv build download)
-                          (let ((drv (call-with-input-file drv-path
+                          (let-values (((b d)
-                                       read-derivation)))
+                                        (derivation-prerequisites-to-build
-                            (let-values (((b d)
+                                         store drv
-                                          (derivation-prerequisites-to-build
+                                         #:use-substitutes?
-                                           store drv
+                                         use-substitutes?)))
-                                           #:use-substitutes?
+                            (values (append b build)
-                                           use-substitutes?)))
+                                    (append d download))))
-                              (values (append b build)
-                                      (append d download)))))
                         '() '()
                         drv))
                 ((build)                          ; add the DRV themselves
                  (delete-duplicates
-                  (append (remove (compose (lambda (out)
+                  (append (map derivation-file-name
-                                             (or (valid-path? store out)
+                               (remove (lambda (drv)
-                                                 (and use-substitutes?
+                                         (let ((out (derivation->output-path
-                                                      (has-substitutes? store
+                                                     drv)))
-                                                                        out))))
+                                           (or (valid-path? store out)
-                                           derivation-path->output-path)
+                                               (and use-substitutes?
-                                  drv)
+                                                    (has-substitutes? store
+                                                                      out)))))
+                                       drv))
                           (map derivation-input-path build))))
                 ((download)                   ; add the references of DOWNLOAD
                  (if use-substitutes?
@@ -404,6 +408,70 @@ WIDTH columns."
           (and=> (package-description p) description->recutils))
   (newline port))
 
+(define (string->generations str)
+  "Return the list of generations matching a pattern in STR.  This function
+accepts the following patterns: \"1\", \"1,2,3\", \"1..9\", \"1..\", \"..9\"."
+  (define (maybe-integer)
+    (let ((x (string->number str)))
+      (and (integer? x)
+           x)))
+
+  (define (maybe-comma-separated-integers)
+    (let ((lst (delete-duplicates
+                (map string->number
+                     (string-split str #\,)))))
+      (and (every integer? lst)
+           lst)))
+
+  (cond ((maybe-integer)
+         =>
+         list)
+        ((maybe-comma-separated-integers)
+         =>
+         identity)
+        ((string-match "^([0-9]+)\\.\\.([0-9]+)$" str)
+         =>
+         (lambda (match)
+           (let ((s (string->number (match:substring match 1)))
+                 (e (string->number (match:substring match 2))))
+             (and (every integer? (list s e))
+                  (<= s e)
+                  (iota (1+ (- e s)) s)))))
+        ((string-match "^([0-9]+)\\.\\.$" str)
+         =>
+         (lambda (match)
+           (let ((s (string->number (match:substring match 1))))
+             (and (integer? s)
+                  `(>= ,s)))))
+        ((string-match "^\\.\\.([0-9]+)$" str)
+         =>
+         (lambda (match)
+           (let ((e (string->number (match:substring match 1))))
+             (and (integer? e)
+                  `(<= ,e)))))
+        (else #f)))
+
+(define (string->duration str)
+  "Return the duration matching a pattern in STR.  This function accepts the
+following patterns: \"1d\", \"1w\", \"1m\"."
+  (define (hours->duration hours match)
+    (make-time time-duration 0
+               (* 3600 hours (string->number (match:substring match 1)))))
+
+  (cond ((string-match "^([0-9]+)d$" str)
+         =>
+         (lambda (match)
+           (hours->duration 24 match)))
+        ((string-match "^([0-9]+)w$" str)
+         =>
+         (lambda (match)
+           (hours->duration (* 24 7) match)))
+        ((string-match "^([0-9]+)m$" str)
+         =>
+         (lambda (match)
+           (hours->duration (* 24 30) match)))
+        (else #f)))
+
 (define (args-fold* options unrecognized-option-proc operand-proc . seeds)
   "A wrapper on top of `args-fold' that does proper user-facing error
 reporting."

nix/guix-register/guix-register.cc

@@ -0,0 +1,168 @@
+/* GNU Guix --- Functional package management for GNU
+   Copyright (C) 2013 Ludovic Courtès <ludo@gnu.org>
+   Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012,
+     2013 Eelco Dolstra <eelco.dolstra@logicblox.com>
+
+   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/>.  */
+
+/* This file derives from the implementation of 'nix-store
+   --register-validity', by Eelco Dolstra, as found in the Nix package
+   manager's src/nix-store/nix-store.cc.  */
+
+#include <config.h>
+
+#include <globals.hh>
+#include <local-store.hh>
+
+#include <iostream>
+#include <fstream>
+#include <cstdlib>
+#include <cstdio>
+
+#include <argp.h>
+
+using namespace nix;
+
+/* Input stream where we read closure descriptions.  */
+static std::istream *input = &std::cin;
+
+
+
+/* Command-line options.  */
+
+const char *argp_program_version =
+  "guix-register (" PACKAGE_NAME ") " PACKAGE_VERSION;
+const char *argp_program_bug_address = PACKAGE_BUGREPORT;
+
+static char doc[] =
+"guix-register -- register a closure as valid in a store\
+\v\
+This program is used internally when populating a store with data \
+from an existing store.  It updates the new store's database with \
+information about which store files are valid, and what their \
+references are.";
+
+static const struct argp_option options[] =
+  {
+    { "prefix", 'p', "DIRECTORY", 0,
+      "Open the store that lies under DIRECTORY" },
+    { 0, 0, 0, 0, 0 }
+  };
+
+/* Parse a single option. */
+static error_t
+parse_opt (int key, char *arg, struct argp_state *state)
+{
+  switch (key)
+    {
+    case 'p':
+      {
+	string prefix = canonPath (arg);
+	settings.nixStore = prefix + NIX_STORE_DIR;
+	settings.nixDataDir = prefix + NIX_DATA_DIR;
+	settings.nixLogDir = prefix + NIX_LOG_DIR;
+	settings.nixStateDir = prefix + NIX_STATE_DIR;
+	settings.nixDBPath = settings.nixStateDir + "/db";
+	break;
+      }
+
+    case ARGP_KEY_ARG:
+      {
+	std::ifstream *file;
+
+	if (state->arg_num >= 2)
+	  /* Too many arguments. */
+	  argp_usage (state);
+
+	file = new std::ifstream ();
+	file->open (arg);
+
+	input = file;
+      }
+      break;
+
+    default:
+      return (error_t) ARGP_ERR_UNKNOWN;
+    }
+
+  return (error_t) 0;
+}
+
+/* Argument parsing.  */
+static struct argp argp = { options, parse_opt, 0, doc };
+
+
+/* Read from INPUT the description of a closure, and register it as valid in
+   STORE.  The expected format on INPUT is that used by #:references-graphs:
+
+     FILE
+     DERIVER
+     NUMBER-OF-REFERENCES
+     REF1
+     ...
+     REFN
+
+   This is really meant as an internal format.  */
+static void
+register_validity (LocalStore *store, std::istream &input,
+		   bool reregister = true, bool hashGiven = false,
+		   bool canonicalise = true)
+{
+  ValidPathInfos infos;
+
+  while (1)
+    {
+      ValidPathInfo info = decodeValidPathInfo (input, hashGiven);
+      if (info.path == "")
+	break;
+      if (!store->isValidPath (info.path) || reregister)
+	{
+	  /* !!! races */
+	  if (canonicalise)
+	    canonicalisePathMetaData (info.path, -1);
+
+	  if (!hashGiven)
+	    {
+	      HashResult hash = hashPath (htSHA256, info.path);
+	      info.hash = hash.first;
+	      info.narSize = hash.second;
+	    }
+	  infos.push_back (info);
+	}
+    }
+
+  store->registerValidPaths (infos);
+}
+
+
+int
+main (int argc, char *argv[])
+{
+  try
+    {
+      argp_parse (&argp, argc, argv, 0, 0, 0);
+
+      LocalStore store;
+      register_validity (&store, *input);
+    }
+  catch (std::exception &e)
+    {
+      fprintf (stderr, "error: %s\n", e.what ());
+      return EXIT_FAILURE;
+    }
+
+  return EXIT_SUCCESS;
+}

nix/libutil/gcrypt-hash.cc

@@ -1,5 +1,5 @@
 /* GNU Guix --- Functional package management for GNU
-   Copyright (C) 2012  Ludovic Courtès <ludo@gnu.org>
+   Copyright (C) 2012, 2013  Ludovic Courtès <ludo@gnu.org>
 
    This file is part of GNU Guix.
 
@@ -24,7 +24,7 @@
 extern "C" {
 
 void
-guix_hash_init (struct guix_hash_context *ctx, gcry_md_algo_t algo)
+guix_hash_init (struct guix_hash_context *ctx, int algo)
 {
   gcry_error_t err;
 
@@ -40,7 +40,7 @@ guix_hash_update (struct guix_hash_context *ctx, const void *buffer, size_t len)
 
 void
 guix_hash_final (void *resbuf, struct guix_hash_context *ctx,
-		 gcry_md_algo_t algo)
+		 int algo)
 {
   memcpy (resbuf, gcry_md_read (ctx->md_handle, algo),
 	  gcry_md_get_algo_dlen (algo));

nix/libutil/gcrypt-hash.hh

@@ -1,5 +1,5 @@
 /* GNU Guix --- Functional package management for GNU
-   Copyright (C) 2012  Ludovic Courtès <ludo@gnu.org>
+   Copyright (C) 2012, 2013  Ludovic Courtès <ludo@gnu.org>
 
    This file is part of GNU Guix.
 
@@ -30,10 +30,10 @@ struct guix_hash_context
   gcry_md_hd_t md_handle;
 };
 
-extern void guix_hash_init (struct guix_hash_context *ctx, gcry_md_algo_t algo);
+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,
-			     gcry_md_algo_t algo);
+			     int algo);
 
 }

test-env.in

@@ -69,5 +69,12 @@ then
     trap "kill $daemon_pid ; rm -rf $NIX_STATE_DIR" EXIT
 fi
 
+storedir="@storedir@"
+prefix="@prefix@"
+datarootdir="@datarootdir@"
+datadir="@datadir@"
+localstatedir="@localstatedir@"
+export storedir prefix datarootdir datadir localstatedir
+
 "@abs_top_builddir@/pre-inst-env" "$@"
 exit $?

tests/builders.scm

@@ -70,10 +70,10 @@
                      "ftp://ftp.gnu.org/gnu/hello/hello-2.8.tar.gz"))
          (hash     (nix-base32-string->bytevector
                     "0wqd8sjmxfskrflaxywc7gqw7sfawrfvdxd9skxawzfgyy0pzdz6"))
-         (drv-path (url-fetch %store url 'sha256 hash
+         (drv      (url-fetch %store url 'sha256 hash
                               #:guile %bootstrap-guile))
-         (out-path (derivation-path->output-path drv-path)))
+         (out-path (derivation->output-path drv)))
-    (and (build-derivations %store (list drv-path))
+    (and (build-derivations %store (list drv))
          (file-exists? out-path)
          (valid-path? %store out-path))))
 
@@ -93,7 +93,7 @@
                               #:implicit-inputs? #f
                               #:guile %bootstrap-guile
                               #:search-paths %bootstrap-search-paths))
-         (out      (derivation-path->output-path build)))
+         (out      (derivation->output-path build)))
     (and (build-derivations %store (list (pk 'hello-drv build)))
          (valid-path? %store out)
          (file-exists? (string-append out "/bin/hello")))))

tests/derivations.scm

@@ -110,29 +110,26 @@
   (let* ((builder  (add-text-to-store %store "my-builder.sh"
                                       "echo hello, world\n"
                                       '()))
-         (drv-path (derivation %store "foo"
+         (drv      (derivation %store "foo"
                                %bash `("-e" ,builder)
                                #:env-vars '(("HOME" . "/homeless")))))
-    (and (store-path? drv-path)
+    (and (store-path? (derivation-file-name drv))
-         (valid-path? %store drv-path))))
+         (valid-path? %store (derivation-file-name drv)))))
 
 (test-assert "build derivation with 1 source"
-  (let*-values (((builder)
+  (let* ((builder (add-text-to-store %store "my-builder.sh"
-                 (add-text-to-store %store "my-builder.sh"
+                                     "echo hello, world > \"$out\"\n"
-                                    "echo hello, world > \"$out\"\n"
+                                     '()))
-                                    '()))
+         (drv     (derivation %store "foo"
-                ((drv-path drv)
+                              %bash `(,builder)
-                 (derivation %store "foo"
+                              #:env-vars '(("HOME" . "/homeless")
-                             %bash `(,builder)
+                                           ("zzz"  . "Z!")
-                             #:env-vars '(("HOME" . "/homeless")
+                                           ("AAA"  . "A!"))
-                                          ("zzz"  . "Z!")
+                              #:inputs `((,builder))))
-                                          ("AAA"  . "A!"))
+         (succeeded?
-                             #:inputs `((,builder))))
+          (build-derivations %store (list drv))))
-                ((succeeded?)
-                 (build-derivations %store (list drv-path))))
     (and succeeded?
-         (let ((path (derivation-output-path
+         (let ((path (derivation->output-path drv)))
-                      (assoc-ref (derivation-outputs drv) "out"))))
            (and (valid-path? %store path)
                 (string=? (call-with-input-file path read-line)
                           "hello, world"))))))
@@ -145,7 +142,7 @@
          (input      (search-path %load-path "ice-9/boot-9.scm"))
          (input*     (add-to-store %store (basename input)
                                    #t "sha256" input))
-         (drv-path   (derivation %store "derivation-with-input-file"
+         (drv        (derivation %store "derivation-with-input-file"
                                  %bash `(,builder)
 
                                  ;; Cheat to pass the actual file name to the
@@ -154,22 +151,22 @@
 
                                  #:inputs `((,builder)
                                             (,input))))) ; ← local file name
-    (and (build-derivations %store (list drv-path))
+    (and (build-derivations %store (list drv))
          ;; Note: we can't compare the files because the above trick alters
          ;; the contents.
-         (valid-path? %store (derivation-path->output-path drv-path)))))
+         (valid-path? %store (derivation->output-path drv)))))
 
 (test-assert "fixed-output derivation"
   (let* ((builder    (add-text-to-store %store "my-fixed-builder.sh"
                                         "echo -n hello > $out" '()))
          (hash       (sha256 (string->utf8 "hello")))
-         (drv-path   (derivation %store "fixed"
+         (drv        (derivation %store "fixed"
                                  %bash `(,builder)
                                  #:inputs `((,builder)) ; optional
                                  #:hash hash #:hash-algo 'sha256))
-         (succeeded? (build-derivations %store (list drv-path))))
+         (succeeded? (build-derivations %store (list drv))))
     (and succeeded?
-         (let ((p (derivation-path->output-path drv-path)))
+         (let ((p (derivation->output-path drv)))
            (and (equal? (string->utf8 "hello")
                         (call-with-input-file p get-bytevector-all))
                 (bytevector? (query-path-hash %store p)))))))
@@ -180,17 +177,16 @@
          (builder2   (add-text-to-store %store "fixed-builder2.sh"
                                         "echo hey; echo -n hello > $out" '()))
          (hash       (sha256 (string->utf8 "hello")))
-         (drv-path1  (derivation %store "fixed"
+         (drv1       (derivation %store "fixed"
                                  %bash `(,builder1)
                                  #:hash hash #:hash-algo 'sha256))
-         (drv-path2  (derivation %store "fixed"
+         (drv2       (derivation %store "fixed"
                                  %bash `(,builder2)
                                  #:hash hash #:hash-algo 'sha256))
-         (succeeded? (build-derivations %store
+         (succeeded? (build-derivations %store (list drv1 drv2))))
-                                        (list drv-path1 drv-path2))))
     (and succeeded?
-         (equal? (derivation-path->output-path drv-path1)
+         (equal? (derivation->output-path drv1)
-                 (derivation-path->output-path drv-path2)))))
+                 (derivation->output-path drv2)))))
 
 (test-assert "derivation with a fixed-output input"
   ;; A derivation D using a fixed-output derivation F doesn't has the same
@@ -207,7 +203,7 @@
          (fixed2     (derivation %store "fixed"
                                  %bash `(,builder2)
                                  #:hash hash #:hash-algo 'sha256))
-         (fixed-out  (derivation-path->output-path fixed1))
+         (fixed-out  (derivation->output-path fixed1))
          (builder3   (add-text-to-store
                       %store "final-builder.sh"
                       ;; Use Bash hackery to avoid Coreutils.
@@ -223,26 +219,26 @@
          (succeeded? (build-derivations %store
                                         (list final1 final2))))
     (and succeeded?
-         (equal? (derivation-path->output-path final1)
+         (equal? (derivation->output-path final1)
-                 (derivation-path->output-path final2)))))
+                 (derivation->output-path final2)))))
 
 (test-assert "multiple-output derivation"
   (let* ((builder    (add-text-to-store %store "my-fixed-builder.sh"
                                         "echo one > $out ; echo two > $second"
                                         '()))
-         (drv-path   (derivation %store "fixed"
+         (drv        (derivation %store "fixed"
                                  %bash `(,builder)
                                  #:env-vars '(("HOME" . "/homeless")
                                               ("zzz"  . "Z!")
                                               ("AAA"  . "A!"))
                                  #:inputs `((,builder))
                                  #:outputs '("out" "second")))
-         (succeeded? (build-derivations %store (list drv-path))))
+         (succeeded? (build-derivations %store (list drv))))
     (and succeeded?
-         (let ((one (derivation-path->output-path drv-path "out"))
+         (let ((one (derivation->output-path drv "out"))
-               (two (derivation-path->output-path drv-path "second")))
+               (two (derivation->output-path drv "second")))
            (and (lset= equal?
-                       (derivation-path->output-paths drv-path)
+                       (derivation->output-paths drv)
                        `(("out" . ,one) ("second" . ,two)))
                 (eq? 'one (call-with-input-file one read))
                 (eq? 'two (call-with-input-file two read)))))))
@@ -253,14 +249,14 @@
   (let* ((builder    (add-text-to-store %store "my-fixed-builder.sh"
                                         "echo one > $out ; echo two > $AAA"
                                         '()))
-         (drv-path   (derivation %store "fixed"
+         (drv        (derivation %store "fixed"
                                  %bash `(,builder)
                                  #:inputs `((,builder))
                                  #:outputs '("out" "AAA")))
-         (succeeded? (build-derivations %store (list drv-path))))
+         (succeeded? (build-derivations %store (list drv))))
     (and succeeded?
-         (let ((one (derivation-path->output-path drv-path "out"))
+         (let ((one (derivation->output-path drv "out"))
-               (two (derivation-path->output-path drv-path "AAA")))
+               (two (derivation->output-path drv "AAA")))
            (and (eq? 'one (call-with-input-file one read))
                 (eq? 'two (call-with-input-file two read)))))))
 
@@ -282,17 +278,17 @@
          (udrv       (derivation %store "multiple-output-user"
                                  %bash `(,builder2)
                                  #:env-vars `(("one"
-                                               . ,(derivation-path->output-path
+                                               . ,(derivation->output-path
                                                    mdrv "out"))
                                               ("two"
-                                               . ,(derivation-path->output-path
+                                               . ,(derivation->output-path
                                                    mdrv "two")))
                                  #:inputs `((,builder2)
                                             ;; two occurrences of MDRV:
                                             (,mdrv)
                                             (,mdrv "two")))))
     (and (build-derivations %store (list (pk 'udrv udrv)))
-         (let ((p (derivation-path->output-path udrv)))
+         (let ((p (derivation->output-path udrv)))
            (and (valid-path? %store p)
                 (equal? '(one two) (call-with-input-file p read)))))))
 
@@ -317,7 +313,7 @@
                                 ("input1" . ,input1)
                                 ("input2" . ,input2))
                               #:inputs `((,%bash) (,builder))))
-         (out     (derivation-path->output-path drv)))
+         (out     (derivation->output-path drv)))
     (define (deps path . deps)
       (let ((count (length deps)))
         (string-append path "\n\n" (number->string count) "\n"
@@ -360,31 +356,30 @@
           (add-text-to-store %store "build-with-coreutils.sh"
                              "echo $PATH ; mkdir --version ; mkdir $out ; touch $out/good"
                              '()))
-         (drv-path
+         (drv
           (derivation %store "foo"
                       %bash `(,builder)
                       #:env-vars `(("PATH" .
                                     ,(string-append
-                                      (derivation-path->output-path %coreutils)
+                                      (derivation->output-path %coreutils)
                                       "/bin")))
                       #:inputs `((,builder)
                                  (,%coreutils))))
          (succeeded?
-          (build-derivations %store (list drv-path))))
+          (build-derivations %store (list drv))))
     (and succeeded?
-         (let ((p (derivation-path->output-path drv-path)))
+         (let ((p (derivation->output-path drv)))
            (and (valid-path? %store p)
                 (file-exists? (string-append p "/good")))))))
 
 (test-skip (if (%guile-for-build) 0 8))
 
 (test-assert "build-expression->derivation and derivation-prerequisites"
-  (let-values (((drv-path drv)
+  (let ((drv (build-expression->derivation %store "fail" (%current-system)
-                (build-expression->derivation %store "fail" (%current-system)
+                                           #f '())))
-                                              #f '())))
     (any (match-lambda
           (($ <derivation-input> path)
-           (string=? path (%guile-for-build))))
+           (string=? path (derivation-file-name (%guile-for-build)))))
          (derivation-prerequisites drv))))
 
 (test-assert "build-expression->derivation without inputs"
@@ -393,11 +388,11 @@
                         (call-with-output-file (string-append %output "/test")
                           (lambda (p)
                             (display '(hello guix) p)))))
-         (drv-path   (build-expression->derivation %store "goo" (%current-system)
+         (drv       (build-expression->derivation %store "goo" (%current-system)
                                                    builder '()))
-         (succeeded? (build-derivations %store (list drv-path))))
+         (succeeded? (build-derivations %store (list drv))))
     (and succeeded?
-         (let ((p (derivation-path->output-path drv-path)))
+         (let ((p (derivation->output-path drv)))
            (equal? '(hello guix)
                    (call-with-input-file (string-append p "/test") read))))))
 
@@ -406,43 +401,35 @@
                        (set-build-options s #:max-silent-time 1)
                        s))
          (builder    '(sleep 100))
-         (drv-path   (build-expression->derivation %store "silent"
+         (drv        (build-expression->derivation %store "silent"
                                                    (%current-system)
                                                    builder '()))
-         (out-path   (derivation-path->output-path drv-path)))
+         (out-path   (derivation->output-path drv)))
     (guard (c ((nix-protocol-error? c)
                (and (string-contains (nix-protocol-error-message c)
                                      "failed")
                     (not (valid-path? store out-path)))))
-      (build-derivations %store (list drv-path)))))
+      (build-derivations %store (list drv)))))
 
 (test-assert "build-expression->derivation and derivation-prerequisites-to-build"
-  (let-values (((drv-path drv)
+  (let ((drv (build-expression->derivation %store "fail" (%current-system)
-                (build-expression->derivation %store "fail" (%current-system)
+                                           #f '())))
-                                              #f '())))
     ;; The only direct dependency is (%guile-for-build) and it's already
     ;; built.
     (null? (derivation-prerequisites-to-build %store drv))))
 
 (test-assert "derivation-prerequisites-to-build when outputs already present"
-  (let*-values (((builder)
+  (let* ((builder    '(begin (mkdir %output) #t))
-                 '(begin (mkdir %output) #t))
+         (input-drv  (build-expression->derivation %store "input"
-                ((input-drv-path input-drv)
+                                                   (%current-system)
-                 (build-expression->derivation %store "input"
+                                                   builder '()))
-                                               (%current-system)
+         (input-path (derivation-output-path
-                                               builder '()))
+                      (assoc-ref (derivation-outputs input-drv)
-                ((input-path)
+                                 "out")))
-                 (derivation-output-path
+         (drv        (build-expression->derivation %store "something"
-                  (assoc-ref (derivation-outputs input-drv)
+                                                   (%current-system) builder
-                             "out")))
+                                                   `(("i" ,input-drv))))
-                ((drv-path drv)
+         (output     (derivation->output-path drv)))
-                 (build-expression->derivation %store "something"
-                                               (%current-system)
-                                               builder
-                                               `(("i" ,input-drv-path))))
-                ((output)
-                 (derivation-output-path
-                  (assoc-ref (derivation-outputs drv) "out"))))
     ;; Make sure these things are not already built.
     (when (valid-path? %store input-path)
       (delete-paths %store (list input-path)))
@@ -451,10 +438,10 @@
 
     (and (equal? (map derivation-input-path
                       (derivation-prerequisites-to-build %store drv))
-                 (list input-drv-path))
+                 (list (derivation-file-name input-drv)))
 
          ;; Build DRV and delete its input.
-         (build-derivations %store (list drv-path))
+         (build-derivations %store (list drv))
          (delete-paths %store (list input-path))
          (not (valid-path? %store input-path))
 
@@ -464,17 +451,12 @@
 
 (test-skip (if (getenv "GUIX_BINARY_SUBSTITUTE_URL") 0 1))
 (test-assert "derivation-prerequisites-to-build and substitutes"
-  (let*-values (((store)
+  (let* ((store  (open-connection))
-                 (open-connection))
+         (drv    (build-expression->derivation store "prereq-subst"
-                ((drv-path drv)
-                 (build-expression->derivation store "prereq-subst"
                                                (%current-system)
                                                (random 1000) '()))
-                ((output)
+         (output (derivation->output-path drv))
-                 (derivation-output-path
+         (dir    (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
-                  (assoc-ref (derivation-outputs drv) "out")))
-                ((dir)
-                 (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
                         (compose uri-path string->uri))))
     ;; Create fake substituter data, to be read by `substitute-binary'.
     (call-with-output-file (string-append dir "/nix-cache-info")
@@ -494,7 +476,8 @@ Deriver: ~a~%"
                 output                              ; StorePath
                 (string-append dir "/example.nar")  ; URL
                 (%current-system)                   ; System
-                (basename drv-path))))              ; Deriver
+                (basename
+                 (derivation-file-name drv)))))     ; Deriver
 
     (let-values (((build download)
                   (derivation-prerequisites-to-build store drv))
@@ -511,16 +494,16 @@ Deriver: ~a~%"
   (let* ((builder  '(begin
                       (mkdir %output)
                       #f))                        ; fail!
-         (drv-path (build-expression->derivation %store "fail" (%current-system)
+         (drv      (build-expression->derivation %store "fail" (%current-system)
                                                  builder '()))
-         (out-path (derivation-path->output-path drv-path)))
+         (out-path (derivation->output-path drv)))
     (guard (c ((nix-protocol-error? c)
                ;; Note that the output path may exist at this point, but it
                ;; is invalid.
                (and (string-match "build .* failed"
                                   (nix-protocol-error-message c))
                     (not (valid-path? %store out-path)))))
-      (build-derivations %store (list drv-path))
+      (build-derivations %store (list drv))
       #f)))
 
 (test-assert "build-expression->derivation with two outputs"
@@ -531,15 +514,15 @@ Deriver: ~a~%"
                         (call-with-output-file (assoc-ref %outputs "second")
                           (lambda (p)
                             (display '(world) p)))))
-         (drv-path   (build-expression->derivation %store "double"
+         (drv        (build-expression->derivation %store "double"
                                                    (%current-system)
                                                    builder '()
                                                    #:outputs '("out"
                                                                "second")))
-         (succeeded? (build-derivations %store (list drv-path))))
+         (succeeded? (build-derivations %store (list drv))))
     (and succeeded?
-         (let ((one (derivation-path->output-path drv-path))
+         (let ((one (derivation->output-path drv))
-               (two (derivation-path->output-path drv-path "second")))
+               (two (derivation->output-path drv "second")))
            (and (equal? '(hello) (call-with-input-file one read))
                 (equal? '(world) (call-with-input-file two read)))))))
 
@@ -552,12 +535,12 @@ Deriver: ~a~%"
                             (dup2 (port->fdes p) 1)
                             (execl (string-append cu "/bin/uname")
                                    "uname" "-a")))))
-         (drv-path   (build-expression->derivation %store "uname" (%current-system)
+         (drv        (build-expression->derivation %store "uname" (%current-system)
                                                    builder
                                                    `(("cu" ,%coreutils))))
-         (succeeded? (build-derivations %store (list drv-path))))
+         (succeeded? (build-derivations %store (list drv))))
     (and succeeded?
-         (let ((p (derivation-path->output-path drv-path)))
+         (let ((p (derivation->output-path drv)))
            (string-contains (call-with-input-file p read-line) "GNU")))))
 
 (test-assert "imported-files"
@@ -566,9 +549,9 @@ Deriver: ~a~%"
                                               "guix/derivations.scm"))
                      ("p/q"   . ,(search-path %load-path "guix.scm"))
                      ("p/z"   . ,(search-path %load-path "guix/store.scm"))))
-         (drv-path (imported-files %store files)))
+         (drv      (imported-files %store files)))
-    (and (build-derivations %store (list drv-path))
+    (and (build-derivations %store (list drv))
-         (let ((dir (derivation-path->output-path drv-path)))
+         (let ((dir (derivation->output-path drv)))
            (every (match-lambda
                    ((path . source)
                     (equal? (call-with-input-file (string-append dir "/" path)
@@ -583,14 +566,13 @@ Deriver: ~a~%"
                       (let ((out (assoc-ref %outputs "out")))
                         (mkdir-p (string-append out "/guile/guix/nix"))
                         #t)))
-         (drv-path (build-expression->derivation %store
+         (drv      (build-expression->derivation %store "test-with-modules"
-                                                 "test-with-modules"
                                                  (%current-system)
                                                  builder '()
                                                  #:modules
                                                  '((guix build utils)))))
-    (and (build-derivations %store (list drv-path))
+    (and (build-derivations %store (list drv))
-         (let* ((p (derivation-path->output-path drv-path))
+         (let* ((p (derivation->output-path drv))
                 (s (stat (string-append p "/guile/guix/nix"))))
            (eq? (stat:type s) 'directory)))))
 
@@ -614,9 +596,10 @@ Deriver: ~a~%"
                                                    #:hash-algo 'sha256))
          (succeeded? (build-derivations %store (list input1 input2))))
     (and succeeded?
-         (not (string=? input1 input2))
+         (not (string=? (derivation-file-name input1)
-         (string=? (derivation-path->output-path input1)
+                        (derivation-file-name input2)))
-                   (derivation-path->output-path input2)))))
+         (string=? (derivation->output-path input1)
+                   (derivation->output-path input2)))))
 
 (test-assert "build-expression->derivation with a fixed-output input"
   (let* ((builder1   '(call-with-output-file %output
@@ -648,8 +631,11 @@ Deriver: ~a~%"
                                                   (%current-system)
                                                   builder3
                                                   `(("input" ,input2)))))
-    (and (string=? (derivation-path->output-path final1)
+    (and (string=? (derivation->output-path final1)
-                   (derivation-path->output-path final2))
+                   (derivation->output-path final2))
+         (string=? (derivation->output-path final1)
+                   (derivation-path->output-path
+                    (derivation-file-name final1)))
          (build-derivations %store (list final1 final2)))))
 
 (test-assert "build-expression->derivation with #:references-graphs"
@@ -661,7 +647,7 @@ Deriver: ~a~%"
                                                 builder '()
                                                 #:references-graphs
                                                 `(("input" . ,input))))
-         (out     (derivation-path->output-path drv)))
+         (out     (derivation->output-path drv)))
     (define (deps path . deps)
       (let ((count (length deps)))
         (string-append path "\n\n" (number->string count) "\n"

tests/guix-package.sh

@@ -55,7 +55,7 @@ test "`guix package --search-paths -p "$profile" | wc -l`" = 0
 if guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null
 then
     boot_make="(@@ (gnu packages base) gnu-make-boot0)"
-    boot_make_drv="`guix build -e "$boot_make" | tail -1`"
+    boot_make_drv="`guix build -e "$boot_make" | grep -v -e -debug`"
     guix package --bootstrap -p "$profile" -i "$boot_make_drv"
     test -L "$profile-2-link"
     test -f "$profile/bin/make" && test -f "$profile/bin/guile"
@@ -81,6 +81,10 @@ then
         "name: hello"
     test "`guix package -s "n0t4r341p4ck4g3"`" = ""
 
+    # List generations.
+    test "`guix package -p "$profile" -l | cut -f1 | grep guile | head -n1`" \
+        = "  guile-bootstrap"
+
     # Remove a package.
     guix package --bootstrap -p "$profile" -r "guile-bootstrap"
     test -L "$profile-3-link"

tests/guix-register.sh

@@ -0,0 +1,74 @@
+# 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-register' command-line utility.
+#
+
+guix-register --version
+
+new_store="t-register-$$"
+closure="t-register-closure-$$"
+rm -rf "$new_store"
+
+exit_hook=":"
+trap "chmod -R +w $new_store ; rm -rf $new_store $closure ; \$exit_hook" EXIT
+
+mkdir -p "$new_store/$storedir"
+new_store_dir="`cd "$new_store/$storedir" ; pwd`"
+new_store="`cd "$new_store" ; pwd`"
+
+to_copy="`guix build guile-bootstrap`"
+cp -r "$to_copy" "$new_store_dir"
+copied="$new_store_dir/`basename $to_copy`"
+
+# Create a file representing a closure with zero references, and with an empty
+# "deriver" field.
+cat >> "$closure" <<EOF
+$copied
+
+0
+EOF
+
+# Register it.
+guix-register -p "$new_store" < "$closure"
+
+# Doing it a second time shouldn't hurt.
+guix-register -p "$new_store" "$closure"
+
+# Now make sure this is recognized as valid.
+
+NIX_IGNORE_SYMLINK_STORE=1
+NIX_STORE_DIR="$new_store_dir"
+NIX_LOCALSTATE_DIR="$new_store$localstatedir"
+NIX_LOG_DIR="$new_store$localstatedir/log/nix"
+NIX_DB_DIR="$new_store$localstatedir/nix/db"
+
+export NIX_IGNORE_SYMLINK_STORE NIX_STORE_DIR NIX_LOCALSTATE_DIR	\
+  NIX_LOG_DIR NIX_DB_DIR
+
+guix-daemon --disable-chroot &
+subdaemon_pid=$!
+exit_hook="kill $subdaemon_pid"
+
+# At this point the copy in $new_store must be valid, and unreferenced.
+guile -c "
+   (use-modules (guix store))
+   (define s (open-connection))
+   (exit (and (valid-path? s \"$copied\")
+              (equal? (list \"$copied\") (dead-paths s))))"

tests/packages.scm

@@ -121,17 +121,16 @@
                                              (package-source package))))
     (string=? file source)))
 
-(test-assert "return values"
+(test-assert "return value"
-  (let-values (((drv-path drv)
+  (let ((drv (package-derivation %store (dummy-package "p"))))
-                (package-derivation %store (dummy-package "p"))))
+    (and (derivation? drv)
-    (and (derivation-path? drv-path)
+         (file-exists? (derivation-file-name drv)))))
-         (derivation? drv))))
 
 (test-assert "package-output"
   (let* ((package  (dummy-package "p"))
-         (drv-path (package-derivation %store package)))
+         (drv      (package-derivation %store package)))
-    (and (derivation-path? drv-path)
+    (and (derivation? drv)
-         (string=? (derivation-path->output-path drv-path)
+         (string=? (derivation->output-path drv)
                    (package-output %store package "out")))))
 
 (test-assert "trivial"
@@ -148,7 +147,7 @@
                        (display '(hello guix) p))))))))
          (d (package-derivation %store p)))
     (and (build-derivations %store (list d))
-         (let ((p (pk 'drv d (derivation-path->output-path d))))
+         (let ((p (pk 'drv d (derivation->output-path d))))
            (equal? '(hello guix)
                    (call-with-input-file (string-append p "/test") read))))))
 
@@ -164,7 +163,7 @@
               (inputs `(("input" ,i)))))
          (d (package-derivation %store p)))
     (and (build-derivations %store (list d))
-         (let ((p (pk 'drv d (derivation-path->output-path d))))
+         (let ((p (pk 'drv d (derivation->output-path d))))
            (equal? (call-with-input-file p get-bytevector-all)
                    (call-with-input-file i get-bytevector-all))))))
 
@@ -183,7 +182,7 @@
                                                           (%current-system)))))))
          (d (package-derivation %store p)))
     (and (build-derivations %store (list d))
-         (let ((p (pk 'drv d (derivation-path->output-path d))))
+         (let ((p (pk 'drv d (derivation->output-path d))))
            (eq? 'hello (call-with-input-file p read))))))
 
 (test-assert "search paths"
@@ -222,20 +221,17 @@
            (equal? x (collect (package-derivation %store c)))))))
 
 (test-assert "package-cross-derivation"
-  (let-values (((drv-path drv)
+  (let ((drv (package-cross-derivation %store (dummy-package "p")
-                (package-cross-derivation %store (dummy-package "p")
+                                       "mips64el-linux-gnu")))
-                                          "mips64el-linux-gnu")))
+    (and (derivation? drv)
-    (and (derivation-path? drv-path)
+         (file-exists? (derivation-file-name drv)))))
-         (derivation? drv))))
 
 (test-assert "package-cross-derivation, trivial-build-system"
   (let ((p (package (inherit (dummy-package "p"))
              (build-system trivial-build-system)
              (arguments '(#:builder (exit 1))))))
-    (let-values (((drv-path drv)
+    (let ((drv (package-cross-derivation %store p "mips64el-linux-gnu")))
-                  (package-cross-derivation %store p "mips64el-linux-gnu")))
+      (derivation? drv))))
-      (and (derivation-path? drv-path)
-           (derivation? drv)))))
 
 (test-assert "package-cross-derivation, no cross builder"
   (let* ((b (build-system (inherit trivial-build-system)
@@ -257,7 +253,7 @@
          (or (location? (package-location gnu-make))
              (not (package-location gnu-make)))
          (let* ((drv (package-derivation %store gnu-make))
-                (out (derivation-path->output-path drv)))
+                (out (derivation->output-path drv)))
            (and (build-derivations %store (list drv))
                 (file-exists? (string-append out "/bin/make")))))))
 

tests/store.scm

@@ -68,8 +68,7 @@
 (test-skip (if %store 0 10))
 
 (test-assert "dead-paths"
-  (let ((p (add-text-to-store %store "random-text"
+  (let ((p (add-text-to-store %store "random-text" (random-text))))
-                              (random-text) '())))
     (member p (dead-paths %store))))
 
 ;; FIXME: Find a test for `live-paths'.
@@ -83,7 +82,7 @@
 ;;          (d1 (derivation %store "link"
 ;;                          "/bin/sh" `("-e" ,b)
 ;;                          #:inputs `((,b) (,p1))))
-;;          (p2 (derivation-path->output-path d1)))
+;;          (p2 (derivation->output-path d1)))
 ;;     (and (add-temp-root %store p2)
 ;;          (build-derivations %store (list d1))
 ;;          (valid-path? %store p1)
@@ -99,7 +98,7 @@
 
 (test-assert "references"
   (let* ((t1 (add-text-to-store %store "random1"
-                                (random-text) '()))
+                                (random-text)))
          (t2 (add-text-to-store %store "random2"
                                 (random-text) (list t1))))
     (and (equal? (list t1) (references %store t2))
@@ -134,21 +133,21 @@
                         s `("-e" ,b)
                         #:env-vars `(("foo" . ,(random-text)))
                         #:inputs `((,b) (,s))))
-         (o (derivation-path->output-path d)))
+         (o (derivation->output-path d)))
     (and (build-derivations %store (list d))
-         (equal? (query-derivation-outputs %store d)
+         (equal? (query-derivation-outputs %store (derivation-file-name d))
                  (list o))
          (equal? (valid-derivers %store o)
-                 (list d)))))
+                 (list (derivation-file-name d))))))
 
 (test-assert "no substitutes"
   (let* ((s  (open-connection))
          (d1 (package-derivation s %bootstrap-guile (%current-system)))
          (d2 (package-derivation s %bootstrap-glibc (%current-system)))
-         (o  (map derivation-path->output-path (list d1 d2))))
+         (o  (map derivation->output-path (list d1 d2))))
     (set-build-options s #:use-substitutes? #f)
-    (and (not (has-substitutes? s d1))
+    (and (not (has-substitutes? s (derivation-file-name d1)))
-         (not (has-substitutes? s d2))
+         (not (has-substitutes? s (derivation-file-name d2)))
          (null? (substitutable-paths s o))
          (null? (substitutable-path-info s o)))))
 
@@ -157,7 +156,7 @@
 (test-assert "substitute query"
   (let* ((s   (open-connection))
          (d   (package-derivation s %bootstrap-guile (%current-system)))
-         (o   (derivation-path->output-path d))
+         (o   (derivation->output-path d))
          (dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
                      (compose uri-path string->uri))))
     ;; Create fake substituter data, to be read by `substitute-binary'.
@@ -178,7 +177,8 @@ Deriver: ~a~%"
                 o                                   ; StorePath
                 (string-append dir "/example.nar")  ; URL
                 (%current-system)                   ; System
-                (basename d))))                     ; Deriver
+                (basename
+                 (derivation-file-name d)))))       ; Deriver
 
     ;; Remove entry from the local cache.
     (false-if-exception
@@ -192,7 +192,7 @@ Deriver: ~a~%"
          (equal? (list o) (substitutable-paths s (list o)))
          (match (pk 'spi (substitutable-path-info s (list o)))
            (((? substitutable? s))
-            (and (equal? (substitutable-deriver s) d)
+            (and (string=? (substitutable-deriver s) (derivation-file-name d))
                  (null? (substitutable-references s))
                  (equal? (substitutable-nar-size s) 1234)))))))
 
@@ -208,7 +208,7 @@ Deriver: ~a~%"
                '()
                #:guile-for-build
                (package-derivation s %bootstrap-guile (%current-system))))
-         (o   (derivation-path->output-path d))
+         (o   (derivation->output-path d))
          (dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
                      (compose uri-path string->uri))))
     ;; Create fake substituter data, to be read by `substitute-binary'.
@@ -239,7 +239,8 @@ Deriver: ~a~%"
                   (compose bytevector->nix-base32-string sha256
                            get-bytevector-all))
                 (%current-system)                   ; System
-                (basename d))))                     ; Deriver
+                (basename
+                 (derivation-file-name d)))))       ; Deriver
 
     ;; Make sure we use `substitute-binary'.
     (set-build-options s #:use-substitutes? #t)
@@ -258,7 +259,7 @@ Deriver: ~a~%"
                '()
                #:guile-for-build
                (package-derivation s %bootstrap-guile (%current-system))))
-         (o   (derivation-path->output-path d))
+         (o   (derivation->output-path d))
          (dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
                      (compose uri-path string->uri))))
     ;; Create fake substituter data, to be read by `substitute-binary'.
@@ -280,7 +281,8 @@ Deriver: ~a~%"
                 o                                   ; StorePath
                 "does-not-exist.nar"                ; relative URL
                 (%current-system)                   ; System
-                (basename d))))                     ; Deriver
+                (basename
+                 (derivation-file-name d)))))       ; Deriver
 
     ;; Make sure we use `substitute-binary'.
     (set-build-options s #:use-substitutes? #t)

tests/ui.scm

@@ -20,6 +20,7 @@
 (define-module (test-ui)
   #:use-module (guix ui)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-64))
 
 ;; Test the (guix ui) module.
@@ -64,6 +65,90 @@ interface, and powerful string processing.")
                    10)
    #\newline))
 
+(test-equal "integer"
+  '(1)
+  (string->generations "1"))
+
+(test-equal "comma-separated integers"
+  '(3 7 1 4 6)
+  (string->generations "3,7,1,4,6"))
+
+(test-equal "closed range"
+  '(4 5 6 7 8 9 10 11 12)
+  (string->generations "4..12"))
+
+(test-equal "closed range, equal endpoints"
+  '(3)
+  (string->generations "3..3"))
+
+(test-equal "indefinite end range"
+  '(>= 7)
+  (string->generations "7.."))
+
+(test-equal "indefinite start range"
+  '(<= 42)
+  (string->generations "..42"))
+
+(test-equal "integer, char"
+  #f
+  (string->generations "a"))
+
+(test-equal "comma-separated integers, consecutive comma"
+  #f
+  (string->generations "1,,2"))
+
+(test-equal "comma-separated integers, trailing comma"
+  #f
+  (string->generations "1,2,"))
+
+(test-equal "comma-separated integers, chars"
+  #f
+  (string->generations "a,b"))
+
+(test-equal "closed range, start > end"
+  #f
+  (string->generations "9..2"))
+
+(test-equal "closed range, chars"
+  #f
+  (string->generations "a..b"))
+
+(test-equal "indefinite end range, char"
+  #f
+  (string->generations "a.."))
+
+(test-equal "indefinite start range, char"
+  #f
+  (string->generations "..a"))
+
+(test-equal "duration, 1 day"
+  (make-time time-duration 0 (* 3600 24))
+  (string->duration "1d"))
+
+(test-equal "duration, 1 week"
+  (make-time time-duration 0 (* 3600 24 7))
+  (string->duration "1w"))
+
+(test-equal "duration, 1 month"
+  (make-time time-duration 0 (* 3600 24 30))
+  (string->duration "1m"))
+
+(test-equal "duration, 1 week == 7 days"
+  (string->duration "1w")
+  (string->duration "7d"))
+
+(test-equal "duration, 1 month == 30 days"
+  (string->duration "1m")
+  (string->duration "30d"))
+
+(test-equal "duration, integer"
+  #f
+  (string->duration "1"))
+
+(test-equal "duration, char"
+  #f
+  (string->duration "d"))
+
 (test-end "ui")
 
 

tests/union.scm

@@ -108,7 +108,7 @@
                                         builder inputs
                                         #:modules '((guix build union)))))
     (and (build-derivations %store (list (pk 'drv drv)))
-         (with-directory-excursion (derivation-path->output-path drv)
+         (with-directory-excursion (derivation->output-path drv)
            (and (file-exists? "bin/touch")
                 (file-exists? "bin/gcc")
                 (file-exists? "bin/ld")