Merge branch 'master' into dbus-update

.dir-locals.el

@@ -23,6 +23,7 @@
    (eval . (put 'lambda* 'scheme-indent-function 1))
    (eval . (put 'substitute* 'scheme-indent-function 1))
    (eval . (put 'modify-phases 'scheme-indent-function 1))
+   (eval . (put 'modify-services 'scheme-indent-function 1))
    (eval . (put 'with-directory-excursion 'scheme-indent-function 1))
    (eval . (put 'package 'scheme-indent-function 0))
    (eval . (put 'origin 'scheme-indent-function 0))

Makefile.am

@@ -253,6 +253,7 @@ SH_TESTS =					\
   tests/guix-archive.sh				\
   tests/guix-authenticate.sh			\
   tests/guix-environment.sh			\
+  tests/guix-environment-container.sh		\
   tests/guix-graph.sh				\
   tests/guix-lint.sh
 

doc/contributing.texi

@@ -27,6 +27,7 @@ the installation instructions (@pxref{Requirements}).
 @item @url{http://gnu.org/software/autoconf/, GNU Autoconf};
 @item @url{http://gnu.org/software/automake/, GNU Automake};
 @item @url{http://gnu.org/software/gettext/, GNU Gettext};
+@item @url{http://gnu.org/software/texinfo/, GNU Texinfo};
 @item @url{http://www.graphviz.org/, Graphviz};
 @item @url{http://www.gnu.org/software/help2man/, GNU Help2man (optional)}.
 @end itemize
@@ -86,6 +87,30 @@ Similarly, for a Guile session using the Guix modules:
 
 @example
 $ ./pre-inst-env guile -c '(use-modules (guix utils)) (pk (%current-system))'
+
+;;; ("x86_64-linux")
+@end example
+
+@noindent
+@cindex REPL
+@cindex read-eval-print loop
+@dots{} and for a REPL (@pxref{Using Guile Interactively,,, guile, Guile
+Reference Manual}):
+
+@example
+$ ./pre-inst-env guile
+scheme@@(guile-user)> ,use(guix)
+scheme@@(guile-user)> ,use(gnu)
+scheme@@(guile-user)> (define snakes
+                       (fold-packages
+                         (lambda (package lst)
+                           (if (string-prefix? "python"
+                                               (package-name package))
+                               (cons package lst)
+                               lst))
+                         '()))
+scheme@@(guile-user)> (length snakes)
+$1 = 361
 @end example
 
 The @command{pre-inst-env} script sets up all the environment variables

doc/emacs.texi

@@ -227,6 +227,8 @@ prefix argument is used.  This has the same meaning as @code{--manifest}
 option (@pxref{Invoking guix package}).
 
 @item C-c C-z
+@cindex REPL
+@cindex read-eval-print loop
 Go to the Guix REPL (@pxref{The REPL,,, geiser, Geiser User Manual}).
 
 @item h

doc/guix.texi

@@ -233,7 +233,8 @@ software packages, etc.
 
 @cindex functional package management
 The term @dfn{functional} refers to a specific package management
-discipline.  In Guix, the package build and installation process is seen
+discipline pioneered by Nix (@pxref{Acknowledgments}).
+In Guix, the package build and installation process is seen
 as a function, in the mathematical sense.  That function takes inputs,
 such as build scripts, a compiler, and libraries, and
 returns an installed package.  As a pure function, its result depends
@@ -3615,6 +3616,19 @@ The @var{options} may be zero or more of the following:
 
 @table @code
 
+@item --file=@var{file}
+@itemx -f @var{file}
+
+Build the package or derivation that the code within @var{file}
+evaluates to.
+
+As an example, @var{file} might contain a package definition like this
+(@pxref{Defining Packages}):
+
+@example
+@verbatiminclude package-hello.scm
+@end example
+
 @item --expression=@var{expr}
 @itemx -e @var{expr}
 Build the package or derivation @var{expr} evaluates to.
@@ -4263,8 +4277,8 @@ inconvenient.
 
 @item --type=@var{updater}
 @itemx -t @var{updater}
-Select only packages handled by @var{updater}.  Currently, @var{updater}
+Select only packages handled by @var{updater} (may be a comma-separated
-may be one of:
+list of updaters).  Currently, @var{updater} may be one of:
 
 @table @code
 @item gnu
@@ -4279,7 +4293,7 @@ For instance, the following commands only checks for updates of Emacs
 packages hosted at @code{elpa.gnu.org} and updates of CRAN packages:
 
 @example
-$ guix refresh -t elpa -t cran
+$ guix refresh --type=elpa,cran
 gnu/packages/statistics.scm:819:13: r-testthat would be upgraded from 0.10.0 to 0.11.0
 gnu/packages/emacs.scm:856:13: emacs-auctex would be upgraded from 11.88.6 to 11.88.9
 @end example
@@ -4305,6 +4319,10 @@ be used when passing @command{guix refresh} one or more package names:
 
 @table @code
 
+@item --list-updaters
+@itemx -L
+List available updaters and exit (see @option{--type} above.)
+
 @item --list-dependent
 @itemx -l
 List top-level dependent packages that would need to be rebuilt as a
@@ -4681,6 +4699,32 @@ NumPy:
 guix environment --ad-hoc python2-numpy python-2.7 -- python
 @end example
 
+Furthermore, one might want the dependencies of a package and also some
+additional packages that are not build-time or runtime dependencies, but
+are useful when developing nonetheless.  Because of this, the
+@code{--ad-hoc} flag is positional.  Packages appearing before
+@code{--ad-hoc} are interpreted as packages whose dependencies will be
+added to the environment.  Packages appearing after are interpreted as
+packages that will be added to the environment directly.  For example,
+the following command creates a Guix development environment that
+additionally includes Git and strace:
+
+@example
+guix environment guix --ad-hoc git strace
+@end example
+
+Sometimes it is desirable to isolate the environment as much as
+possible, for maximal purity and reproducibility.  In particular, when
+using Guix on a host distro that is not GuixSD, it is desirable to
+prevent access to @file{/usr/bin} and other system-wide resources from
+the development environment.  For example, the following command spawns
+a Guile REPL in a ``container'' where only the store and the current
+working directory are mounted:
+
+@example
+guix environment --ad-hoc --container guile -- guile
+@end example
+
 The available options are summarized below.
 
 @table @code
@@ -4729,6 +4773,12 @@ Note that this example implicitly asks for the default output of
 specific output---e.g., @code{glib:bin} asks for the @code{bin} output
 of @code{glib} (@pxref{Packages with Multiple Outputs}).
 
+This option may be composed with the default behavior of @command{guix
+environment}.  Packages appearing before @code{--ad-hoc} are interpreted
+as packages whose dependencies will be added to the environment, the
+default behavior.  Packages appearing after are interpreted as packages
+that will be added to the environment directly.
+
 @item --pure
 Unset existing environment variables when building the new environment.
 This has the effect of creating an environment in which search paths
@@ -4741,6 +4791,49 @@ environment.
 @item --system=@var{system}
 @itemx -s @var{system}
 Attempt to build for @var{system}---e.g., @code{i686-linux}.
+
+@item --container
+@itemx -C
+@cindex container
+Run @var{command} within an isolated container.  The current working
+directory outside the container is mapped to @file{/env} inside the
+container.  Additionally, the spawned process runs as the current user
+outside the container, but has root privileges in the context of the
+container.
+
+@item --network
+@itemx -N
+For containers, share the network namespace with the host system.
+Containers created without this flag only have access to the loopback
+device.
+
+@item --expose=@var{source}[=@var{target}]
+For containers, expose the file system @var{source} from the host system
+as the read-only file system @var{target} within the container.  If
+@var{target} is not specified, @var{source} is used as the target mount
+point in the container.
+
+The example below spawns a Guile REPL in a container in which the user's
+home directory is accessible read-only via the @file{/exchange}
+directory:
+
+@example
+guix environment --container --expose=$HOME=/exchange guile -- guile
+@end example
+
+@item --share
+For containers, share the file system @var{source} from the host system
+as the writable file system @var{target} within the container.  If
+@var{target} is not specified, @var{source} is used as the target mount
+point in the container.
+
+The example below spawns a Guile REPL in a container in which the user's
+home directory is accessible for both reading and writing via the
+@file{/exchange} directory:
+
+@example
+guix environment --container --share=$HOME=/exchange guile -- guile
+@end example
 @end table
 
 It also supports all of the common build options that @command{guix
@@ -5283,7 +5376,7 @@ addition to the per-user profiles (@pxref{Invoking guix package}).  The
 for basic user and administrator tasks---including the GNU Core
 Utilities, the GNU Networking Utilities, the GNU Zile lightweight text
 editor, @command{find}, @command{grep}, etc.  The example above adds
-Emacs to those, taken from the @code{(gnu packages emacs)} module
+tcpdump to those, taken from the @code{(gnu packages admin)} module
 (@pxref{Package Modules}).
 
 @vindex %base-services
@@ -5291,16 +5384,40 @@ The @code{services} field lists @dfn{system services} to be made
 available when the system starts (@pxref{Services}).
 The @code{operating-system} declaration above specifies that, in
 addition to the basic services, we want the @command{lshd} secure shell
-daemon listening on port 2222, and allowing remote @code{root} logins
+daemon listening on port 2222 (@pxref{Networking Services,
-(@pxref{Invoking lshd,,, lsh, GNU lsh Manual}).  Under the hood,
+@code{lsh-service}}).  Under the hood,
 @code{lsh-service} arranges so that @code{lshd} is started with the
 right command-line options, possibly with supporting configuration files
-generated as needed (@pxref{Defining Services}).  @xref{operating-system
+generated as needed (@pxref{Defining Services}).
-Reference}, for details about the available @code{operating-system}
+
-fields.
+@cindex customization, of services
+@findex modify-services
+Occasionally, instead of using the base services as is, you will want to
+customize them.  For instance, to change the configuration of
+@code{guix-daemon} and Mingetty (the console log-in), you may write the
+following instead of @var{%base-services}:
+
+@lisp
+(modify-services %base-services
+  (guix-service-type config =>
+                     (guix-configuration
+                      (inherit config)
+                      (use-substitutes? #f)
+                      (extra-options '("--gc-keep-outputs"))))
+  (mingetty-service-type config =>
+                         (mingetty-configuration
+                          (inherit config)
+                          (motd (plain-file "motd" "Hi there!")))))
+@end lisp
+
+@noindent
+The effect here is to change the options passed to @command{guix-daemon}
+when it is started, as well as the ``message of the day'' that appears
+when logging in at the console.  @xref{Service Reference,
+@code{modify-services}}, for more on that.
 
 The configuration for a typical ``desktop'' usage, with the X11 display
-server, a desktop environment, network management, an SSH server, and
+server, a desktop environment, network management, power management, and
 more, would look like this:
 
 @lisp
@@ -5310,13 +5427,30 @@ more, would look like this:
 @xref{Desktop Services}, for the exact list of services provided by
 @var{%desktop-services}.  @xref{X.509 Certificates}, for background
 information about the @code{nss-certs} package that is used here.
+@xref{operating-system Reference}, for details about all the available
+@code{operating-system} fields.
 
 Assuming the above snippet is stored in the @file{my-system-config.scm}
 file, the @command{guix system reconfigure my-system-config.scm} command
 instantiates that configuration, and makes it the default GRUB boot
-entry (@pxref{Invoking guix system}).  The normal way to change the
+entry (@pxref{Invoking guix system}).
-system's configuration is by updating this file and re-running the
+
-@command{guix system} command.
+The normal way to change the system's configuration is by updating this
+file and re-running @command{guix system reconfigure}.  One should never
+have to touch files in @command{/etc} or to run commands that modify the
+system state such as @command{useradd} or @command{grub-install}.  In
+fact, you must avoid that since that would not only void your warranty
+but also prevent you from rolling back to previous versions of your
+system, should you ever need to.
+
+@cindex roll-back, of the operating system
+Speaking of roll-back, each time you run @command{guix system
+reconfigure}, a new @dfn{generation} of the system is created---without
+modifying or deleting previous generations.  Old system generations get
+an entry in the GRUB boot menu, allowing you to boot them in case
+something went wrong with the latest generation.  Reassuring, no?  The
+@command{guix system list-generations} command lists the system
+generations available on disk.
 
 At the Scheme level, the bulk of an @code{operating-system} declaration
 is instantiated with the following monadic procedure (@pxref{The Store
@@ -6130,6 +6264,9 @@ Whether to authorize the substitute key for @code{hydra.gnu.org}
 @item @code{use-substitutes?} (default: @code{#t})
 Whether to use substitutes.
 
+@item @code{substitute-urls} (default: @var{%default-substitute-urls})
+The list of URLs where to look for substitutes by default.
+
 @item @code{extra-options} (default: @code{'()})
 List of extra command-line options for @command{guix-daemon}.
 
@@ -6379,6 +6516,19 @@ Last, @var{extra-config} is a list of strings or objects appended to the
 verbatim to the configuration file.
 @end deffn
 
+@deffn {Scheme Procedure} screen-locker-service @var{package} [@var{name}]
+Add @var{package}, a package for a screen-locker or screen-saver whose
+command is @var{program}, to the set of setuid programs and add a PAM entry
+for it.  For example:
+
+@lisp
+(screen-locker-service xlockmore "xlock")
+@end lisp
+
+makes the good ol' XlockMore usable.
+@end deffn
+
+
 @node Desktop Services
 @subsubsection Desktop Services
 
@@ -6396,7 +6546,8 @@ This is a list of services that builds upon @var{%base-services} and
 adds or adjust services for a typical ``desktop'' setup.
 
 In particular, it adds a graphical login manager (@pxref{X Window,
-@code{slim-service}}), a network management tool (@pxref{Networking
+@code{slim-service}}), screen lockers,
+a network management tool (@pxref{Networking
 Services, @code{wicd-service}}), energy and color management services,
 the @code{elogind} login and seat manager, the Polkit privilege service,
 the GeoClue location service, an NTP client (@pxref{Networking
@@ -7022,7 +7173,7 @@ supported:
 @item reconfigure
 Build the operating system described in @var{file}, activate it, and
 switch to it@footnote{This action is usable only on systems already
-running GNU.}.
+running GuixSD.}.
 
 This effects all the configuration specified in @var{file}: user
 accounts, system services, global package list, setuid programs, etc.
@@ -7064,6 +7215,7 @@ This command also installs GRUB on the device specified in
 @item vm
 @cindex virtual machine
 @cindex VM
+@anchor{guix system vm}
 Build a virtual machine that contain the operating system declared in
 @var{file}, and return a script to run that virtual machine (VM).
 Arguments given to the script are passed as is to QEMU.
@@ -7162,6 +7314,30 @@ KVM kernel module should be loaded, and the @file{/dev/kvm} device node
 must exist and be readable and writable by the user and by the daemon's
 build users.
 
+Once you have built, configured, re-configured, and re-re-configured
+your GuixSD installation, you may find it useful to list the operating
+system generations available on disk---and that you can choose from the
+GRUB boot menu:
+
+@table @code
+
+@item list-generations
+List a summary of each generation of the operating system available on
+disk, in a human-readable way.  This is similar to the
+@option{--list-generations} option of @command{guix package}
+(@pxref{Invoking guix package}).
+
+Optionally, one can specify a pattern, with the same syntax that is used
+in @command{guix package --list-generations}, to restrict the list of
+generations displayed.  For instance, the following command displays
+generations up to 10-day old:
+
+@example
+$ guix system list-generations 10d
+@end example
+
+@end table
+
 The @command{guix system} command has even more to offer!  The following
 sub-commands allow you to visualize how your system services relate to
 each other:
@@ -7424,6 +7600,41 @@ Here is an example of how a service is created and manipulated:
 @result{} #t
 @end example
 
+The @code{modify-services} form provides a handy way to change the
+parameters of some of the services of a list such as
+@var{%base-services} (@pxref{Base Services, @code{%base-services}}).  Of
+course, you could always use standard list combinators such as
+@code{map} and @code{fold} to do that (@pxref{SRFI-1, List Library,,
+guile, GNU Guile Reference Manual}); @code{modify-services} simply
+provides a more concise form for this common pattern.
+
+@deffn {Scheme Syntax} modify-services @var{services} @
+  (@var{type} @var{variable} => @var{body}) @dots{}
+
+Modify the services listed in @var{services} according to the given
+clauses.  Each clause has the form:
+
+@example
+(@var{type} @var{variable} => @var{body})
+@end example
+
+where @var{type} is a service type, such as @var{guix-service-type}, and
+@var{variable} is an identifier that is bound within @var{body} to the
+value of the service of that @var{type}.  @xref{Using the Configuration
+System}, for an example.
+
+This is a shorthand for:
+
+@example
+(map (lambda (service) @dots{}) @var{services})
+@end example
+@end deffn
+
+Next comes the programming interface for service types.  This is
+something you want to know when writing new service definitions, but not
+necessarily when simply looking for ways to customize your
+@code{operating-system} declaration.
+
 @deftp {Data Type} service-type
 @cindex service type
 This is the representation of a @dfn{service type} (@pxref{Service Types
@@ -8245,7 +8456,8 @@ reason.
 @node Acknowledgments
 @chapter Acknowledgments
 
-Guix is based on the Nix package manager, which was designed and
+Guix is based on the @uref{http://nixos.org/nix/, Nix package manager},
+which was designed and
 implemented by Eelco Dolstra, with contributions from other people (see
 the @file{nix/AUTHORS} file in Guix.)  Nix pioneered functional package
 management, and promoted unprecedented features, such as transactional

emacs/guix-base.el

@@ -1035,7 +1035,7 @@ Each element from GENERATIONS is a generation number."
                               profile generation)))
     (guix-eval-in-repl
      (guix-make-guile-expression
-      'switch-to-generation profile generation)
+      'switch-to-generation* profile generation)
      operation-buffer)))
 
 (defun guix-package-source-path (package-id)

emacs/guix-command.el

@@ -364,8 +364,9 @@ to be modified."
                      :name "-- " :char ?= :option? t args)))
     (let ((command (car commands)))
       (cond
-       ((member command '("archive" "build" "graph" "edit"
+       ((member command
-                          "environment" "lint" "refresh"))
+                '("archive" "build" "challenge" "edit" "environment"
+                  "graph" "lint" "refresh"))
         (argument :doc "Packages" :fun 'guix-read-package-names-string))
        ((string= command "download")
         (argument :doc "URL"))

emacs/guix-devel.el

@@ -198,6 +198,7 @@ to find 'modify-phases' keywords."
     "mbegin"
     "mlet"
     "mlet*"
+    "modify-services"
     "munless"
     "mwhen"
     "run-with-state"
@@ -288,6 +289,7 @@ Each rule should have a form (SYMBOL VALUE).  See `put' for details."
   (mlet 2)
   (mlet* 2)
   (modify-phases 1)
+  (modify-services 1)
   (munless 1)
   (mwhen 1)
   (operating-system 0)

emacs/guix-pcomplete.el

@@ -209,8 +209,8 @@ group - the argument.")
   "Complete argument for guix COMMAND."
   (cond
    ((member command
-            '("archive" "build" "graph" "edit" "environment"
+            '("archive" "build" "challenge" "edit" "environment"
-              "lint" "refresh" "size"))
+              "graph" "lint" "refresh" "size"))
     (while t
       (pcomplete-here (guix-pcomplete-all-packages))))
    (t (pcomplete-here* (pcomplete-entries)))))

gnu-system.am

@@ -121,7 +121,6 @@ GNU_SYSTEM_MODULES =				\
   gnu/packages/gcc.scm				\
   gnu/packages/gd.scm				\
   gnu/packages/gdb.scm				\
-  gnu/packages/gdbm.scm				\
   gnu/packages/geeqie.scm			\
   gnu/packages/gettext.scm			\
   gnu/packages/ghostscript.scm			\
@@ -693,6 +692,7 @@ dist_patch_DATA =						\
   gnu/packages/patches/xf86-video-trident-remove-mibstore.patch	\
   gnu/packages/patches/xf86-video-vmware-glibc-2.20.patch	\
   gnu/packages/patches/xfce4-panel-plugins.patch		\
+  gnu/packages/patches/xfce4-session-fix-xflock4.patch		\
   gnu/packages/patches/xfce4-settings-defaults.patch		\
   gnu/packages/patches/xmodmap-asprintf.patch 			\
   gnu/packages/patches/zathura-plugindir-environment-variable.patch

gnu/build/linux-container.scm

@@ -165,7 +165,7 @@ (define (namespaces->bit-mask namespaces)
   "Return the number suitable for the 'flags' argument of 'clone' that
 corresponds to the symbols in NAMESPACES."
   ;; Use the same flags as fork(3) in addition to the namespace flags.
-  (apply logior SIGCHLD CLONE_CHILD_CLEARTID CLONE_CHILD_SETTID
+  (apply logior SIGCHLD
          (map (match-lambda
                ('mnt  CLONE_NEWNS)
                ('uts  CLONE_NEWUTS)

gnu/packages/algebra.scm

@@ -26,6 +26,7 @@ (define-module (gnu packages algebra)
   #:use-module (gnu packages perl)
   #:use-module (gnu packages readline)
   #:use-module (gnu packages flex)
+  #:use-module (gnu packages xorg)
   #:use-module ((guix licenses) #:prefix license:)
   #:use-module (guix packages)
   #:use-module (guix download)
@@ -125,6 +126,7 @@ (define-public pari-gp
                 "0k1qqagfl6zn7gvwmsqffj6g9yrzqvszwh2mblhmxpjlw1pigfh8"))))
    (build-system gnu-build-system)
    (inputs `(("gmp" ,gmp)
+             ("libx11" ,libx11)
              ("perl" ,perl)
              ("readline" ,readline)))
    (arguments

gnu/packages/avahi.scm

@@ -23,7 +23,7 @@ (define-module (gnu packages avahi)
   #:use-module (guix download)
   #:use-module (guix build-system gnu)
   #:use-module (gnu packages)
-  #:use-module (gnu packages gdbm)
+  #:use-module (gnu packages databases)
   #:use-module (gnu packages libdaemon)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages glib)

gnu/packages/backup.scm

@@ -30,9 +30,12 @@ (define-module (gnu packages backup)
   #:use-module (gnu packages acl)
   #:use-module (gnu packages base)
   #:use-module (gnu packages compression)
+  #:use-module (gnu packages databases)
   #:use-module (gnu packages dejagnu)
   #:use-module (gnu packages glib)
   #:use-module (gnu packages gnupg)
+  #:use-module (gnu packages gperf)
+  #:use-module (gnu packages guile)
   #:use-module (gnu packages linux)
   #:use-module (gnu packages mcrypt)
   #:use-module (gnu packages nettle)
@@ -147,6 +150,7 @@ (define-public libarchive
               (search-patch "libarchive-fix-lzo-test-case.patch")
               (search-patch "libarchive-CVE-2013-0211.patch")))))
     (build-system gnu-build-system)
+    ;; TODO: Add -L/path/to/nettle in libarchive.pc.
     (inputs
      `(("zlib" ,zlib)
        ("nettle" ,nettle)
@@ -352,3 +356,44 @@ (define-public attic
 changes are stored.")
     (home-page "https://attic-backup.org/")
     (license license:bsd-3)))
+
+(define-public libchop
+  (package
+    (name "libchop")
+    (version "0.5.2")
+    (source (origin
+              (method url-fetch)
+              (uri (string-append "mirror://savannah/libchop/libchop-"
+                                  version ".tar.gz"))
+              (sha256
+               (base32
+                "0fpdyxww41ba52d98blvnf543xvirq1v9xz1i3x1gm9lzlzpmc2g"))
+              (patches
+               (list (search-patch "diffutils-gets-undeclared.patch")))))
+    (build-system gnu-build-system)
+    (native-inputs
+     `(("guile" ,guile-2.0)
+       ("gperf" ,gperf)
+       ("pkg-config" ,pkg-config)))
+    (inputs
+     `(("guile" ,guile-2.0)
+       ("util-linux" ,util-linux)
+       ("gnutls" ,gnutls)
+       ("tdb" ,tdb)
+       ("bdb" ,bdb)
+       ("gdbm" ,gdbm)
+       ("libgcrypt" ,libgcrypt)
+       ("lzo" ,lzo)
+       ("bzip2" ,bzip2)
+       ("zlib" ,zlib)))
+    (home-page "http://nongnu.org/libchop/")
+    (synopsis "Tools & library for data backup and distributed storage")
+    (description
+     "Libchop is a set of utilities and library for data backup and
+distributed storage.  Its main application is @command{chop-backup}, an
+encrypted backup program that supports data integrity checks, versioning,
+distribution among several sites, selective sharing of stored data, adaptive
+compression, and more.  The library itself implements storage techniques such
+as content-addressable storage, content hash keys, Merkle trees, similarity
+detection, and lossless compression.")
+    (license license:gpl3+)))

gnu/packages/bioinformatics.scm

@@ -805,15 +805,16 @@ (define-public clustal-omega
 (define-public crossmap
   (package
     (name "crossmap")
-    (version "0.1.6")
+    (version "0.2.1")
     (source (origin
               (method url-fetch)
               (uri (string-append "mirror://sourceforge/crossmap/CrossMap-"
                                   version ".tar.gz"))
               (sha256
                (base32
-                "163hi5gjgij6cndxlvbkp5jjwr0k4wbm9im6d2210278q7k9kpnp"))
+                "07y179f63d7qnzdvkqcziwk9bs3k4zhp81q392fp1hwszjdvy22f"))
-              ;; patch has been sent upstream already
+              ;; This patch has been sent upstream already and is available
+              ;; for download from Sourceforge, but it has not been merged.
               (patches (list
                         (search-patch "crossmap-allow-system-pysam.patch")))
               (modules '((guix build utils)))
@@ -1838,19 +1839,25 @@ (define-public python2-warpedlmm
     (license license:asl2.0)))
 
 (define-public pbtranscript-tofu
-  (let ((commit "c7bbd5472"))
+  (let ((commit "8f5467fe6"))
     (package
       (name "pbtranscript-tofu")
-      (version (string-append "0.4.1." commit))
+      (version (string-append "2.2.3." commit))
       (source (origin
                 (method git-fetch)
                 (uri (git-reference
                       (url "https://github.com/PacificBiosciences/cDNA_primer.git")
                       (commit commit)))
-                (file-name (string-append name "-" version ".tar.gz"))
+                (file-name (string-append name "-" version "-checkout"))
                 (sha256
                  (base32
-                  "148xkzi689c49g6fdhckp6mnmj2qhjdf1j4wifm6ja7ij95d7fxx"))))
+                  "1lgnpi35ihay42qx0b6yl3kkgra723i413j33kvs0kvs61h82w0f"))
+                (modules '((guix build utils)))
+                (snippet
+                 '(begin
+                    ;; remove bundled Cython sources
+                    (delete-file "pbtranscript-tofu/pbtranscript/Cython-0.20.1.tar.gz")
+                    #t))))
       (build-system python-build-system)
       (arguments
        `(#:python ,python-2
@@ -1860,34 +1867,29 @@ (define-public pbtranscript-tofu
          #:configure-flags '("--single-version-externally-managed"
                              "--record=pbtranscript-tofu.txt")
          #:phases
-         (alist-cons-after
+         (modify-phases %standard-phases
-          'unpack 'enter-directory-and-clean-up
+           (add-after 'unpack 'enter-directory
-          (lambda _
+            (lambda _
-            (chdir "pbtranscript-tofu/pbtranscript/")
+              (chdir "pbtranscript-tofu/pbtranscript/")
-            ;; Delete clutter
+              #t))
-            (delete-file-recursively "dist/")
+           ;; With setuptools version 18.0 and later this setup.py hack causes
-            (delete-file-recursively "build/")
+           ;; a build error, so we disable it.
-            (delete-file-recursively "setuptools_cython-0.2.1-py2.6.egg/")
+           (add-after 'enter-directory 'patch-setuppy
-            (delete-file-recursively "pbtools.pbtranscript.egg-info")
+            (lambda _
-            (delete-file "Cython-0.20.1.tar.gz")
+              (substitute* "setup.py"
-            (delete-file "setuptools_cython-0.2.1-py2.7.egg")
+                (("if 'setuptools.extension' in sys.modules:")
-            (delete-file "setuptools_cython-0.2.1.tar.gz")
+                 "if False:"))
-            (delete-file "setup.cfg")
+              #t)))))
-            (for-each delete-file
-                      (find-files "." "\\.so$"))
-            ;; files should be writable for install phase
-            (for-each (lambda (f) (chmod f #o755))
-                      (find-files "." "\\.py$")))
-          %standard-phases)))
       (inputs
-       `(("python-cython" ,python2-cython)
+       `(("python-numpy" ,python2-numpy)
-         ("python-numpy" ,python2-numpy)
          ("python-bx-python" ,python2-bx-python)
          ("python-networkx" ,python2-networkx)
          ("python-scipy" ,python2-scipy)
-         ("python-pbcore" ,python2-pbcore)))
+         ("python-pbcore" ,python2-pbcore)
+         ("python-h5py" ,python2-h5py)))
       (native-inputs
-       `(("python-nose" ,python2-nose)
+       `(("python-cython" ,python2-cython)
+         ("python-nose" ,python2-nose)
          ("python-setuptools" ,python2-setuptools)))
       (home-page "https://github.com/PacificBiosciences/cDNA_primer")
       (synopsis "Analyze transcriptome data generated with the Iso-Seq protocol")
@@ -2703,7 +2705,24 @@ (define-public subread
     (build-system gnu-build-system)
     (arguments
      `(#:tests? #f ;no "check" target
-       #:make-flags '("-f" "Makefile.Linux")
+      ;; The CC and CCFLAGS variables are set to contain a lot of x86_64
+      ;; optimizations by default, so we override these flags such that x86_64
+      ;; flags are only added when the build target is an x86_64 system.
+       #:make-flags
+       (list (let ((system ,(or (%current-target-system)
+                                (%current-system)))
+                   (flags '("-ggdb" "-fomit-frame-pointer"
+                            "-ffast-math" "-funroll-loops"
+                            "-fmessage-length=0"
+                            "-O9" "-Wall" "-DMAKE_FOR_EXON"
+                            "-DMAKE_STANDALONE"
+                            "-DSUBREAD_VERSION=\\\"${SUBREAD_VERSION}\\\""))
+                   (flags64 '("-mmmx" "-msse" "-msse2" "-msse3")))
+               (if (string-prefix? "x86_64" system)
+                   (string-append "CCFLAGS=" (string-join (append flags flags64)))
+                   (string-append "CCFLAGS=" (string-join flags))))
+             "-f" "Makefile.Linux"
+             "CC=gcc ${CCFLAGS}")
        #:phases
        (alist-cons-after
         'unpack 'enter-dir

gnu/packages/cyrus-sasl.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -19,7 +19,7 @@
 
 (define-module (gnu packages cyrus-sasl)
   #:use-module (gnu packages)
-  #:use-module (gnu packages gdbm)
+  #:use-module (gnu packages databases)
   #:use-module (gnu packages mit-krb5)
   #:use-module (gnu packages tls)
   #:use-module ((guix licenses) #:prefix license:)

gnu/packages/databases.scm

@@ -53,6 +53,28 @@ (define-module (gnu packages databases)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match))
 
+(define-public gdbm
+  (package
+    (name "gdbm")
+    (version "1.11")
+    (source (origin
+              (method url-fetch)
+              (uri (string-append "mirror://gnu/gdbm/gdbm-"
+                                  version ".tar.gz"))
+              (sha256
+               (base32
+                "1hz3jgh3pd4qzp6jy0l8pd8x01g9abw7csnrlnj1a2sxy122z4cd"))))
+    (arguments `(#:configure-flags '("--enable-libgdbm-compat")))
+    (build-system gnu-build-system)
+    (home-page "http://www.gnu.org/software/gdbm/")
+    (synopsis
+     "Hash library of database functions compatible with traditional dbm")
+    (description
+     "GDBM is a library for manipulating hashed databases.  It is used to
+store key/value pairs in a file in a manner similar to the Unix dbm library
+and provides interfaces to the traditional file format.")
+    (license gpl3+)))
+
 (define-public bdb
   (package
     (name "bdb")

gnu/packages/emacs.scm

@@ -316,7 +316,7 @@ (define-public git-modes
 (define-public magit
   (package
     (name "magit")
-    (version "2.2.2")
+    (version "2.3.0")
     (source (origin
              (method url-fetch)
              (uri (string-append
@@ -324,7 +324,7 @@ (define-public magit
                    version "/" name "-" version ".tar.gz"))
              (sha256
               (base32
-               "1imkj4prprnivhbpdn1mdpiryxkckzy5hbnqaahv7gixwac1irh8"))))
+               "0bi0vqp9802f00vnii3x80iqycji20bw4pjysy6al0d86mkggjx5"))))
     (build-system gnu-build-system)
     (native-inputs `(("texinfo" ,texinfo)
                      ("emacs" ,emacs-no-x)))
@@ -372,7 +372,7 @@ (define-public magit
 (define-public magit-svn
   (package
     (name "magit-svn")
-    (version "2.1.0")
+    (version "2.1.1")
     (source (origin
               (method url-fetch)
               (uri (string-append
@@ -381,7 +381,7 @@ (define-public magit-svn
               (file-name (string-append name "-" version ".tar.gz"))
               (sha256
                (base32
-                "09sz93g7x7g9q75jsw8bdh7yr4jr1igfb4fpg5i302a7l2ahxfr8"))))
+                "04y88j7q9h8xjbx5dbick6n5nr1522sn9i1znp0qwk3vjb4b5mzz"))))
     (build-system trivial-build-system)
     (native-inputs `(("emacs" ,emacs-no-x)
                      ("tar" ,tar)

gnu/packages/fish.scm

@@ -20,6 +20,7 @@ (define-module (gnu packages fish)
   #:use-module (guix licenses)
   #:use-module (gnu packages doxygen)
   #:use-module (gnu packages ncurses)
+  #:use-module (gnu packages python)
   #:use-module (guix packages)
   #:use-module (guix download)
   #:use-module (guix utils)
@@ -45,7 +46,8 @@ (define-public fish
     (native-inputs
      `(("doxygen" ,doxygen)))
     (inputs
-     `(("ncurses" ,ncurses)))
+     `(("ncurses" ,ncurses)
+       ("python" ,python-wrapper)))   ;for fish_config and manpage completions
     (arguments
      '(#:tests? #f ; no check target
        #:configure-flags '("--sysconfdir=/etc")))

gnu/packages/freeipmi.scm

@@ -27,14 +27,14 @@ (define-module (gnu packages freeipmi)
 (define-public freeipmi
   (package
     (name "freeipmi")
-    (version "1.4.10")
+    (version "1.4.11")
     (source (origin
              (method url-fetch)
              (uri (string-append "mirror://gnu/freeipmi/freeipmi-"
                                  version ".tar.gz"))
              (sha256
               (base32
-               "1l98l8g8lha85q1d288wr7dyx00x36smh9g5wza15n4wm35c9wqs"))))
+               "0bkghpbj1zkxcgmx2crg0mf97y6dhnxdqvdk5mkw1pyqdxncwq3l"))))
     (build-system gnu-build-system)
     (inputs
      `(("readline" ,readline) ("libgcrypt" ,libgcrypt)))

gnu/packages/gcc.scm

@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014, 2015 Mark H Weaver <mhw@netris.org>
-;;; Copyright © 2014 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2014, 2015 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2015 Andreas Enge <andreas@enge.fr>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -27,6 +27,7 @@ (define-module (gnu packages gcc)
   #:use-module (gnu packages compression)
   #:use-module (gnu packages multiprecision)
   #:use-module (gnu packages texinfo)
+  #:use-module (gnu packages dejagnu)
   #:use-module (gnu packages doxygen)
   #:use-module (gnu packages xml)
   #:use-module (gnu packages docbook)
@@ -460,6 +461,9 @@ (define-public gcj
        ("javac.in" ,javac.in)
        ("ecj-bootstrap" ,ecj-bootstrap)
        ,@(package-inputs gcc)))
+    (native-inputs
+     `(("dejagnu" ,dejagnu)
+       ,@(package-native-inputs gcc)))
     ;; Suppress the separate "lib" output, because otherwise the
     ;; "lib" and "out" outputs would refer to each other, creating
     ;; a cyclic dependency.  <http://debbugs.gnu.org/18101>
@@ -471,7 +475,9 @@ (define-public gcj
                                                 (ice-9 regex)
                                                 (srfi srfi-1)
                                                 (srfi srfi-26))
-                                               ,@(package-arguments gcc))
+                                     #:test-target "check-target-libjava"
+                                     ,@(package-arguments gcc))
+       ((#:tests? _) #t)
        ((#:configure-flags flags)
         `(let ((ecj (assoc-ref %build-inputs "ecj-bootstrap")))
            `("--enable-java-home"

gnu/packages/gdbm.scm

@@ -1,46 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012 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 packages gdbm)
-  #:use-module (guix licenses)
-  #:use-module (guix packages)
-  #:use-module (guix download)
-  #:use-module (guix build-system gnu))
-
-(define-public gdbm
-  (package
-    (name "gdbm")
-    (version "1.11")
-    (source
-     (origin
-      (method url-fetch)
-      (uri (string-append "mirror://gnu/gdbm/gdbm-"
-                          version ".tar.gz"))
-      (sha256
-       (base32
-        "1hz3jgh3pd4qzp6jy0l8pd8x01g9abw7csnrlnj1a2sxy122z4cd"))))
-    (arguments `(#:configure-flags '("--enable-libgdbm-compat")))
-    (build-system gnu-build-system)
-    (home-page "http://www.gnu.org/software/gdbm/")
-    (synopsis
-     "Hash library of database functions compatible with traditional dbm")
-    (description
-     "GDBM is a library for manipulating hashed databases.  It is used to
-store key/value pairs in a file in a manner similar to the Unix dbm library
-and provides interfaces to the traditional file format.")
-    (license gpl3+)))

gnu/packages/grub.scm

@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -28,6 +29,8 @@ (define-module (gnu packages grub)
   #:use-module (gnu packages fontutils)
   #:use-module (gnu packages linux)
   #:use-module (gnu packages qemu)
+  #:use-module (gnu packages man)
+  #:use-module (gnu packages texinfo)
   #:use-module (gnu packages ncurses)
   #:use-module (gnu packages cdrom)
   #:use-module (srfi srfi-1))
@@ -84,30 +87,35 @@ (define-public grub
     (build-system gnu-build-system)
     (arguments
      '(#:configure-flags '("--disable-werror")
-       #:phases (alist-cons-before
+       #:phases (modify-phases %standard-phases
-                 'patch-source-shebangs 'patch-stuff
+                  (add-after
-                 (lambda* (#:key inputs #:allow-other-keys)
+                   'unpack 'patch-stuff
-                   (substitute* "grub-core/Makefile.in"
+                   (lambda* (#:key inputs #:allow-other-keys)
-                     (("/bin/sh") (which "sh")))
+                     (substitute* "grub-core/Makefile.in"
+                       (("/bin/sh") (which "sh")))
 
-                   ;; Make the font visible.
+                     ;; Make the font visible.
-                   (copy-file (assoc-ref inputs "unifont") "unifont.bdf.gz")
+                     (copy-file (assoc-ref inputs "unifont") "unifont.bdf.gz")
-                   (system* "gunzip" "unifont.bdf.gz")
+                     (system* "gunzip" "unifont.bdf.gz")
 
-                   ;; TODO: Re-enable this test when we have Parted.
+                     ;; TODO: Re-enable this test when we have Parted.
-                   (substitute* "tests/partmap_test.in"
+                     (substitute* "tests/partmap_test.in"
-                     (("set -e") "exit 77")))
+                       (("set -e") "exit 77"))
-                 %standard-phases)))
+
+                     #t)))))
     (inputs
      `(;; ("lvm2" ,lvm2)
        ("gettext" ,gnu-gettext)
        ("freetype" ,freetype)
        ;; ("libusb" ,libusb)
+       ;; ("fuse" ,fuse)
        ("ncurses" ,ncurses)))
     (native-inputs
      `(("unifont" ,unifont)
        ("bison" ,bison)
        ("flex" ,flex)
+       ("texinfo" ,texinfo)
+       ("help2man" ,help2man)
 
        ;; Dependencies for the test suite.  The "real" QEMU is needed here,
        ;; because several targets are used.

gnu/packages/guile.scm

@@ -38,7 +38,7 @@ (define-module (gnu packages guile)
   #:use-module (gnu packages base)
   #:use-module (gnu packages texinfo)
   #:use-module (gnu packages gettext)
-  #:use-module (gnu packages gdbm)
+  #:use-module (gnu packages databases)
   #:use-module (gnu packages python)
   #:use-module (guix packages)
   #:use-module (guix download)
@@ -189,15 +189,15 @@ (define-public guile-2.0/fixed
 (define-public guile-next
   (package (inherit guile-2.0)
     (name "guile-next")
-    (version "20150815.00884bb")
+    (version "20151025.e5bccb6")
     (source (origin
               (method git-fetch)
               (uri (git-reference
                     (url "git://git.sv.gnu.org/guile.git")
-                    (commit "00884bb79fff41fdf5f22f24a74e366a94a14c9b")))
+                    (commit "e5bccb6e5df3485152bc6501e1f36275e09c6352")))
               (sha256
                (base32
-                "0qk8m9aq3i7pzw6npim58xmsvjqfz5kl1pkyb6b43awn2vydydi5"))))
+                "0z7ywryfcargrpz8hdrz6sfs06c2h2y9baqin3mbjvvg96a5bx47"))))
 
     (arguments
      (substitute-keyword-arguments `(;; Tests aren't passing for now.

gnu/packages/haskell.scm

@@ -865,14 +865,6 @@ (define-public ghc-sdl
         (base32
          "1sa3zx3vrs1gbinxx33zwq0x2bsf3i964bff7419p7vzidn36k46"))))
     (build-system haskell-build-system)
-    (arguments
-     `(#:phases
-       (modify-phases %standard-phases
-         (add-after
-          'unpack 'fix-/bin/sh
-          (lambda _
-            ;; Use `sh', not `/bin/sh'.
-            (setenv "CONFIG_SHELL" "sh"))))))
     (inputs
      `(("sdl" ,sdl)))
     (home-page "https://hackage.haskell.org/package/SDL")
@@ -903,14 +895,7 @@ (define-public ghc-sdl-mixer
      `(#:configure-flags
        (let* ((sdl-mixer (assoc-ref %build-inputs "sdl-mixer"))
               (sdl-mixer-include (string-append sdl-mixer "/include/SDL")))
-         (list (string-append "--extra-include-dirs=" sdl-mixer-include)))
+         (list (string-append "--extra-include-dirs=" sdl-mixer-include)))))
-       #:phases
-       (modify-phases %standard-phases
-         (add-after
-          'unpack 'fix-/bin/sh
-          (lambda _
-            ;; Use `sh', not `/bin/sh'.
-            (setenv "CONFIG_SHELL" "sh"))))))
     (propagated-inputs
      `(("ghc-sdl" ,ghc-sdl)))
     (inputs
@@ -942,14 +927,7 @@ (define-public ghc-sdl-image
      `(#:configure-flags
        (let* ((sdl-image (assoc-ref %build-inputs "sdl-image"))
               (sdl-image-include (string-append sdl-image "/include/SDL")))
-         (list (string-append "--extra-include-dirs=" sdl-image-include)))
+         (list (string-append "--extra-include-dirs=" sdl-image-include)))))
-       #:phases
-       (modify-phases %standard-phases
-         (add-after
-          'unpack 'fix-/bin/sh
-          (lambda _
-            ;; Use `sh', not `/bin/sh'.
-            (setenv "CONFIG_SHELL" "sh"))))))
     (propagated-inputs
      `(("ghc-sdl" ,ghc-sdl)))
     (inputs
@@ -1031,10 +1009,10 @@ (define-public ghc-glut
     (build-system haskell-build-system)
     (propagated-inputs
      `(("ghc-statevar" ,ghc-statevar)
-       ("ghc-openglraw" ,ghc-openglraw)))
+       ("ghc-openglraw" ,ghc-openglraw)
-    (inputs
-     `(("ghc-opengl" ,ghc-opengl)
        ("freeglut" ,freeglut)))
+    (inputs
+     `(("ghc-opengl" ,ghc-opengl)))
     (home-page "http://www.haskell.org/haskellwiki/Opengl")
     (synopsis "Haskell bindings for the OpenGL Utility Toolkit")
     (description "This library provides Haskell bindings for the OpenGL
@@ -1216,12 +1194,6 @@ (define-public ghc-old-time
         (base32
          "1h9b26s3kfh2k0ih4383w90ibji6n0iwamxp6rfp2lbq1y5ibjqw"))))
     (build-system haskell-build-system)
-    (arguments
-     `(#:phases
-       (modify-phases %standard-phases
-         (add-after 'unpack 'fix-/bin/sh
-                    (lambda _
-                      (setenv "CONFIG_SHELL" "sh"))))))
     (propagated-inputs
      `(("ghc-old-locale" ,ghc-old-locale)))
     (home-page "http://hackage.haskell.org/package/old-time")
@@ -1433,12 +1405,6 @@ (define-public ghc-x11
                            "X11-" version ".tar.gz"))
        (sha256
         (base32 "1kzjcynm3rr83ihqx2y2d852jc49da4p18gv6jzm7g87z22x85jj"))))
-    (arguments
-     `(#:phases (modify-phases %standard-phases
-                  (add-before 'configure 'set-sh
-                              (lambda _
-                                (setenv "CONFIG_SHELL" "sh")
-                                #t)))))
     (build-system haskell-build-system)
     (inputs
      `(("libx11" ,libx11)
@@ -1801,13 +1767,8 @@ (define-public ghc-unix-time
          "0dyvyxwaffb94bgri1wc4b9wqaasy32pyjn0lww3dqblxv8fn5ax"))))
     (build-system haskell-build-system)
     (arguments
-     `(#:tests? #f ; FIXME: Test fails with "System.Time not found".  This is
+     `(#:tests? #f)) ; FIXME: Test fails with "System.Time not found".  This
-                   ; weird, that should be provided by GHC 7.10.2.
+                     ; is weird, that should be provided by GHC 7.10.2.
-       #:phases
-       (modify-phases %standard-phases
-         (add-after 'unpack 'fix-/bin/sh
-                    (lambda _
-                      (setenv "CONFIG_SHELL" "sh"))))))
     (propagated-inputs
      `(("ghc-old-time" ,ghc-old-time)
        ("ghc-old-locale" ,ghc-old-locale)))
@@ -3162,11 +3123,7 @@ (define-public ghc-network
     (inputs
      `(("ghc-hunit" ,ghc-hunit)))
     (arguments
-     `(#:tests? #f  ; FIXME: currently missing libraries used for tests.
+     `(#:tests? #f))      ; FIXME: currently missing libraries used for tests.
-       #:phases
-       (modify-phases %standard-phases
-         (add-before 'configure 'set-sh
-                     (lambda _ (setenv "CONFIG_SHELL" "sh"))))))
     (home-page "https://github.com/haskell/network")
     (synopsis "Low-level networking interface")
     (description
@@ -3645,7 +3602,7 @@ (define-public ghc-async
     (home-page "https://github.com/simonmar/async")
     (synopsis "Library to run IO operations asynchronously")
     (description "Async provides a library to run IO operations
-asynchronously, and wait for their results. It is a higher-level interface
+asynchronously, and wait for their results.  It is a higher-level interface
 over threads in Haskell, in which @code{Async a} is a concurrent thread that
 will eventually deliver a value of type @code{a}.")
     (license bsd-3)))

gnu/packages/java.scm

@@ -576,7 +576,7 @@ (define-public icedtea6
     (license license:gpl2+)))
 
 (define-public icedtea7
-  (let* ((version "2.6.1")
+  (let* ((version "2.6.2")
          (drop (lambda (name hash)
                  (origin
                    (method url-fetch)
@@ -594,7 +594,7 @@ (define-public icedtea7
                       version ".tar.xz"))
                 (sha256
                  (base32
-                  "0s107vi1530a5dyxacysc4m64zshgg2d3xpndsc0ws99wz0zmr6c"))
+                  "0xi0w8gpxx3r68hyi7fb991hxb3rqfp7895nfsl4wj3sa1f5ds5y"))
                 (modules '((guix build utils)))
                 (snippet
                  '(substitute* "Makefile.in"
@@ -728,24 +728,24 @@ (define-public icedtea7
       (native-inputs
        `(("openjdk-drop"
           ,(drop "openjdk"
-                 "0gs6vbj5c09516r460r68i7vm652sb25h973kq9hfx749qbs0s01"))
+                 "0jabxc8iw7ciz6f2qshcpla66qniy686vnxnfx3h2yw7syvas4a9"))
          ("corba-drop"
           ,(drop "corba"
-                 "1y7nf6hqry1az28i3b6ln5cs82cww1jj4r61jk54ab8s2xydj0yd"))
+                 "1bw22djg8mfqqn8kp8mpbj9vi4pl8dk67qwwrny67d0fvirixylj"))
          ("jaxp-drop"
           ,(drop "jaxp"
-                 "1szs2w0p496k1qi3yl1fymj0g10lgq31am35zlalcz7pi4l4q360"))
+                 "1h3g2dwbj8ihicl73qbr4cvvc3i5bs5ckrpja1nx6g5b56xa7kcl"))
          ("jaxws-drop"
           ,(drop "jaxws"
-                 "17xfy9q2zdpap7m2prbf937x55jm3pwrqpp1fdlridraqrfzjprd"))
+                 "1m1h7455qn4pdhb5yamdl9965iz9260lzwl3njcs35vi14v7fihl"))
          ("jdk-drop"
           ,(drop "jdk"
-                 "0qskhwr4nml49zhbppnq8ldj0x001bl37mrcpxslbnsdw5skw258"))
+                 "1wcaxf2chnlpk34q04c23im6z32dy8fr6f9giz3ih65nyvah3n3s"))
          ("langtools-drop"
           ,(drop "langtools"
-                 "0hyxrrb0zrx1pq1s90bmim94hwfligr0ajzs1874da4gclbbvfbd"))
+                 "0da3cmm8nwz7dk2sqnywvidaa0kjnyzzi33p2lkdi4415f8yhgx5"))
          ("hotspot-drop"
           ,(drop "hotspot"
-                 "1cv8df2s89mnjzg4rja4i89d4fr8n0c3v5y2cqbww1ma1463n100"))
+                 "0fn3cjhqsgbkfzychkvvw6whxil2n9dr6q0196ywxzkinny1hjcq"))
          ,@(fold alist-delete (package-native-inputs icedtea6)
                  '("openjdk6-src")))))))

gnu/packages/linux.scm

@@ -210,7 +210,7 @@ (define (lookup file)
      #f)))
 
 (define-public linux-libre
-  (let* ((version "4.2.4")
+  (let* ((version "4.2.5")
          (build-phase
           '(lambda* (#:key system inputs #:allow-other-keys #:rest args)
              ;; Apply the neat patch.
@@ -220,6 +220,7 @@ (define-public linux-libre
              (let ((arch (car (string-split system #\-))))
                (setenv "ARCH"
                        (cond ((string=? arch "i686") "i386")
+                             ((string=? arch "mips64el") "mips")
                              (else arch)))
                (format #t "`ARCH' set to `~a'~%" (getenv "ARCH")))
 
@@ -266,7 +267,7 @@ (define-public linux-libre
                (for-each (lambda (file)
                            (copy-file file
                                       (string-append out "/" (basename file))))
-                         (find-files "." "^(bzImage|System\\.map)$"))
+                         (find-files "." "^(bzImage|vmlinuz|System\\.map)$"))
                (copy-file ".config" (string-append out "/config"))
                (zero? (system* "make"
                                (string-append "DEPMOD=" mit "/sbin/depmod")
@@ -283,8 +284,9 @@ (define-public linux-libre
              (uri (linux-libre-urls version))
              (sha256
               (base32
-               "11r9yhi4c2zwfb8i21zk014gcm1kvnabq410wjy6g6a015d5v37w"))))
+               "13ar9sghm2g5w2km9x2d07q3lh81rz286d6slklv56qanm24chzx"))))
     (build-system gnu-build-system)
+    (supported-systems '("x86_64-linux" "i686-linux"))
     (native-inputs `(("perl" ,perl)
                      ("bc" ,bc)
                      ("module-init-tools" ,module-init-tools)

gnu/packages/mail.scm

@@ -36,7 +36,6 @@ (define-module (gnu packages mail)
   #:use-module (gnu packages dejagnu)
   #:use-module (gnu packages emacs)
   #:use-module (gnu packages enchant)
-  #:use-module (gnu packages gdbm)
   #:use-module (gnu packages ghostscript)
   #:use-module (gnu packages glib)
   #:use-module (gnu packages gnome)
@@ -48,7 +47,6 @@ (define-module (gnu packages mail)
   #:use-module (gnu packages libidn)
   #:use-module (gnu packages linux)
   #:use-module (gnu packages m4)
-  #:use-module (gnu packages databases)
   #:use-module (gnu packages ncurses)
   #:use-module (gnu packages pcre)
   #:use-module (gnu packages perl)

gnu/packages/man.scm

@@ -24,9 +24,9 @@ (define-module (gnu packages man)
   #:use-module (guix download)
   #:use-module (guix packages)
   #:use-module (guix build-system gnu)
+  #:use-module (gnu packages databases)
   #:use-module (gnu packages flex)
   #:use-module (gnu packages gawk)
-  #:use-module (gnu packages gdbm)
   #:use-module (gnu packages groff)
   #:use-module (gnu packages less)
   #:use-module (gnu packages lynx)

gnu/packages/maths.scm

@@ -1461,7 +1461,7 @@ (define-public muparser
 (define-public openblas
   (package
     (name "openblas")
-    (version "0.2.14")
+    (version "0.2.15")
     (source
      (origin
        (method url-fetch)
@@ -1470,7 +1470,7 @@ (define-public openblas
        (file-name (string-append name "-" version ".tar.gz"))
        (sha256
         (base32
-         "0av3pd96j8rx5i65f652xv9wqfkaqn0w4ma1gvbyz73i6j2hi9db"))))
+         "1k5f6vjlk54qlplk5m7xkbaw6g2y7dl50lwwdv6xsbcsgsbxfcpy"))))
     (build-system gnu-build-system)
     (arguments
      `(#:tests? #f  ;no "check" target

gnu/packages/package-management.scm

@@ -23,9 +23,12 @@ (define-module (gnu packages package-management)
   #:use-module (guix git-download)
   #:use-module (guix utils)
   #:use-module (guix build-system gnu)
-  #:use-module ((guix licenses) #:select (gpl2+ gpl3+ lgpl2.1+))
+  #:use-module (guix build-system python)
+  #:use-module ((guix licenses) #:select (gpl2+ gpl3+ lgpl2.1+ asl2.0))
   #:use-module (gnu packages)
   #:use-module (gnu packages guile)
+  #:use-module (gnu packages file)
+  #:use-module (gnu packages backup)
   #:use-module (gnu packages compression)
   #:use-module (gnu packages gnupg)
   #:use-module (gnu packages databases)
@@ -34,12 +37,17 @@ (define-module (gnu packages package-management)
   #:use-module (gnu packages autotools)
   #:use-module (gnu packages gettext)
   #:use-module (gnu packages texinfo)
+  #:use-module (gnu packages nettle)
   #:use-module (gnu packages perl)
   #:use-module (gnu packages curl)
   #:use-module (gnu packages web)
   #:use-module (gnu packages man)
   #:use-module (gnu packages emacs)
   #:use-module (gnu packages bdw-gc)
+  #:use-module (gnu packages python)
+  #:use-module (gnu packages popt)
+  #:use-module (gnu packages gnuzilla)
+  #:use-module (gnu packages cpio)
   #:use-module (gnu packages tls))
 
 (define (boot-guile-uri arch)
@@ -275,3 +283,130 @@ (define-public stow
 letting you install them apart in distinct directories and then create
 symlinks to the files in a common directory such as /usr/local.")
     (license gpl2+)))
+
+(define-public rpm
+  (package
+    (name "rpm")
+    (version "4.12.0")
+    (source (origin
+              (method url-fetch)
+              (uri (string-append "http://rpm.org/releases/rpm-4.12.x/rpm-"
+                                  version ".tar.bz2"))
+              (sha256
+               (base32
+                "18hk47hc755nslvb7xkq4jb095z7va0nlcyxdpxayc4lmb8mq3bp"))))
+    (build-system gnu-build-system)
+    (arguments
+     '(#:configure-flags '("--with-external-db"   ;use the system's bdb
+                           "--enable-python"
+                           "--without-lua")
+       #:phases (modify-phases %standard-phases
+                  (add-before 'configure 'set-nspr-search-path
+                    (lambda* (#:key inputs #:allow-other-keys)
+                      ;; nspr.pc contains the right -I flag pointing to
+                      ;; 'include/nspr', but unfortunately 'configure' doesn't
+                      ;; use 'pkg-config'.  Thus, augment CPATH.
+                      ;; Likewise for NSS.
+                      (let ((nspr (assoc-ref inputs "nspr"))
+                            (nss  (assoc-ref inputs "nss")))
+                        (setenv "CPATH"
+                                (string-append (getenv "CPATH") ":"
+                                               nspr "/include/nspr:"
+                                               nss "/include/nss"))
+                        (setenv "LIBRARY_PATH"
+                                (string-append (getenv "LIBRARY_PATH") ":"
+                                               nss "/lib/nss"))
+                        #t)))
+                  (add-after 'install 'fix-rpm-symlinks
+                    (lambda* (#:key outputs #:allow-other-keys)
+                      ;; 'make install' gets these symlinks wrong.  Fix them.
+                      (let* ((out (assoc-ref outputs "out"))
+                             (bin (string-append out "/bin")))
+                        (with-directory-excursion bin
+                          (for-each (lambda (file)
+                                      (delete-file file)
+                                      (symlink "rpm" file))
+                                    '("rpmquery" "rpmverify"))
+                          #t)))))))
+    (native-inputs
+     `(("pkg-config" ,pkg-config)))
+    (inputs
+     `(("python" ,python-2)
+       ("xz" ,xz)
+       ("bdb" ,bdb)
+       ("popt" ,popt)
+       ("nss" ,nss)
+       ("nspr" ,nspr)
+       ("libarchive" ,libarchive)
+       ("nettle" ,nettle)            ;XXX: actually a dependency of libarchive
+       ("file" ,file)
+       ("bzip2" ,bzip2)
+       ("zlib" ,zlib)
+       ("cpio" ,cpio)))
+    (home-page "http://www.rpm.org/")
+    (synopsis "The RPM Package Manager")
+    (description
+     "The RPM Package Manager (RPM) is a command-line driven package
+management system capable of installing, uninstalling, verifying, querying,
+and updating computer software packages.  Each software package consists of an
+archive of files along with information about the package like its version, a
+description.  There is also a library permitting developers to manage such
+transactions from C or Python.")
+
+    ;; The whole is GPLv2+; librpm itself is dual-licensed LGPLv2+ | GPLv2+.
+    (license gpl2+)))
+
+(define-public diffoscope
+  (package
+    (name "diffoscope")
+    (version "34")
+    (source (origin
+              (method git-fetch)
+              (uri (git-reference
+                    (url
+                     "https://anonscm.debian.org/cgit/reproducible/diffoscope.git")
+                    (commit version)))
+              (sha256
+               (base32
+                "1g8b7bpkmns0355gkr3a244affwx4xzqwahwsl6ivw4z0qv7dih8"))
+              (file-name (string-append name "-" version "-checkout"))))
+    (build-system python-build-system)
+    (arguments
+     `(#:python ,python-2
+       #:phases (modify-phases %standard-phases
+                  (add-before 'build 'disable-egg-zipping
+                    (lambda _
+                      ;; Leave the .egg file uncompressed.
+                      (let ((port (open-file "setup.cfg" "a")))
+                        (display "\n[easy_install]\nzip_ok = 0\n"
+                                 port)
+                        (close-port port)
+                        #t)))
+                  (add-before 'build 'dependency-on-rpm
+                    (lambda _
+                      (substitute* "setup.py"
+                        ;; Somehow this requirement is reported as not met,
+                        ;; even though rpm.py is in the search path.  So
+                        ;; delete it.
+                        (("'rpm-python',") ""))
+                      #t)))
+       ;; FIXME: Some obscure test failures.
+       #:tests? #f))
+    (inputs `(("rpm" ,rpm)                        ;for rpm-python
+              ("python-file" ,python2-file)
+              ("python-debian" ,python2-debian)
+              ("python-libarchive-c" ,python2-libarchive-c)
+              ("python-tlsh" ,python2-tlsh)
+
+              ;; Below are modules used for tests.
+              ("python-pytest" ,python2-pytest)
+              ("python-chardet" ,python2-chardet)))
+    (native-inputs `(("python-setuptools" ,python2-setuptools)))
+    (home-page "http://diffoscope.org/")
+    (synopsis "Compare files, archives, and directories in depth")
+    (description
+     "Diffoscope tries to get to the bottom of what makes files or directories
+different.  It recursively unpacks archives of many kinds and transforms
+various binary formats into more human readable forms to compare them.  It can
+compare two tarballs, ISO images, or PDFs just as easily.")
+    (license gpl3+)))

gnu/packages/password-utils.scm

@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com>
 ;;; Copyright © 2015 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2015 Aljosha Papsch <misc@rpapsch.de>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -26,6 +27,9 @@ (define-module (gnu packages password-utils)
   #:use-module (gnu packages compression)
   #:use-module (gnu packages gnupg)
   #:use-module (gnu packages guile)
+  #:use-module (gnu packages ncurses)
+  #:use-module (gnu packages pkg-config)
+  #:use-module (gnu packages tls)
   #:use-module (gnu packages qt)
   #:use-module (gnu packages xdisorg)
   #:use-module (gnu packages xorg))
@@ -104,3 +108,31 @@ (define-public shroud
 applications, there is xclip integration." )
     (home-page "http://dthompson.us/pages/software/shroud.html")
     (license license:gpl3+)))
+
+(define-public yapet
+  (package
+    (name "yapet")
+    (version "1.0")
+    (source (origin
+              (method url-fetch)
+              (uri (string-append "http://www.guengel.ch/myapps/yapet/downloads/yapet-"
+                                  version
+                                  ".tar.bz2"))
+              (sha256
+               (base32
+                "0ydbnqw6icdh07pnv2w6dhvq501bdfvrklv4xmyr8znca9d753if"))))
+    (build-system gnu-build-system)
+    (inputs
+     `(("ncurses" ,ncurses)
+       ("openssl" ,openssl)))
+    (native-inputs
+     `(("pkg-config" ,pkg-config)))
+    (synopsis "Yet Another Password Encryption Tool")
+    (description "YAPET is a text based password manager using the Blowfish
+encryption algorithm.  Because of its small footprint and very few library
+dependencies, it is suited for installing on desktop and server systems alike.
+The text based user interface allows you to run YAPET easily in a Secure Shell
+session.  Two companion utilities enable users to convert CSV files to YAPET
+and vice versa.")
+    (home-page "http://www.guengel.ch/myapps/yapet/")
+    (license license:gpl3+)))

gnu/packages/patches/xfce4-session-fix-xflock4.patch

@@ -0,0 +1,31 @@
+From cbb9c769316b4d32956a2c78aa01a38b473f0cfc Mon Sep 17 00:00:00 2001
+From: David Thompson <dthompson2@worcester.edu>
+Date: Fri, 30 Oct 2015 08:30:43 -0400
+Subject: [PATCH] xflock4: Do not override PATH with hardcoded value.
+
+The PATH "/bin:/usr/bin" may not be a valid search path on the user's
+machine.  The screen locking program may be in /usr/local/bin or
+elsewhere.  Distros that do not conform to the FHS, such as GuixSD and
+NixOS, will not have their executables in either location.  Thus, we
+simply leave PATH alone.
+---
+ scripts/xflock4 | 3 ---
+ 1 file changed, 3 deletions(-)
+
+diff --git a/scripts/xflock4 b/scripts/xflock4
+index ec4d05d..e7981ac 100644
+--- a/scripts/xflock4
++++ b/scripts/xflock4
+@@ -21,9 +21,6 @@
+ #  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ #
+ 
+-PATH=/bin:/usr/bin
+-export PATH
+-
+ # Lock by xscreensaver or gnome-screensaver, if a respective daemon is running
+ for lock_cmd in \
+     "xscreensaver-command -lock" \
+-- 
+2.5.0
+

gnu/packages/pcre.scm

@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
 ;;; Copyright © 2014, 2015 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -57,3 +58,37 @@ (define-public pcre
 POSIX regular expression API.")
    (license license:bsd-3)
    (home-page "http://www.pcre.org/")))
+
+(define-public pcre2
+  (package
+    (name "pcre2")
+    (version "10.20")
+    (source (origin
+              (method url-fetch)
+              (uri (string-append "mirror://sourceforge/pcre/pcre2/"
+                                  version "/pcre2-" version ".tar.bz2"))
+
+              (sha256
+               (base32
+                "0yj8mm9ll9zj3v47rvmmqmr1ybxk72rr2lym3rymdsf905qjhbik"))))
+   (build-system gnu-build-system)
+   (inputs `(("bzip2" ,bzip2)
+             ("readline" ,readline)
+             ("zlib" ,zlib)))
+   (arguments
+    `(#:configure-flags '("--enable-unicode"
+                          "--enable-pcregrep-libz"
+                          "--enable-pcregrep-libbz2"
+                          "--enable-pcretest-libreadline"
+                          "--enable-unicode-properties"
+                          "--enable-pcre2-16"
+                          "--enable-pcre2-32"
+                          "--enable-jit")))
+   (synopsis "Perl Compatible Regular Expressions")
+   (description
+    "The PCRE library is a set of functions that implement regular expression
+pattern matching using the same syntax and semantics as Perl 5.  PCRE has its
+own native API, as well as a set of wrapper functions that correspond to the
+POSIX regular expression API.")
+   (license license:bsd-3)
+   (home-page "http://www.pcre.org/")))

gnu/packages/pulseaudio.scm

@@ -27,7 +27,7 @@ (define-module (gnu packages pulseaudio)
   #:use-module (gnu packages autotools)
   #:use-module (gnu packages avahi)
   #:use-module (gnu packages check)
-  #:use-module (gnu packages gdbm)
+  #:use-module (gnu packages databases)
   #:use-module (gnu packages glib)
   #:use-module (gnu packages gtk)
   #:use-module (gnu packages libcanberra)

gnu/packages/python.scm

@@ -39,8 +39,8 @@ (define-module (gnu packages python)
   #:use-module (gnu packages backup)
   #:use-module (gnu packages compression)
   #:use-module (gnu packages databases)
+  #:use-module (gnu packages file)
   #:use-module (gnu packages fontutils)
-  #:use-module (gnu packages gdbm)
   #:use-module (gnu packages gcc)
   #:use-module (gnu packages ghostscript)
   #:use-module (gnu packages glib)
@@ -5761,3 +5761,98 @@ (define-public python-libarchive-c
 
 (define-public python2-libarchive-c
   (package-with-python2 python-libarchive-c))
+
+(define-public python-file
+  (package
+    (inherit file)
+    (name "python-file")
+    (build-system python-build-system)
+    (arguments
+     '(#:tests? #f                                ;no tests
+       #:phases (modify-phases %standard-phases
+                  (add-before 'build 'change-directory
+                    (lambda _
+                      (chdir "python")
+                      #t))
+                  (add-before 'build 'set-library-file-name
+                    (lambda* (#:key inputs #:allow-other-keys)
+                      (let ((file (assoc-ref inputs "file")))
+                        (substitute* "magic.py"
+                          (("find_library\\('magic'\\)")
+                           (string-append "'" file "/lib/libmagic.so'")))
+                        #t))))))
+    (inputs `(("file" ,file)))
+    (self-native-input? #f)
+    (synopsis "Python bindings to the libmagic file type guesser")))
+
+(define-public python2-file
+  (package-with-python2 python-file))
+
+(define-public python-debian
+  (package
+    (name "python-debian")
+    (version "0.1.23")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (string-append
+             "https://pypi.python.org/packages/source/p/python-debian/python-debian-"
+             version ".tar.gz"))
+       (sha256
+        (base32
+         "193faznwnjc3n5991wyzim6h9gyq1zxifmfrnpm3avgkh7ahyynh"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-six" ,python-six)))
+    (native-inputs
+     `(("python-setuptools" ,python-setuptools)))
+    (home-page "http://packages.debian.org/sid/python-debian")
+    (synopsis "Debian package related modules")
+    (description
+     ;; XXX: Use @enumerate instead of @itemize to work around
+     ;; <http://bugs.gnu.org/21772>.
+     "This package provides Python modules that abstract many formats of
+Debian-related files, such as:
+
+@enumerate
+@item Debtags information;
+@item @file{debian/changelog} files;
+@item packages files, pdiffs;
+@item control files of single or multiple RFC822-style paragraphs---e.g.
+   @file{debian/control}, @file{.changes}, @file{.dsc};
+@item Raw @file{.deb} and @file{.ar} files, with (read-only) access to
+   contained files and meta-information.
+@end enumerate\n")
+
+    ;; Modules are either GPLv2+ or GPLv3+.
+    (license gpl3+)))
+
+(define-public python2-debian
+  (package-with-python2 python-debian))
+
+(define-public python-chardet
+  (package
+    (name "python-chardet")
+    (version "2.3.0")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (string-append
+             "https://pypi.python.org/packages/source/c/chardet/chardet-"
+             version
+             ".tar.gz"))
+       (sha256
+        (base32
+         "1ak87ikcw34fivcgiz2xvi938dmclh078az65l9x3rmgljrkhgp5"))))
+    (build-system python-build-system)
+    (native-inputs
+     `(("python-setuptools" ,python-setuptools)))
+    (home-page "https://github.com/chardet/chardet")
+    (synopsis "Universal encoding detector for Python 2 and 3")
+    (description
+     "This package provides @code{chardet}, a Python module that can
+automatically detect a wide range of file encodings.")
+    (license lgpl2.1+)))
+
+(define-public python2-chardet
+  (package-with-python2 python-chardet))

gnu/packages/ruby.scm

@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2015 Pjotr Prins <pjotr.guix@thebird.nl>
-;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014, 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2014, 2015 David Thompson <davet@gnu.org>
 ;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net>
@@ -30,7 +30,6 @@ (define-module (gnu packages ruby)
   #:use-module (gnu packages autotools)
   #:use-module (gnu packages java)
   #:use-module (gnu packages libffi)
-  #:use-module (gnu packages gdbm)
   #:use-module (gnu packages tls)
   #:use-module (gnu packages version-control)
   #:use-module (guix packages)

gnu/packages/sawfish.scm

@@ -22,7 +22,7 @@ (define-module (gnu packages sawfish)
   #:use-module (guix download)
   #:use-module (guix build-system gnu)
   #:use-module (gnu packages)
-  #:use-module (gnu packages gdbm)
+  #:use-module (gnu packages databases)
   #:use-module (gnu packages gettext)
   #:use-module (gnu packages gtk)
   #:use-module (gnu packages libffi)

gnu/packages/scheme.scm

@@ -334,7 +334,7 @@ (define-public scheme48
 (define-public racket
   (package
     (name "racket")
-    (version "6.1.1")
+    (version "6.2.1")
     (source (origin
              (method url-fetch)
              (uri (list (string-append "http://mirror.racket-lang.org/installers/"
@@ -344,7 +344,7 @@ (define-public racket
                          version "/racket/racket-" version "-src-unix.tgz")))
              (sha256
               (base32
-               "0xfsfdqkngz0xw2lqmc7bsznwx25cw91l9fjhp7abrr05m96j0h9"))))
+               "0555j63k7fs10iv0icmivlxpzgp6s7gwcbfddmbwxlf2rk80qhq0"))))
     (build-system gnu-build-system)
     (arguments
      '(#:phases

gnu/packages/video.scm

@@ -4,6 +4,7 @@
 ;;; Copyright © 2014, 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
 ;;; Copyright © 2015 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2015 Andy Patterson <ajpatter@uwaterloo.ca>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -412,6 +413,89 @@ (define-public ffmpeg
        ("yasm" ,yasm)))
     (arguments
      `(#:test-target "fate"
+       #:configure-flags
+       ;; possible additional inputs:
+       ;;   --enable-avisynth        enable reading of AviSynth script
+       ;;                            files [no]
+       ;;   --enable-frei0r          enable frei0r video filtering
+       ;;   --enable-libaacplus      enable AAC+ encoding via libaacplus [no]
+       ;;   --enable-libcelt         enable CELT decoding via libcelt [no]
+       ;;   --enable-libdc1394       enable IIDC-1394 grabbing using libdc1394
+       ;;                            and libraw1394 [no]
+       ;;   --enable-libfaac         enable AAC encoding via libfaac [no]
+       ;;   --enable-libfdk-aac      enable AAC de/encoding via libfdk-aac [no]
+       ;;   --enable-libflite        enable flite (voice synthesis) support via
+       ;;                            libflite [no]
+       ;;   --enable-libgme          enable Game Music Emu via libgme [no]
+       ;;   --enable-libgsm          enable GSM de/encoding via libgsm [no]
+       ;;   --enable-libiec61883     enable iec61883 via libiec61883 [no]
+       ;;   --enable-libilbc         enable iLBC de/encoding via libilbc [no]
+       ;;   --enable-libmodplug      enable ModPlug via libmodplug [no]
+       ;;   --enable-libnut          enable NUT (de)muxing via libnut,
+       ;;                            native (de)muxer exists [no]
+       ;;   --enable-libopencore-amrnb    enable AMR-NB de/encoding via
+       ;;                                 libopencore-amrnb [no]
+       ;;   --enable-libopencore-amrwb    enable AMR-WB decoding via
+       ;;                                 libopencore-amrwb [no]
+       ;;   --enable-libopencv       enable video filtering via libopencv [no]
+       ;;   --enable-libopenjpeg     enable JPEG 2000 de/encoding via
+       ;;                            OpenJPEG [no]
+       ;;   --enable-librtmp         enable RTMP[E] support via librtmp [no]
+       ;;   --enable-libschroedinger enable Dirac de/encoding via
+       ;;                            libschroedinger [no]
+       ;;   --enable-libshine        enable fixed-point MP3 encoding via
+       ;;                            libshine [no]
+       ;;   --enable-libssh          enable SFTP protocol via libssh [no]
+       ;;                            (libssh2 does not work)
+       ;;   --enable-libstagefright-h264  enable H.264 decoding via
+       ;;                                 libstagefright [no]
+       ;;   --enable-libutvideo      enable Ut Video encoding and decoding via
+       ;;                            libutvideo [no]
+       ;;   --enable-libv4l2         enable libv4l2/v4l-utils [no]
+       ;;   --enable-libvidstab      enable video stabilization using
+       ;;                            vid.stab [no]
+       ;;   --enable-libvo-aacenc    enable AAC encoding via libvo-aacenc [no]
+       ;;   --enable-libvo-amrwbenc  enable AMR-WB encoding via
+       ;;                            libvo-amrwbenc [no]
+       ;;   --enable-libwavpack      enable wavpack encoding via libwavpack [no]
+       ;;   --enable-libxavs         enable AVS encoding via xavs [no]
+       ;;   --enable-libzmq          enable message passing via libzmq [no]
+       ;;   --enable-libzvbi         enable teletext support via libzvbi [no]
+       ;;   --enable-opencl          enable OpenCL code
+       ;;   --enable-x11grab         enable X11 grabbing [no]
+       '("--enable-avresample"
+         "--enable-gpl" ; enable optional gpl licensed parts
+         "--enable-shared"
+         "--enable-fontconfig"
+         ;; "--enable-gnutls" ; causes test failures
+         "--enable-ladspa"
+         "--enable-libass"
+         "--enable-libbluray"
+         "--enable-libcaca"
+         "--enable-libcdio"
+         "--enable-libfreetype"
+         "--enable-libmp3lame"
+         "--enable-libopus"
+         "--enable-libpulse"
+         "--enable-libquvi"
+         "--enable-libsoxr"
+         "--enable-libspeex"
+         "--enable-libtheora"
+         "--enable-libtwolame"
+         "--enable-libvorbis"
+         "--enable-libvpx"
+         "--enable-libxvid"
+         "--enable-libx264"
+         "--enable-openal"
+
+         "--enable-runtime-cpudetect"
+
+         ;; Runtime cpu detection is not implemented on
+         ;; MIPS, so we disable some features.
+         "--disable-mips32r2"
+         "--disable-mipsdspr1"
+         "--disable-mipsdspr2"
+         "--disable-mipsfpu")
        #:phases
        (modify-phases %standard-phases
          (replace
@@ -424,83 +508,13 @@ (define-public ffmpeg
                 (("#! /bin/sh") (string-append "#!" (which "bash"))))
               (setenv "SHELL" (which "bash"))
               (setenv "CONFIG_SHELL" (which "bash"))
-              ;; possible additional inputs:
+              (zero? (apply system*
-              ;;   --enable-avisynth        enable reading of AviSynth script files [no]
+                            "./configure"
-              ;;   --enable-frei0r          enable frei0r video filtering
+                            (string-append "--prefix=" out)
-              ;;   --enable-libaacplus      enable AAC+ encoding via libaacplus [no]
+                            ;; Add $libdir to the RUNPATH of all the binaries.
-              ;;   --enable-libcelt         enable CELT decoding via libcelt [no]
+                            (string-append "--extra-ldflags=-Wl,-rpath="
-              ;;   --enable-libdc1394       enable IIDC-1394 grabbing using libdc1394
+                                           out "/lib")
-              ;;                            and libraw1394 [no]
+                            configure-flags)))))
-              ;;   --enable-libfaac         enable AAC encoding via libfaac [no]
-              ;;   --enable-libfdk-aac      enable AAC de/encoding via libfdk-aac [no]
-              ;;   --enable-libflite        enable flite (voice synthesis) support via libflite [no]
-              ;;   --enable-libgme          enable Game Music Emu via libgme [no]
-              ;;   --enable-libgsm          enable GSM de/encoding via libgsm [no]
-              ;;   --enable-libiec61883     enable iec61883 via libiec61883 [no]
-              ;;   --enable-libilbc         enable iLBC de/encoding via libilbc [no]
-              ;;   --enable-libmodplug      enable ModPlug via libmodplug [no]
-              ;;   --enable-libnut          enable NUT (de)muxing via libnut,
-              ;;                            native (de)muxer exists [no]
-              ;;   --enable-libopencore-amrnb enable AMR-NB de/encoding via libopencore-amrnb [no]
-              ;;   --enable-libopencore-amrwb enable AMR-WB decoding via libopencore-amrwb [no]
-              ;;   --enable-libopencv       enable video filtering via libopencv [no]
-              ;;   --enable-libopenjpeg     enable JPEG 2000 de/encoding via OpenJPEG [no]
-              ;;   --enable-librtmp         enable RTMP[E] support via librtmp [no]
-              ;;   --enable-libschroedinger enable Dirac de/encoding via libschroedinger [no]
-              ;;   --enable-libshine        enable fixed-point MP3 encoding via libshine [no]
-              ;;   --enable-libssh          enable SFTP protocol via libssh [no]
-              ;;                            (libssh2 does not work)
-              ;;   --enable-libstagefright-h264  enable H.264 decoding via libstagefright [no]
-              ;;   --enable-libutvideo      enable Ut Video encoding and decoding via libutvideo [no]
-              ;;   --enable-libv4l2         enable libv4l2/v4l-utils [no]
-              ;;   --enable-libvidstab      enable video stabilization using vid.stab [no]
-              ;;   --enable-libvo-aacenc    enable AAC encoding via libvo-aacenc [no]
-              ;;   --enable-libvo-amrwbenc  enable AMR-WB encoding via libvo-amrwbenc [no]
-              ;;   --enable-libwavpack      enable wavpack encoding via libwavpack [no]
-              ;;   --enable-libxavs         enable AVS encoding via xavs [no]
-              ;;   --enable-libzmq          enable message passing via libzmq [no]
-              ;;   --enable-libzvbi         enable teletext support via libzvbi [no]
-              ;;   --enable-opencl          enable OpenCL code
-              ;;   --enable-x11grab         enable X11 grabbing [no]
-              (zero? (system*
-                      "./configure"
-                      (string-append "--prefix=" out)
-                      ;; Add $libdir to the RUNPATH of all the binaries.
-                      (string-append "--extra-ldflags=-Wl,-rpath="
-                                     %output "/lib")
-                      "--enable-avresample"
-                      "--enable-gpl" ; enable optional gpl licensed parts
-                      "--enable-shared"
-                      "--enable-fontconfig"
-                      ;; "--enable-gnutls" ; causes test failures
-                      "--enable-ladspa"
-                      "--enable-libass"
-                      "--enable-libbluray"
-                      "--enable-libcaca"
-                      "--enable-libcdio"
-                      "--enable-libfreetype"
-                      "--enable-libmp3lame"
-                      "--enable-libopus"
-                      "--enable-libpulse"
-                      "--enable-libquvi"
-                      "--enable-libsoxr"
-                      "--enable-libspeex"
-                      "--enable-libtheora"
-                      "--enable-libtwolame"
-                      "--enable-libvorbis"
-                      "--enable-libvpx"
-                      "--enable-libxvid"
-                      "--enable-libx264"
-                      "--enable-openal"
-
-                      "--enable-runtime-cpudetect"
-
-                      ;; Runtime cpu detection is not implemented on
-                      ;; MIPS, so we disable some features.
-                      "--disable-mips32r2"
-                      "--disable-mipsdspr1"
-                      "--disable-mipsdspr2"
-                      "--disable-mipsfpu")))))
          (add-before
           'check 'set-ld-library-path
           (lambda _
@@ -797,7 +811,7 @@ (define-public libvpx
 (define-public youtube-dl
   (package
     (name "youtube-dl")
-    (version "2015.10.16")
+    (version "2015.10.24")
     (source (origin
               (method url-fetch)
               (uri (string-append "https://youtube-dl.org/downloads/"
@@ -805,7 +819,7 @@ (define-public youtube-dl
                                   version ".tar.gz"))
               (sha256
                (base32
-                "001a4md0yl3zx129mksmwc85grss67r3c9rynvranf9vlpv202vn"))))
+                "1q9srq08vb2yzl81hmjrgqwajckq52fhh9ag2ppbbxjibf91w5gs"))))
     (build-system python-build-system)
     (inputs `(("setuptools" ,python-setuptools)))
     (home-page "http://youtube-dl.org")

gnu/packages/xfce.scm

@@ -423,7 +423,10 @@ (define-public xfce4-session
                                   "/src/" name "-" version ".tar.bz2"))
               (sha256
                (base32
-                "01kvbd09c06j20n155hracsgrq06rlmfgdywffjsvlwpn19m9j38"))))
+                "01kvbd09c06j20n155hracsgrq06rlmfgdywffjsvlwpn19m9j38"))
+              (patches
+               ;; See: https://bugzilla.xfce.org/show_bug.cgi?id=12282
+               (list (search-patch "xfce4-session-fix-xflock4.patch")))))
     (build-system gnu-build-system)
     (arguments
      '(#:configure-flags

gnu/packages/xorg.scm

@@ -4,6 +4,7 @@
 ;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Eric Dvorsak <eric@dvorsak.fr>
+;;; Copyright © 2015 Cyrill Schenkel <cyrill.schenkel@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -5439,3 +5440,44 @@ (define-public perl-x11-protocol
     ;; of the extension modules in the directory Protocol/Ext: see those files
     ;; for details)."
     (license (package-license perl))))
+
+(define-public xcompmgr
+  (package
+    (name "xcompmgr")
+    (version "1.1.7")
+    (source
+     (origin
+       ;; there's no current tarball
+       (method git-fetch)
+       (uri (git-reference
+             (url "http://anongit.freedesktop.org/git/xorg/app/xcompmgr.git")
+             (commit (string-append name "-" version))))
+       (sha256
+        (base32
+         "04swkrm3gk689wrjc418bd3n25w8r20kg1xfbn5j8d7mx1r5gf16"))
+       (file-name (string-append name "-" version))))
+    (build-system gnu-build-system)
+    (arguments
+     `(#:phases (modify-phases %standard-phases
+                  (add-after 'unpack 'autogen
+                              (lambda _
+                                (setenv "NOCONFIGURE" "t")
+                                (zero? (system* "sh" "autogen.sh")))))))
+    (native-inputs
+     `(("pkg-config" ,pkg-config)
+       ("autoconf" ,autoconf)
+       ("automake" ,automake)))
+    (inputs
+     `(("libX11" ,libx11)
+       ("libXext" ,libxext)
+       ("libXcomposite" ,libxcomposite)
+       ("libXfixes" ,libxfixes)
+       ("libXdamage" ,libxdamage)
+       ("libXrender" ,libxrender)))
+    (synopsis "X Compositing manager using RENDER")
+    (description "xcompmgr is a sample compositing manager for X servers
+supporting the XFIXES, DAMAGE, RENDER, and COMPOSITE extensions.  It enables
+basic eye-candy effects.")
+    (home-page "http://cgit.freedesktop.org/xorg/app/xcompmgr/")
+    (license (license:x11-style
+              "http://cgit.freedesktop.org/xorg/app/xcompmgr/tree/COPYING"))))

gnu/services.scm

@@ -48,6 +48,7 @@ (define-module (gnu services)
             service-kind
             service-parameters
 
+            modify-services
             service-back-edges
             fold-services
 
@@ -62,6 +63,7 @@ (define-module (gnu services)
             boot-service-type
             activation-service-type
             activation-service->script
+            %linux-bare-metal-service
             etc-service-type
             etc-directory
             setuid-program-service-type
@@ -133,6 +135,47 @@ (define-record-type <service>
   (parameters service-parameters))
 
 
+(define-syntax %modify-service
+  (syntax-rules (=>)
+    ((_ service)
+     service)
+    ((_ svc (kind param => exp ...) clauses ...)
+     (if (eq? (service-kind svc) kind)
+         (let ((param (service-parameters svc)))
+           (service (service-kind svc)
+                    (begin exp ...)))
+         (%modify-service svc clauses ...)))))
+
+(define-syntax modify-services
+  (syntax-rules ()
+    "Modify the services listed in SERVICES according to CLAUSES.  Each clause
+must have the form:
+
+  (TYPE VARIABLE => BODY)
+
+where TYPE is a service type, such as 'guix-service-type', and VARIABLE is an
+identifier that is bound within BODY to the value of the service of that
+TYPE.  Consider this example:
+
+  (modify-services %base-services
+    (guix-service-type config =>
+                       (guix-configuration
+                        (inherit config)
+                        (use-substitutes? #f)
+                        (extra-options '(\"--gc-keep-derivations\"))))
+    (mingetty-service-type config =>
+                           (mingetty-configuration
+                            (inherit config)
+                            (motd (plain-file \"motd\" \"Hi there!\")))))
+
+It changes the configuration of the GUIX-SERVICE-TYPE instance, and that of
+all the MINGETTY-SERVICE-TYPE instances.
+
+This is a shorthand for (map (lambda (svc) ...) %base-services)."
+    ((_ services clauses ...)
+     (map (lambda (service)
+            (%modify-service service clauses ...))
+          services))))
 
 
 ;;;
@@ -202,20 +245,6 @@ (define (directory-union name things)
                         (union-build #$output '#$things))
                     #:modules '((guix build union))))))
 
-(define (modprobe-wrapper)
-  "Return a wrapper for the 'modprobe' command that knows where modules live.
-
-This wrapper is typically invoked by the Linux kernel ('call_modprobe', in
-kernel/kmod.c), a situation where the 'LINUX_MODULE_DIRECTORY' environment
-variable is not set---hence the need for this wrapper."
-  (let ((modprobe "/run/current-system/profile/bin/modprobe"))
-    (gexp->script "modprobe"
-                  #~(begin
-                      (setenv "LINUX_MODULE_DIRECTORY"
-                              "/run/booted-system/kernel/lib/modules")
-                      (apply execl #$modprobe
-                             (cons #$modprobe (cdr (command-line))))))))
-
 (define* (activation-service->script service)
   "Return as a monadic value the activation script for SERVICE, a service of
 ACTIVATION-SCRIPT-TYPE."
@@ -240,8 +269,7 @@ (define (service-activations)
 
   (mlet* %store-monad ((actions  (service-activations))
                        (modules  (imported-modules %modules))
-                       (compiled (compiled-modules %modules))
+                       (compiled (compiled-modules %modules)))
-                       (modprobe (modprobe-wrapper)))
     (gexp->file "activate"
                 #~(begin
                     (eval-when (expand load eval)
@@ -256,12 +284,6 @@ (define (service-activations)
                     (activate-/bin/sh
                      (string-append #$(canonical-package bash) "/bin/sh"))
 
-                    ;; Tell the kernel to use our 'modprobe' command.
-                    (activate-modprobe #$modprobe)
-
-                    ;; Let users debug their own processes!
-                    (activate-ptrace-attach)
-
                     ;; Run the services' activation snippets.
                     ;; TODO: Use 'load-compiled'.
                     (for-each primitive-load '#$actions)
@@ -287,6 +309,41 @@ (define %activation-service
   ;; receives.
   (service activation-service-type #t))
 
+(define %modprobe-wrapper
+  ;; Wrapper for the 'modprobe' command that knows where modules live.
+  ;;
+  ;; This wrapper is typically invoked by the Linux kernel ('call_modprobe',
+  ;; in kernel/kmod.c), a situation where the 'LINUX_MODULE_DIRECTORY'
+  ;; environment variable is not set---hence the need for this wrapper.
+  (let ((modprobe "/run/current-system/profile/bin/modprobe"))
+    (program-file "modprobe"
+                  #~(begin
+                      (setenv "LINUX_MODULE_DIRECTORY"
+                              "/run/booted-system/kernel/lib/modules")
+                      (apply execl #$modprobe
+                             (cons #$modprobe (cdr (command-line))))))))
+
+(define %linux-kernel-activation
+  ;; Activation of the Linux kernel running on the bare metal (as opposed to
+  ;; running in a container.)
+  #~(begin
+      ;; Tell the kernel to use our 'modprobe' command.
+      (activate-modprobe #$%modprobe-wrapper)
+
+      ;; Let users debug their own processes!
+      (activate-ptrace-attach)))
+
+(define linux-bare-metal-service-type
+  (service-type (name 'linux-bare-metal)
+                (extensions
+                 (list (service-extension activation-service-type
+                                          (const %linux-kernel-activation))))))
+
+(define %linux-bare-metal-service
+  ;; The service that does things that are needed on the "bare metal", but not
+  ;; necessary or impossible in a container.
+  (service linux-bare-metal-service-type #f))
+
 (define (etc-directory service)
   "Return the directory for SERVICE, a service of type ETC-SERVICE-TYPE."
   (files->etc-directory (service-parameters service)))

gnu/services/base.scm

@@ -57,6 +57,7 @@ (define-module (gnu services base)
             mingetty-configuration
             mingetty-configuration?
             mingetty-service
+            mingetty-service-type
 
             %nscd-default-caches
             %nscd-default-configuration
@@ -74,6 +75,7 @@ (define-module (gnu services base)
             guix-configuration
             guix-configuration?
             guix-service
+            guix-service-type
 
             %base-services))
 
@@ -142,6 +144,18 @@ (define (file-system->dmd-service-name file-system)
   (symbol-append 'file-system-
                  (string->symbol (file-system-mount-point file-system))))
 
+(define (mapped-device->dmd-service-name md)
+  "Return the symbol that denotes the dmd service of MD, a <mapped-device>."
+  (symbol-append 'device-mapping-
+                 (string->symbol (mapped-device-target md))))
+
+(define dependency->dmd-service-name
+  (match-lambda
+    ((? mapped-device? md)
+     (mapped-device->dmd-service-name md))
+    ((? file-system? fs)
+     (file-system->dmd-service-name fs))))
+
 (define file-system-service-type
   ;; TODO(?): Make this an extensible service that takes <file-system> objects
   ;; and returns a list of <dmd-service>.
@@ -158,7 +172,7 @@ (define file-system-service-type
        (dmd-service
         (provision (list (file-system->dmd-service-name file-system)))
         (requirement `(root-file-system
-                       ,@(map file-system->dmd-service-name dependencies)))
+                       ,@(map dependency->dmd-service-name dependencies)))
         (documentation "Check, mount, and unmount the given file system.")
         (start #~(lambda args
                    ;; FIXME: Use or factorize with 'mount-file-system'.
@@ -751,6 +765,8 @@ (define-record-type* <guix-configuration>
                     (default #t))
   (use-substitutes? guix-configuration-use-substitutes? ;Boolean
                     (default #t))
+  (substitute-urls  guix-configuration-substitute-urls ;list of strings
+                    (default %default-substitute-urls))
   (extra-options    guix-configuration-extra-options ;list of strings
                     (default '()))
   (lsof             guix-configuration-lsof       ;<package>
@@ -765,7 +781,8 @@ (define (guix-dmd-service config)
   "Return a <dmd-service> for the Guix daemon service with CONFIG."
   (match config
     (($ <guix-configuration> guix build-group build-accounts authorize-key?
-                             use-substitutes? extra-options lsof lsh)
+                             use-substitutes? substitute-urls extra-options
+                             lsof lsh)
      (list (dmd-service
             (documentation "Run the Guix daemon.")
             (provision '(guix-daemon))
@@ -777,6 +794,7 @@ (define (guix-dmd-service config)
                       #$@(if use-substitutes?
                              '()
                              '("--no-substitutes"))
+                      "--substitute-urls" #$(string-join substitute-urls)
                       #$@extra-options)
 
                 ;; Add 'lsof' (for the GC) and 'lsh' (for offloading) to the

gnu/services/desktop.scm

@@ -34,6 +34,8 @@ (define-module (gnu services desktop)
   #:use-module (gnu packages gnome)
   #:use-module (gnu packages avahi)
   #:use-module (gnu packages polkit)
+  #:use-module (gnu packages xdisorg)
+  #:use-module (gnu packages suckless)
   #:use-module (guix records)
   #:use-module (guix packages)
   #:use-module (guix store)
@@ -599,6 +601,10 @@ (define %desktop-services
   ;; List of services typically useful for a "desktop" use case.
   (cons* (slim-service)
 
+         ;; Screen lockers are a pretty useful thing and these are small.
+         (screen-locker-service slock)
+         (screen-locker-service xlockmore "xlock")
+
          ;; The D-Bus clique.
          (avahi-service)
          (wicd-service)

gnu/services/xorg.scm

@@ -32,16 +32,21 @@ (define-module (gnu services xorg)
   #:use-module (gnu packages bash)
   #:use-module (guix gexp)
   #:use-module (guix store)
+  #:use-module (guix packages)
   #:use-module (guix derivations)
   #:use-module (guix records)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
   #:export (xorg-configuration-file
             xorg-start-command
             %default-slim-theme
             %default-slim-theme-name
-            slim-service))
+            slim-service
+
+            screen-locker-service-type
+            screen-locker-service))
 
 ;;; Commentary:
 ;;;
@@ -350,4 +355,52 @@ (define* (slim-service #:key (slim slim)
             (auto-login-session auto-login-session)
             (startx startx))))
 
+
+;;;
+;;; Screen lockers & co.
+;;;
+
+(define-record-type <screen-locker>
+  (screen-locker name program empty?)
+  screen-locker?
+  (name    screen-locker-name)                     ;string
+  (program screen-locker-program)                  ;gexp
+  (empty?  screen-locker-allows-empty-passwords?)) ;Boolean
+
+(define screen-locker-pam-services
+  (match-lambda
+    (($ <screen-locker> name _ empty?)
+     (list (unix-pam-service name
+                             #:allow-empty-passwords? empty?)))))
+
+(define screen-locker-setuid-programs
+  (compose list screen-locker-program))
+
+(define screen-locker-service-type
+  (service-type (name 'screen-locker)
+                (extensions
+                 (list (service-extension pam-root-service-type
+                                          screen-locker-pam-services)
+                       (service-extension setuid-program-service-type
+                                          screen-locker-setuid-programs)))))
+
+(define* (screen-locker-service package
+                                #:optional
+                                (program (package-name package))
+                                #:key allow-empty-passwords?)
+  "Add @var{package}, a package for a screen-locker or screen-saver whose
+command is @var{program}, to the set of setuid programs and add a PAM entry
+for it.  For example:
+
+@lisp
+(screen-locker-service xlockmore \"xlock\")
+@end lisp
+
+makes the good ol' XlockMore usable."
+  (service screen-locker-service-type
+           (screen-locker program
+                          #~(string-append #$package
+                                           #$(string-append "/bin/" program))
+                          allow-empty-passwords?)))
+
 ;;; xorg.scm ends here

gnu/system.scm

@@ -195,19 +195,16 @@ (define (device-mappings fs)
                         (file-system-device fs)))
             (operating-system-mapped-devices os)))
 
-  (define (requirements fs)
+  (define (add-dependencies fs)
-    ;; XXX: Fiddling with dmd service names is not nice.
+    ;; Add the dependencies due to device mappings to FS.
-    (append (map (lambda (fs)
+    (file-system
-                   (symbol-append 'file-system-
+      (inherit fs)
-                                  (string->symbol
+      (dependencies
-                                   (file-system-mount-point fs))))
+       (delete-duplicates (append (device-mappings fs)
-                 (file-system-dependencies fs))
+                                  (file-system-dependencies fs))
-            (map (lambda (md)
+                          eq?))))
-                   (symbol-append 'device-mapping-
-                                  (string->symbol (mapped-device-target md))))
-                 (device-mappings fs))))
 
-  (map file-system-service file-systems))
+  (map (compose file-system-service add-dependencies) file-systems))
 
 (define (mapped-device-user device file-systems)
   "Return a file system among FILE-SYSTEMS that uses DEVICE, or #f."
@@ -290,7 +287,8 @@ (define known-fs
                    ;; container.
                    (if container?
                        '()
-                       (list (service firmware-service-type
+                       (list %linux-bare-metal-service
+                             (service firmware-service-type
                                       (operating-system-firmware os))))))))
 
 (define* (operating-system-services os #:key container?)

gnu/system/file-systems.scm

@@ -99,9 +99,8 @@ (define-record-type* <file-system> file-system
                     (default #t))
   (create-mount-point? file-system-create-mount-point? ; Boolean
                        (default #f))
-  (dependencies     file-system-dependencies      ; list of strings (mount
+  (dependencies     file-system-dependencies      ; list of <file-system>
-                                                  ; points depended on)
+                    (default '())))               ; or <mapped-device>
-                    (default '())))
 
 (define-inlinable (file-system-needed-for-boot? fs)
   "Return true if FS has the 'needed-for-boot?' flag set, or if it's the root

gnu/system/grub.scm

@@ -30,6 +30,7 @@ (define-module (gnu system grub)
   #:autoload   (gnu packages imagemagick) (imagemagick)
   #:autoload   (gnu packages compression) (gzip)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
   #:use-module (srfi srfi-1)
   #:export (grub-image
             grub-image?
@@ -152,10 +153,26 @@ (define* (grub-background-image config #:key (width 640) (height 480))
         (with-monad %store-monad
           (return #f)))))
 
-(define (eye-candy config port)
+(define (eye-candy config system port)
   "Return in %STORE-MONAD a gexp that writes to PORT (a port-valued gexp) the
 'grub.cfg' part concerned with graphics mode, background images, colors, and
 all that."
+  (define setup-gfxterm-body
+    ;; Intel systems need to be switched into graphics mode, whereas most
+    ;; other modern architectures have no other mode and therefore don't need
+    ;; to be switched.
+    (if (string-match "^(x86_64|i[3-6]86)-" system)
+        "
+  # Leave 'gfxmode' to 'auto'.
+  insmod vbe
+  insmod vga
+  insmod video_bochs
+  insmod video_cirrus
+  insmod gfxterm
+  terminal_output gfxterm
+"
+        ""))
+
   (define (theme-colors type)
     (let* ((theme  (grub-configuration-theme config))
            (colors (type theme)))
@@ -163,22 +180,15 @@ (define (theme-colors type)
                      (symbol->string (assoc-ref colors 'bg)))))
 
   (mlet* %store-monad ((image (grub-background-image config)))
-    (return (and image #~(format #$port "
+    (return (and image
-function load_video {
+                 #~(format #$port "
-  insmod vbe
+function setup_gfxterm {~a}
-  insmod vga
-  insmod video_bochs
-  insmod video_cirrus
-}
 
 # Set 'root' to the partition that contains /gnu/store.
 search --file --set ~a/share/grub/unicode.pf2
 
 if loadfont ~a/share/grub/unicode.pf2; then
-  set gfxmode=640x480
+  setup_gfxterm
-  load_video
-  insmod gfxterm
-  terminal_output gfxterm
 fi
 
 insmod png
@@ -189,10 +199,11 @@ (define (theme-colors type)
   set menu_color_normal=cyan/blue
   set menu_color_highlight=white/blue
 fi~%"
-                        #$grub #$grub
+                           #$setup-gfxterm-body
-                        #$image
+                           #$grub #$grub
-                        #$(theme-colors grub-theme-color-normal)
+                           #$image
-                        #$(theme-colors grub-theme-color-highlight))))))
+                           #$(theme-colors grub-theme-color-normal)
+                           #$(theme-colors grub-theme-color-highlight))))))
 
 
 ;;;
@@ -206,6 +217,11 @@ (define* (grub-configuration-file config entries
   "Return the GRUB configuration file corresponding to CONFIG, a
 <grub-configuration> object.  OLD-ENTRIES is taken to be a list of menu
 entries corresponding to old generations of the system."
+  (define linux-image-name
+    (if (string-prefix? "mips" system)
+        "vmlinuz"
+        "bzImage"))
+
   (define all-entries
     (append entries (grub-configuration-menu-entries config)))
 
@@ -214,16 +230,17 @@ (define entry->gexp
      (($ <menu-entry> label linux arguments initrd)
       #~(format port "menuentry ~s {
   # Set 'root' to the partition that contains the kernel.
-  search --file --set ~a/bzImage~%
+  search --file --set ~a/~a~%
 
-  linux ~a/bzImage ~a
+  linux ~a/~a ~a
   initrd ~a
 }~%"
                 #$label
-                #$linux #$linux (string-join (list #$@arguments))
+                #$linux #$linux-image-name
+                #$linux #$linux-image-name (string-join (list #$@arguments))
                 #$initrd))))
 
-  (mlet %store-monad ((sugar (eye-candy config #~port)))
+  (mlet %store-monad ((sugar (eye-candy config system #~port)))
     (define builder
       #~(call-with-output-file #$output
           (lambda (port)

gnu/system/linux-initrd.scm

@@ -178,11 +178,13 @@ (define (file-system-type-predicate type)
   (define linux-modules
     ;; Modules added to the initrd and loaded from the initrd.
     `("ahci"                                  ;for SATA controllers
-      "pata_acpi" "pata_atiixp"               ;for ATA controllers
-      "isci"                              ;for SAS controllers like Intel C602
       "usb-storage" "uas"                     ;for the installation image etc.
       "usbkbd" "usbhid"                       ;USB keyboards, for debugging
       "dm-crypt" "xts"                        ;for encrypted root partitions
+      ,@(if (string-match "^(x86_64|i[3-6]86)-" (%current-system))
+            '("pata_acpi" "pata_atiixp"    ;for ATA controllers
+              "isci")                      ;for SAS controllers like Intel C602
+            '())
       ,@(if (or virtio? qemu-networking?)
             virtio-modules
             '())

gnu/system/linux.scm

@@ -182,8 +182,7 @@ (define* (base-pam-services #:key allow-empty-passwords?)
           ;; These programs are setuid-root.
           (map (cut unix-pam-service <>
                     #:allow-empty-passwords? allow-empty-passwords?)
-               '("su" "passwd" "sudo"
+               '("su" "passwd" "sudo"))
-                 "xlock" "xscreensaver"))
 
           ;; These programs are not setuid-root, and we want root to be able
           ;; to run them without having to authenticate (notably because

guix/build/haskell-build-system.scm

@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
+;;; Copyright © 2015 Paul van der Walt <paul@denknerd.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -96,6 +97,14 @@ (define* (configure #:key outputs inputs tests? (configure-flags '())
                              '("--enable-tests")
                              '())
                          configure-flags)))
+    ;; For packages where the Cabal build-type is set to "Configure",
+    ;; ./configure will be executed.  In these cases, the following
+    ;; environment variable is needed to be able to find the shell executable.
+    ;; For other package types, the configure script isn't present.  For more
+    ;; information, see the Build Information section of
+    ;; <https://www.haskell.org/cabal/users-guide/developing-packages.html>.
+    (when (file-exists? "configure")
+      (setenv "CONFIG_SHELL" "sh"))
     (run-setuphs "configure" params)))
 
 (define* (build #:rest empty)

guix/gnu-maintenance.scm

@@ -413,8 +413,10 @@ (define (non-emacs-gnu-package? package)
        (gnu-package? package)))
 
 (define %gnu-updater
-  (upstream-updater 'gnu
+  (upstream-updater
-                    non-emacs-gnu-package?
+   (name 'gnu)
-                    latest-release*))
+   (description "Updater for GNU packages")
+   (pred non-emacs-gnu-package?)
+   (latest latest-release*)))
 
 ;;; gnu-maintenance.scm ends here

guix/import/cran.scm

@@ -236,8 +236,10 @@ (define (cran-package? package)
   (string-prefix? "r-" (package-name package)))
 
 (define %cran-updater
-  (upstream-updater 'cran
+  (upstream-updater
-                    cran-package?
+   (name 'cran)
-                    latest-release))
+   (description "Updater for CRAN packages")
+   (pred cran-package?)
+   (latest latest-release)))
 
 ;;; cran.scm ends here

guix/import/elpa.scm

@@ -272,8 +272,10 @@ (define (package-from-gnu.org? package)
 (define %elpa-updater
   ;; The ELPA updater.  We restrict it to packages hosted on elpa.gnu.org
   ;; because for other repositories, we typically grab the source elsewhere.
-  (upstream-updater 'elpa
+  (upstream-updater
-                    package-from-gnu.org?
+   (name 'elpa)
-                    latest-release))
+   (description "Updater for ELPA packages")
+   (pred package-from-gnu.org?)
+   (latest latest-release)))
 
 ;;; elpa.scm ends here

guix/profiles.scm

@@ -84,13 +84,17 @@ (define-module (guix profiles)
             packages->manifest
             %default-profile-hooks
             profile-derivation
+
             generation-number
             generation-numbers
             profile-generations
             relative-generation
             previous-generation-number
             generation-time
-            generation-file-name))
+            generation-file-name
+            switch-to-generation
+            roll-back
+            delete-generation))
 
 ;;; Commentary:
 ;;;
@@ -844,4 +848,78 @@ (define (generation-time profile number)
   (make-time time-utc 0
              (stat:ctime (stat (generation-file-name profile number)))))
 
+(define (link-to-empty-profile store generation)
+  "Link GENERATION, a string, to the empty profile.  An error is raised if
+that fails."
+  (let* ((drv  (run-with-store store
+                 (profile-derivation (manifest '()))))
+         (prof (derivation->output-path drv "out")))
+    (build-derivations store (list drv))
+    (switch-symlinks generation prof)))
+
+(define (switch-to-generation profile number)
+  "Atomically switch PROFILE to the generation NUMBER.  Return the number of
+the generation that was current before switching."
+  (let ((current    (generation-number profile))
+        (generation (generation-file-name profile number)))
+    (cond ((not (file-exists? profile))
+           (raise (condition (&profile-not-found-error
+                              (profile profile)))))
+          ((not (file-exists? generation))
+           (raise (condition (&missing-generation-error
+                              (profile profile)
+                              (generation number)))))
+          (else
+           (switch-symlinks profile generation)
+           current))))
+
+(define (switch-to-previous-generation profile)
+  "Atomically switch PROFILE to the previous generation.  Return the former
+generation number and the current one."
+  (let ((previous (previous-generation-number profile)))
+    (values (switch-to-generation profile previous)
+            previous)))
+
+(define (roll-back store profile)
+  "Roll back to the previous generation of PROFILE.  Return the number of the
+generation that was current before switching and the new generation number."
+  (let* ((number              (generation-number profile))
+         (previous-number     (previous-generation-number profile number))
+         (previous-generation (generation-file-name profile previous-number)))
+    (cond ((not (file-exists? profile))           ;invalid profile
+           (raise (condition (&profile-not-found-error
+                              (profile profile)))))
+          ((zero? number)                         ;empty profile
+           (values number number))
+          ((or (zero? previous-number)            ;going to emptiness
+               (not (file-exists? previous-generation)))
+           (link-to-empty-profile store previous-generation)
+           (switch-to-previous-generation profile))
+          (else                                   ;anything else
+           (switch-to-previous-generation profile)))))
+
+(define (delete-generation store profile number)
+  "Delete generation with NUMBER from PROFILE.  Return the file name of the
+generation that has been deleted, or #f if nothing was done (for instance
+because the NUMBER is zero.)"
+  (define (delete-and-return)
+    (let ((generation (generation-file-name profile number)))
+      (delete-file generation)
+      generation))
+
+  (let* ((current-number      (generation-number profile))
+         (previous-number     (previous-generation-number profile number))
+         (previous-generation (generation-file-name profile previous-number)))
+    (cond ((zero? number) #f)                     ;do not delete generation 0
+          ((and (= number current-number)
+                (not (file-exists? previous-generation)))
+           (link-to-empty-profile store previous-generation)
+           (switch-to-previous-generation profile)
+           (delete-and-return))
+          ((= number current-number)
+           (roll-back store profile)
+           (delete-and-return))
+          (else
+           (delete-and-return)))))
+
 ;;; profiles.scm ends here

guix/scripts/build.scm

@@ -185,8 +185,7 @@ (define (set-build-options-from-command-line store opts)
                      #:max-build-jobs (or (assoc-ref opts 'max-jobs) 1)
                      #:fallback? (assoc-ref opts 'fallback?)
                      #:use-substitutes? (assoc-ref opts 'substitutes?)
-                     #:substitute-urls (or (assoc-ref opts 'substitute-urls)
+                     #:substitute-urls (assoc-ref opts 'substitute-urls)
-                                           %default-substitute-urls)
                      #:use-build-hook? (assoc-ref opts 'build-hook?)
                      #:max-silent-time (assoc-ref opts 'max-silent-time)
                      #:timeout (assoc-ref opts 'timeout)
@@ -290,6 +289,9 @@ (define (show-help)
   (display (_ "
   -e, --expression=EXPR  build the package or derivation EXPR evaluates to"))
   (display (_ "
+  -f, --file=FILE        build the package or derivation that the code within
+                         FILE evaluates to"))
+  (display (_ "
   -S, --source           build the packages' source derivations"))
   (display (_ "
       --sources[=TYPE]   build source derivations; TYPE may optionally be one
@@ -359,6 +361,9 @@ (define %options
          (option '(#\e "expression") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'expression arg result)))
+         (option '(#\f "file") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'file arg result)))
          (option '(#\n "dry-run") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'dry-run? #t result)))
@@ -422,29 +427,34 @@ (define (options/resolve-packages store opts)
   (define system
     (or (assoc-ref opts 'system) (%current-system)))
 
+  (define (object->argument obj)
+    (match obj
+      ((? package? p)
+       `(argument . ,p))
+      ((? procedure? proc)
+       (let ((drv (run-with-store store
+                    (mbegin %store-monad
+                      (set-guile-for-build (default-guile))
+                      (proc))
+                    #:system system)))
+         `(argument . ,drv)))
+      ((? gexp? gexp)
+       (let ((drv (run-with-store store
+                    (mbegin %store-monad
+                      (set-guile-for-build (default-guile))
+                      (gexp->derivation "gexp" gexp
+                                        #:system system)))))
+         `(argument . ,drv)))))
+
   (map (match-lambda
         (('argument . (? string? spec))
          (if (store-path? spec)
              `(argument . ,spec)
              `(argument . ,(specification->package spec))))
+        (('file . file)
+         (object->argument (load* file (make-user-module '()))))
         (('expression . str)
-         (match (read/eval str)
+         (object->argument (read/eval str)))
-           ((? package? p)
-            `(argument . ,p))
-           ((? procedure? proc)
-            (let ((drv (run-with-store store
-                         (mbegin %store-monad
-                           (set-guile-for-build (default-guile))
-                           (proc))
-                         #:system system)))
-              `(argument . ,drv)))
-           ((? gexp? gexp)
-            (let ((drv (run-with-store store
-                         (mbegin %store-monad
-                           (set-guile-for-build (default-guile))
-                           (gexp->derivation "gexp" gexp
-                                             #:system system)))))
-              `(argument . ,drv)))))
         (opt opt))
        opts))
 
@@ -501,6 +511,8 @@ (define (guix-build . args)
              (urls  (map (cut string-append <> "/log")
                          (if (assoc-ref opts 'substitutes?)
                              (or (assoc-ref opts 'substitute-urls)
+                                 ;; XXX: This does not necessarily match the
+                                 ;; daemon's substitute URLs.
                                  %default-substitute-urls)
                              '())))
              (roots (filter-map (match-lambda

guix/scripts/challenge.scm

@@ -125,10 +125,8 @@ (define (select-reference item narinfos urls)
                                               servers))
                        ;; No 'assert-valid-narinfo' on purpose.
                        (narinfos -> (fold (lambda (narinfo vhash)
-                                            (if narinfo
+                                            (vhash-cons (narinfo-path narinfo) narinfo
-                                                (vhash-cons (narinfo-path narinfo) narinfo
+                                                        vhash))
-                                                            vhash)
-                                                vhash))
                                           vlist-null
                                           remote)))
     (return (filter-map (lambda (item local)

guix/scripts/environment.scm

@@ -25,13 +25,19 @@ (define-module (guix scripts environment)
   #:use-module (guix profiles)
   #:use-module (guix search-paths)
   #:use-module (guix utils)
+  #:use-module (guix build utils)
   #:use-module (guix monads)
   #:use-module ((guix gexp) #:select (lower-inputs))
   #:use-module (guix scripts)
   #:use-module (guix scripts build)
+  #:use-module (gnu build linux-container)
+  #:use-module (gnu system linux-container)
+  #:use-module (gnu system file-systems)
   #:use-module (gnu packages)
+  #:use-module (gnu packages bash)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 rdelim)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
@@ -60,6 +66,12 @@ (define %precious-variables
 (define %default-shell
   (or (getenv "SHELL") "/bin/sh"))
 
+(define %network-configuration-files
+  '("/etc/resolv.conf"
+    "/etc/nsswitch.conf"
+    "/etc/services"
+    "/etc/hosts"))
+
 (define (purify-environment)
   "Unset almost all environment variables.  A small number of variables such
 as 'HOME' and 'USER' are left untouched."
@@ -124,6 +136,18 @@ (define (show-help)
       --search-paths     display needed environment variable definitions"))
   (display (_ "
   -s, --system=SYSTEM    attempt to build for SYSTEM--e.g., \"i686-linux\""))
+  (display (_ "
+  -C, --container        run command within an isolated container"))
+  (display (_ "
+  -N, --network          allow containers to access the network"))
+  (display (_ "
+      --share=SPEC       for containers, share writable host file system
+                         according to SPEC"))
+  (display (_ "
+      --expose=SPEC      for containers, expose read-only host file system
+                         according to SPEC"))
+  (display (_ "
+      --bootstrap        use bootstrap binaries to build the environment"))
   (newline)
   (show-build-options-help)
   (newline)
@@ -142,6 +166,16 @@ (define %default-options
     (max-silent-time . 3600)
     (verbosity . 0)))
 
+(define (tag-package-arg opts arg)
+  "Return a two-element list with the form (TAG ARG) that tags ARG with either
+'ad-hoc' in OPTS has the 'ad-hoc?' key set to #t, or 'inputs' otherwise."
+  ;; Normally, the transitive inputs to a package are added to an environment,
+  ;; but the ad-hoc? flag changes the meaning of a package argument such that
+  ;; the package itself is added to the environment instead.
+  (if (assoc-ref opts 'ad-hoc?)
+      `(ad-hoc-package ,arg)
+      `(package ,arg)))
+
 (define %options
   ;; Specification of the command-line options.
   (cons* (option '(#\h "help") #f #f
@@ -162,10 +196,14 @@ (define %options
                    (alist-cons 'search-paths #t result)))
          (option '(#\l "load") #t #f
                  (lambda (opt name arg result)
-                   (alist-cons 'load arg result)))
+                   (alist-cons 'load
+                               (tag-package-arg result arg)
+                               result)))
          (option '(#\e "expression") #t #f
                  (lambda (opt name arg result)
-                   (alist-cons 'expression arg result)))
+                   (alist-cons 'expression
+                               (tag-package-arg result arg)
+                               result)))
          (option '("ad-hoc") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'ad-hoc? #t result)))
@@ -176,6 +214,25 @@ (define %options
                  (lambda (opt name arg result)
                    (alist-cons 'system arg
                                (alist-delete 'system result eq?))))
+         (option '(#\C "container") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'container? #t result)))
+         (option '(#\N "network") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'network? #t result)))
+         (option '("share") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'file-system-mapping
+                               (specification->file-system-mapping arg #t)
+                               result)))
+         (option '("expose") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'file-system-mapping
+                               (specification->file-system-mapping arg #f)
+                               result)))
+         (option '("bootstrap") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'bootstrap? #t result)))
          %standard-build-options))
 
 (define (pick-all alist key)
@@ -189,29 +246,34 @@ (define same-key? (cut eq? key <>))
             (_ memo)))
         '() alist))
 
+(define (compact lst)
+  "Remove all #f elements from LST."
+  (filter identity lst))
+
 (define (options/resolve-packages opts)
   "Return OPTS with package specification strings replaced by actual
 packages."
-  (append-map (match-lambda
+  (compact
-                (('package . (? string? spec))
+   (append-map (match-lambda
-                 (let-values (((package output)
+                 (('package mode (? string? spec))
-                               (specification->package+output spec)))
+                  (let-values (((package output)
-                   `((package ,package ,output))))
+                                (specification->package+output spec)))
-                (('expression . str)
+                    (list (list mode package output))))
-                 ;; Add all the outputs of the package STR evaluates to.
+                 (('expression mode str)
-                 (match (read/eval str)
+                  ;; Add all the outputs of the package STR evaluates to.
-                   ((? package? package)
+                  (match (read/eval str)
+                    ((? package? package)
+                     (map (lambda (output)
+                            (list mode package output))
+                          (package-outputs package)))))
+                 (('load mode file)
+                  ;; Add all the outputs of the package defined in FILE.
+                  (let ((package (load* file (make-user-module '()))))
                     (map (lambda (output)
-                           `(package ,package ,output))
+                           (list mode package output))
-                         (package-outputs package)))))
+                         (package-outputs package))))
-                (('load . file)
+                 (_ '(#f)))
-                 ;; Add all the outputs of the package defined in FILE.
+               opts)))
-                 (let ((package (load* file (make-user-module '()))))
-                   (map (lambda (output)
-                          `(package ,package ,output))
-                        (package-outputs package))))
-                (opt (list opt)))
-              opts))
 
 (define (build-inputs inputs opts)
   "Build the derivations in INPUTS, a list of (DERIVATION) or (DERIVATION
@@ -231,10 +293,135 @@ (define (build-inputs inputs opts)
                (built-derivations derivations)
                (return derivations))))))))
 
+(define requisites* (store-lift requisites))
+
+(define (inputs->requisites inputs)
+  "Convert INPUTS, a list of input tuples or store path strings, into a set of
+requisite store items i.e. the union closure of all the inputs."
+  (define (input->requisites input)
+    (requisites*
+     (match input
+       ((drv output)
+        (derivation->output-path drv output))
+       ((drv)
+        (derivation->output-path drv))
+       ((? direct-store-path? path)
+        path))))
+
+  (mlet %store-monad ((reqs (sequence %store-monad
+                                      (map input->requisites inputs))))
+    (return (delete-duplicates (concatenate reqs)))))
+
+(define exit/status (compose exit status:exit-val))
+(define primitive-exit/status (compose primitive-exit status:exit-val))
+
+(define (launch-environment command inputs paths pure?)
+  "Run COMMAND in a new environment containing INPUTS, using the native search
+paths defined by the list PATHS.  When PURE?, pre-existing environment
+variables are cleared before setting the new ones."
+  (create-environment inputs paths pure?)
+  (apply system* command))
+
+(define* (launch-environment/container #:key command bash user-mappings
+                                       inputs paths network?)
+  "Run COMMAND within a Linux container.  The environment features INPUTS, a
+list of derivations to be shared from the host system.  Environment variables
+are set according to PATHS, a list of native search paths.  The global shell
+is BASH, a file name for a GNU Bash binary in the store.  When NETWORK?,
+access to the host system network is permitted.  USER-MAPPINGS, a list of file
+system mappings, contains the user-specified host file systems to mount inside
+the container."
+  (mlet %store-monad ((reqs (inputs->requisites
+                             (cons (direct-store-path bash) inputs))))
+    (return
+     (let* ((cwd (getcwd))
+            ;; Bind-mount all requisite store items, user-specified mappings,
+            ;; /bin/sh, the current working directory, and possibly networking
+            ;; configuration files within the container.
+            (mappings
+             (append user-mappings
+                     ;; Current working directory.
+                     (list (file-system-mapping
+                            (source cwd)
+                            (target cwd)
+                            (writable? #t)))
+                     ;; When in Rome, do as Nix build.cc does: Automagically
+                     ;; map common network configuration files.
+                     (if network?
+                         (filter-map (lambda (file)
+                                       (and (file-exists? file)
+                                            (file-system-mapping
+                                             (source file)
+                                             (target file)
+                                             (writable? #f))))
+                                     %network-configuration-files)
+                         '())
+                     ;; Mappings for the union closure of all inputs.
+                     (map (lambda (dir)
+                            (file-system-mapping
+                             (source dir)
+                             (target dir)
+                             (writable? #f)))
+                          reqs)))
+            (file-systems (append %container-file-systems
+                                  (map mapping->file-system mappings))))
+       (exit/status
+        (call-with-container (map file-system->spec file-systems)
+          (lambda ()
+            ;; Setup global shell.
+            (mkdir-p "/bin")
+            (symlink bash "/bin/sh")
+
+            ;; Setup directory for temporary files.
+            (mkdir-p "/tmp")
+            (for-each (lambda (var)
+                        (setenv var "/tmp"))
+                      ;; The same variables as in Nix's 'build.cc'.
+                      '("TMPDIR" "TEMPDIR" "TMP" "TEMP"))
+
+            ;; From Nix build.cc:
+            ;;
+            ;; Set HOME to a non-existing path to prevent certain
+            ;; programs from using /etc/passwd (or NIS, or whatever)
+            ;; to locate the home directory (for example, wget looks
+            ;; for ~/.wgetrc).  I.e., these tools use /etc/passwd if
+            ;; HOME is not set, but they will just assume that the
+            ;; settings file they are looking for does not exist if
+            ;; HOME is set but points to some non-existing path.
+            (setenv "HOME" "/homeless-shelter")
+
+            ;; For convenience, start in the user's current working
+            ;; directory rather than the root directory.
+            (chdir cwd)
+
+            (primitive-exit/status
+             ;; A container's environment is already purified, so no need to
+             ;; request it be purified again.
+             (launch-environment command inputs paths #f)))
+          #:namespaces (if network?
+                           (delq 'net %namespaces) ; share host network
+                           %namespaces)))))))
+
+(define (environment-bash container? bootstrap? system)
+  "Return a monadic value in the store monad for the version of GNU Bash
+needed in the environment for SYSTEM, if any.  If CONTAINER? is #f, return #f.
+If CONTAINER? and BOOTSTRAP?, return the store path for the bootstrap Bash.
+Otherwise, return the derivation for the Bash package."
+  (with-monad %store-monad
+    (cond
+     ((and container? (not bootstrap?))
+      (package->derivation bash))
+     ;; Use the bootstrap Bash instead.
+     ((and container? bootstrap?)
+      (interned-file
+       (search-bootstrap-binary "bash" system)))
+     (else
+      (return #f)))))
+
 (define (parse-args args)
   "Parse the list of command line arguments ARGS."
   (define (handle-argument arg result)
-    (alist-cons 'package arg result))
+    (alist-cons 'package (tag-package-arg result arg) result))
 
   ;; The '--' token is used to separate the command to run from the rest of
   ;; the operands.
@@ -248,52 +435,74 @@ (define (handle-argument arg result)
 ;; Entry point.
 (define (guix-environment . args)
   (with-error-handling
-    (let* ((opts     (parse-args args))
+    (let* ((opts       (parse-args args))
-           (pure?    (assoc-ref opts 'pure))
+           (pure?      (assoc-ref opts 'pure))
-           (ad-hoc?  (assoc-ref opts 'ad-hoc?))
+           (container? (assoc-ref opts 'container?))
-           (command  (assoc-ref opts 'exec))
+           (network?   (assoc-ref opts 'network?))
-           (packages (pick-all (options/resolve-packages opts) 'package))
+           (bootstrap? (assoc-ref opts 'bootstrap?))
-           (inputs   (if ad-hoc?
+           (system     (assoc-ref opts 'system))
-                         (append-map (match-lambda
+           (command    (assoc-ref opts 'exec))
-                                       ((package output)
+           (packages   (options/resolve-packages opts))
-                                        (package+propagated-inputs package
+           (mappings   (pick-all opts 'file-system-mapping))
-                                                                   output)))
+           (inputs     (delete-duplicates
-                                     packages)
+                        (append-map (match-lambda
-                         (append-map (compose bag-transitive-inputs
+                                      (('ad-hoc-package package output)
-                                              package->bag
+                                       (package+propagated-inputs package
-                                              first)
+                                                                  output))
-                                     packages)))
+                                      (('package package output)
-           (paths    (delete-duplicates
+                                       (bag-transitive-inputs
-                      (cons $PATH
+                                        (package->bag package))))
-                            (append-map (match-lambda
+                                    packages)))
-                                          ((label (? package? p) _ ...)
+           (paths      (delete-duplicates
-                                           (package-native-search-paths p))
+                        (cons $PATH
-                                          (_
+                              (append-map (match-lambda
-                                           '()))
+                                           ((label (? package? p) _ ...)
-                                        inputs))
+                                            (package-native-search-paths p))
-                      eq?)))
+                                           (_
+                                            '()))
+                                          inputs))
+                        eq?)))
       (with-store store
         (run-with-store store
-          (mlet %store-monad ((inputs (lower-inputs
+          (mlet* %store-monad ((inputs (lower-inputs
-                                       (map (match-lambda
+                                        (map (match-lambda
                                               ((label item)
                                                (list item))
                                               ((label item output)
                                                (list item output)))
-                                            inputs)
+                                             inputs)
-                                       #:system (assoc-ref opts 'system))))
+                                        #:system system))
+                               ;; Containers need a Bourne shell at /bin/sh.
+                               (bash (environment-bash container?
+                                                       bootstrap?
+                                                       system)))
             (mbegin %store-monad
-              ;; First build INPUTS.  This is necessary even for
+              ;; First build the inputs.  This is necessary even for
-              ;; --search-paths.
+              ;; --search-paths.  Additionally, we might need to build bash
-              (build-inputs inputs opts)
+              ;; for a container.
-              (cond ((assoc-ref opts 'dry-run?)
+              (build-inputs (if (derivation? bash)
-                     (return #t))
+                                `((,bash "out") ,@inputs)
-                    ((assoc-ref opts 'search-paths)
+                                inputs)
-                     (show-search-paths inputs paths pure?)
+                            opts)
-                     (return #t))
+              (cond
-                    (else
+               ((assoc-ref opts 'dry-run?)
-                     (create-environment inputs paths pure?)
+                (return #t))
-                     (return
+               ((assoc-ref opts 'search-paths)
-                      (exit
+                (show-search-paths inputs paths pure?)
-                       (status:exit-val
+                (return #t))
-                        (apply system* command)))))))))))))
+               (container?
+                (let ((bash-binary
+                       (if bootstrap?
+                           bash
+                           (string-append (derivation->output-path bash)
+                                          "/bin/sh"))))
+                  (launch-environment/container #:command command
+                                                #:bash bash-binary
+                                                #:user-mappings mappings
+                                                #:inputs inputs
+                                                #:paths paths
+                                                #:network? network?)))
+               (else
+                (return
+                 (exit/status
+                  (launch-environment command inputs paths pure?))))))))))))

guix/scripts/package.scm

@@ -48,11 +48,7 @@ (define-module (guix scripts package)
   #:use-module (gnu packages base)
   #:use-module (gnu packages guile)
   #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile))
-  #:export (switch-to-generation
+  #:export (delete-generations
-            switch-to-previous-generation
-            roll-back
-            delete-generation
-            delete-generations
             display-search-paths
             guix-package))
 
@@ -100,149 +96,12 @@ (define (user-friendly-profile profile)
       %user-profile-directory
       profile))
 
-(define (link-to-empty-profile store generation)
-  "Link GENERATION, a string, to the empty profile."
-  (let* ((drv  (run-with-store store
-                 (profile-derivation (manifest '()))))
-         (prof (derivation->output-path drv "out")))
-    (when (not (build-derivations store (list drv)))
-          (leave (_ "failed to build the empty profile~%")))
-
-    (switch-symlinks generation prof)))
-
-(define (switch-to-generation profile number)
-  "Atomically switch PROFILE to the generation NUMBER."
-  (let ((current    (generation-number profile))
-        (generation (generation-file-name profile number)))
-    (cond ((not (file-exists? profile))
-           (raise (condition (&profile-not-found-error
-                              (profile profile)))))
-          ((not (file-exists? generation))
-           (raise (condition (&missing-generation-error
-                              (profile profile)
-                              (generation number)))))
-          (else
-           (format #t (_ "switching from generation ~a to ~a~%")
-                   current number)
-           (switch-symlinks profile generation)))))
-
-(define (switch-to-previous-generation profile)
-  "Atomically switch PROFILE to the previous generation."
-  (switch-to-generation profile
-                        (previous-generation-number profile)))
-
-(define (roll-back store profile)
-  "Roll back to the previous generation of PROFILE."
-  (let* ((number              (generation-number profile))
-         (previous-number     (previous-generation-number profile number))
-         (previous-generation (generation-file-name profile previous-number)))
-    (cond ((not (file-exists? profile))                 ; invalid profile
-           (raise (condition (&profile-not-found-error
-                              (profile profile)))))
-          ((zero? number)                               ; empty profile
-           (format (current-error-port)
-                   (_ "nothing to do: already at the empty profile~%")))
-          ((or (zero? previous-number)                  ; going to emptiness
-               (not (file-exists? previous-generation)))
-           (link-to-empty-profile store previous-generation)
-           (switch-to-previous-generation profile))
-          (else
-           (switch-to-previous-generation profile)))))  ; anything else
-
-(define (delete-generation store profile number)
-  "Delete generation with NUMBER from PROFILE."
-  (define (display-and-delete)
-    (let ((generation (generation-file-name profile number)))
-      (format #t (_ "deleting ~a~%") generation)
-      (delete-file generation)))
-
-  (let* ((current-number      (generation-number profile))
-         (previous-number     (previous-generation-number profile number))
-         (previous-generation (generation-file-name profile previous-number)))
-    (cond ((zero? number))              ; do not delete generation 0
-          ((and (= number current-number)
-                (not (file-exists? previous-generation)))
-           (link-to-empty-profile store previous-generation)
-           (switch-to-previous-generation profile)
-           (display-and-delete))
-          ((= number current-number)
-           (roll-back store profile)
-           (display-and-delete))
-          (else
-           (display-and-delete)))))
-
 (define (delete-generations store profile generations)
   "Delete GENERATIONS from PROFILE.
 GENERATIONS is a list of generation numbers."
-  (for-each (cut delete-generation store profile <>)
+  (for-each (cut delete-generation* store profile <>)
             generations))
 
-(define* (matching-generations str #:optional (profile %current-profile)
-                               #:key (duration-relation <=))
-  "Return the list of available generations matching a pattern in STR.  See
-'string->generations' and 'string->duration' for the list of valid patterns.
-When STR is a duration pattern, return all the generations whose ctime has
-DURATION-RELATION with the current time."
-  (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 (duration-relation s (cdr x))
-                                (first x)))
-                         generation-ctime-alist))))))
-
-  (cond ((string->generations str)
-         =>
-         filter-generations)
-        ((string->duration str)
-         =>
-         filter-by-duration)
-        (else #f)))
-
 (define (delete-matching-generations store profile pattern)
   "Delete from PROFILE all the generations matching PATTERN.  PATTERN must be
 a string denoting a set of generations: the empty list means \"all generations
@@ -576,14 +435,14 @@ (define (package->manifest-entry* package output)
   (define upgrade-regexps
     (filter-map (match-lambda
                  (('upgrade . regexp)
-                  (make-regexp (or regexp "")))
+                  (make-regexp* (or regexp "")))
                  (_ #f))
                 opts))
 
   (define do-not-upgrade-regexps
     (filter-map (match-lambda
                  (('do-not-upgrade . regexp)
-                  (make-regexp regexp))
+                  (make-regexp* regexp))
                  (_ #f))
                 opts))
 
@@ -678,34 +537,6 @@ (define absolute
 
   (add-indirect-root store absolute))
 
-(define (readlink* file)
-  "Call 'readlink' until the result is not a symlink."
-  (define %max-symlink-depth 50)
-
-  (let loop ((file  file)
-             (depth 0))
-    (define (absolute target)
-      (if (absolute-file-name? target)
-          target
-          (string-append (dirname file) "/" target)))
-
-    (if (>= depth %max-symlink-depth)
-        file
-        (call-with-values
-            (lambda ()
-              (catch 'system-error
-                (lambda ()
-                  (values #t (readlink file)))
-                (lambda args
-                  (let ((errno (system-error-errno args)))
-                    (if (or (= errno EINVAL))
-                        (values #f file)
-                        (apply throw args))))))
-          (lambda (success? target)
-            (if success?
-                (loop (absolute target) (+ depth 1))
-                file))))))
-
 
 ;;;
 ;;; Entry point.
@@ -819,7 +650,7 @@ (define (build-and-use-profile manifest)
     ;; First roll back if asked to.
     (cond ((and (assoc-ref opts 'roll-back?)
                 (not dry-run?))
-           (roll-back (%store) profile)
+           (roll-back* (%store) profile)
            (process-actions (alist-delete 'roll-back? opts)))
           ((and (assoc-ref opts 'switch-generation)
                 (not dry-run?))
@@ -833,7 +664,7 @@ (define (build-and-use-profile manifest)
                                       (relative-generation profile number))
                                      (else number)))))
                  (if number
-                     (switch-to-generation profile number)
+                     (switch-to-generation* profile number)
                      (leave (_ "cannot switch to generation '~a'~%")
                             pattern)))
                (process-actions (alist-delete 'switch-generation opts)))
@@ -883,25 +714,8 @@ (define (process-query opts)
         (('list-generations pattern)
          (define (list-generation number)
            (unless (zero? number)
-             (let ((header (format #f (_ "Generation ~a\t~a") number
+             (display-generation profile number)
-                                   (date->string
+             (display-profile-content profile number)
-                                    (time-utc->date
-                                     (generation-time profile number))
-                                    "~b ~d ~Y ~T")))
-                   (current (generation-number profile)))
-               (if (= number current)
-                   (format #t (_ "~a\t(current)~%") header)
-                   (format #t "~a~%" header)))
-             (for-each (match-lambda
-                        (($ <manifest-entry> 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-entries
-                         (profile-manifest
-                          (generation-file-name profile number)))))
              (newline)))
 
          (cond ((not (file-exists? profile)) ; XXX: race condition
@@ -922,7 +736,7 @@ (define (list-generation number)
          #t)
 
         (('list-installed regexp)
-         (let* ((regexp    (and regexp (make-regexp regexp)))
+         (let* ((regexp    (and regexp (make-regexp* regexp)))
                 (manifest  (profile-manifest profile))
                 (installed (manifest-entries manifest)))
            (leave-on-EPIPE
@@ -938,7 +752,7 @@ (define (list-generation number)
            #t))
 
         (('list-available regexp)
-         (let* ((regexp    (and regexp (make-regexp regexp)))
+         (let* ((regexp    (and regexp (make-regexp* regexp)))
                 (available (fold-packages
                             (lambda (p r)
                               (let ((n (package-name p)))
@@ -964,7 +778,7 @@ (define (list-generation number)
            #t))
 
         (('search regexp)
-         (let ((regexp (make-regexp regexp regexp/icase)))
+         (let ((regexp (make-regexp* regexp regexp/icase)))
            (leave-on-EPIPE
             (for-each (cute package->recutils <> (current-output-port))
                       (find-packages-by-description regexp)))

guix/scripts/pull.scm

@@ -18,6 +18,7 @@
 
 (define-module (guix scripts pull)
   #:use-module (guix ui)
+  #:use-module (guix utils)
   #:use-module (guix scripts)
   #:use-module (guix store)
   #:use-module (guix config)

guix/scripts/refresh.scm

@@ -2,6 +2,7 @@
 ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
+;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -68,7 +69,13 @@ (define %options
                             arg)))))
         (option '(#\t "type") #t #f
                 (lambda (opt name arg result)
-                  (alist-cons 'updater (string->symbol arg) result)))
+                  (let* ((not-comma (char-set-complement (char-set #\,)))
+                         (names (map string->symbol
+                                     (string-tokenize arg not-comma))))
+                    (alist-cons 'updaters names result))))
+        (option '(#\L "list-updaters") #f #f
+                (lambda args
+                  (list-updaters-and-exit)))
         (option '(#\l "list-dependent") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'list-dependent? #t result)))
@@ -110,7 +117,10 @@ (define (show-help)
   -s, --select=SUBSET    select all the packages in SUBSET, one of
                          `core' or `non-core'"))
   (display (_ "
-  -t, --type=UPDATER     restrict to updates from UPDATER--e.g., 'gnu'"))
+  -t, --type=UPDATER,... restrict to updates from the specified updaters
+                         (e.g., 'gnu')"))
+  (display (_ "
+  -L, --list-updaters    list available updaters and exit"))
   (display (_ "
   -l, --list-dependent   list top-level dependent packages that would need to
                          be rebuilt as a result of upgrading PACKAGE..."))
@@ -149,6 +159,16 @@ (define (lookup-updater name)
           (eq? name (upstream-updater-name updater)))
         %updaters))
 
+(define (list-updaters-and-exit)
+  "Display available updaters and exit."
+  (format #t (_ "Available updaters:~%"))
+  (for-each (lambda (updater)
+              (format #t "- ~a: ~a~%"
+                      (upstream-updater-name updater)
+                      (_ (upstream-updater-description updater))))
+            %updaters)
+  (exit 0))
+
 (define* (update-package store package updaters
                          #:key (key-download 'interactive))
   "Update the source file that defines PACKAGE with the new version.
@@ -193,15 +213,15 @@ (define (parse-options)
   (define (options->updaters opts)
     ;; Return the list of updaters to use.
     (match (filter-map (match-lambda
-                         (('updater . name)
+                         (('updaters . names)
-                          (lookup-updater name))
+                          (map lookup-updater names))
                          (_ #f))
                        opts)
       (()
        ;; Use the default updaters.
        %updaters)
-      (lst
+      (lists
-       lst)))
+       (concatenate lists))))
 
   (define (keep-newest package lst)
     ;; If a newer version of PACKAGE is already in LST, return LST; otherwise

guix/scripts/size.scm

@@ -252,8 +252,7 @@ (define %options
                   (show-version-and-exit "guix size")))))
 
 (define %default-options
-  `((system . ,(%current-system))
+  `((system . ,(%current-system))))
-    (substitute-urls . ,%default-substitute-urls)))
 
 
 ;;;

guix/scripts/substitute.scm

@@ -72,6 +72,7 @@ (define-module (guix scripts substitute)
             assert-valid-narinfo
 
             lookup-narinfos
+            lookup-narinfos/diverse
             read-narinfo
             write-narinfo
             guix-substitute))
@@ -474,12 +475,13 @@ (define (narinfo-request cache-url path)
                             ".narinfo")))
     (build-request (string->uri url) #:method 'GET)))
 
-(define (http-multiple-get base-url requests proc)
+(define (http-multiple-get base-url proc seed requests)
   "Send all of REQUESTS to the server at BASE-URL.  Call PROC for each
-response, passing it the request object, the response, and a port from which
+response, passing it the request object, the response, a port from which to
-to read the response body.  Return the list of results."
+read the response body, and the previous result, starting with SEED, à la
+'fold'.  Return the final result."
   (let connect ((requests requests)
-                (result   '()))
+                (result   seed))
     ;; (format (current-error-port) "connecting (~a requests left)..."
     ;;         (length requests))
     (let ((p (open-socket-for-uri base-url)))
@@ -497,7 +499,7 @@ (define (http-multiple-get base-url requests proc)
           ((head tail ...)
            (let* ((resp   (read-response p))
                   (body   (response-body-port resp))
-                  (result (cons (proc head resp body) result)))
+                  (result (proc head resp body result)))
              ;; The server can choose to stop responding at any time, in which
              ;; case we have to try again.  Check whether that is the case.
              ;; Note that even upon "Connection: close", we can read from BODY.
@@ -536,7 +538,7 @@ (define update-progress!
                 url (* 100. (/ done (length paths))))
         (set! done (+ 1 done)))))
 
-  (define (handle-narinfo-response request response port)
+  (define (handle-narinfo-response request response port result)
     (let ((len (response-content-length response)))
       ;; Make sure to read no more than LEN bytes since subsequent bytes may
       ;; belong to the next response.
@@ -545,7 +547,7 @@ (define (handle-narinfo-response request response port)
          (let ((narinfo (read-narinfo port url #:size len)))
            (cache-narinfo! url (narinfo-path narinfo) narinfo)
            (update-progress!)
-           narinfo))
+           (cons narinfo result)))
         ((404)                                     ; failure
          (let* ((path      (uri-path (request-uri request)))
                 (hash-part (string-drop-right path 8))) ; drop ".narinfo"
@@ -555,13 +557,13 @@ (define (handle-narinfo-response request response port)
            (cache-narinfo! url
                            (find (cut string-contains <> hash-part) paths)
                            #f)
-           (update-progress!))
+           (update-progress!)
-         #f)
+           result))
         (else                                      ; transient failure
          (if len
              (get-bytevector-n port len)
              (read-to-eof port))
-         #f))))
+         result))))
 
   (define cache-info
     (download-cache-info url))
@@ -574,8 +576,9 @@ (define cache-info
            ((http)
             (let ((requests (map (cut narinfo-request url <>) paths)))
               (update-progress!)
-              (let ((result (http-multiple-get url requests
+              (let ((result (http-multiple-get url
-                                               handle-narinfo-response)))
+                                               handle-narinfo-response '()
+                                               requests)))
                 (newline (current-error-port))
                 result)))
            ((file #f)
@@ -596,7 +599,9 @@ (define (lookup-narinfos cache paths)
                          (let-values (((valid? value)
                                        (cached-narinfo cache path)))
                            (if valid?
-                               (values (cons value cached) missing)
+                               (if value
+                                   (values (cons value cached) missing)
+                                   (values cached missing))
                                (values cached (cons path missing)))))
                        '()
                        '()
@@ -606,11 +611,32 @@ (define (lookup-narinfos cache paths)
         (let ((missing (fetch-narinfos cache missing)))
           (append cached (or missing '()))))))
 
-(define (lookup-narinfo cache path)
+(define (lookup-narinfos/diverse caches paths)
-  "Return the narinfo for PATH in CACHE, or #f when no substitute for PATH was
+  "Look up narinfos for PATHS on all of CACHES, a list of URLS, in that order.
-found."
+That is, when a cache lacks a narinfo, look it up in the next cache, and so
-  (match (lookup-narinfos cache (list path))
+on.  Return a list of narinfos for PATHS or a subset thereof."
-    ((answer) answer)))
+  (let loop ((caches caches)
+             (paths  paths)
+             (result '()))
+    (match paths
+      (()                                         ;we're done
+       result)
+      (_
+       (match caches
+         ((cache rest ...)
+          (let* ((narinfos (lookup-narinfos cache paths))
+                 (hits     (map narinfo-path narinfos))
+                 (missing  (lset-difference string=? paths hits))) ;XXX: perf
+            (loop rest missing (append narinfos result))))
+         (()                                      ;that's it
+          result))))))
+
+(define (lookup-narinfo caches path)
+  "Return the narinfo for PATH in CACHES, or #f when no substitute for PATH
+was found."
+  (match (lookup-narinfos/diverse caches (list path))
+    ((answer) answer)
+    (_        #f)))
 
 (define (remove-expired-cached-narinfos directory)
   "Remove expired narinfo entries from DIRECTORY.  The sole purpose of this
@@ -752,34 +778,34 @@ (define (display-narinfo-data narinfo)
           (or (narinfo-size narinfo) 0)))
 
 (define* (process-query command
-                        #:key cache-url acl)
+                        #:key cache-urls acl)
   "Reply to COMMAND, a query as written by the daemon to this process's
 standard input.  Use ACL as the access-control list against which to check
 authorized substitutes."
   (define (valid? obj)
-    (and (narinfo? obj) (valid-narinfo? obj acl)))
+    (valid-narinfo? obj acl))
 
   (match (string-tokenize command)
     (("have" paths ..1)
-     ;; Return the subset of PATHS available in CACHE-URL.
+     ;; Return the subset of PATHS available in CACHE-URLS.
-     (let ((substitutable (lookup-narinfos cache-url paths)))
+     (let ((substitutable (lookup-narinfos/diverse cache-urls paths)))
        (for-each (lambda (narinfo)
                    (format #t "~a~%" (narinfo-path narinfo)))
                  (filter valid? substitutable))
        (newline)))
     (("info" paths ..1)
-     ;; Reply info about PATHS if it's in CACHE-URL.
+     ;; Reply info about PATHS if it's in CACHE-URLS.
-     (let ((substitutable (lookup-narinfos cache-url paths)))
+     (let ((substitutable (lookup-narinfos/diverse cache-urls paths)))
        (for-each display-narinfo-data (filter valid? substitutable))
        (newline)))
     (wtf
      (error "unknown `--query' command" wtf))))
 
 (define* (process-substitution store-item destination
-                               #:key cache-url acl)
+                               #:key cache-urls acl)
-  "Substitute STORE-ITEM (a store file name) from CACHE-URL, and write it to
+  "Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to
 DESTINATION as a nar file.  Verify the substitute against ACL."
-  (let* ((narinfo (lookup-narinfo cache-url store-item))
+  (let* ((narinfo (lookup-narinfo cache-urls store-item))
          (uri     (narinfo-uri narinfo)))
     ;; Make sure it is signed and everything.
     (assert-valid-narinfo narinfo acl)
@@ -876,21 +902,16 @@ (define-syntax-rule (or* a b)
         b
         first)))
 
-(define %cache-url
+(define %cache-urls
   (match (and=> (or* (find-daemon-option "untrusted-substitute-urls") ;client
                      (find-daemon-option "substitute-urls"))          ;admin
                 string-tokenize)
-    ((url)
+    ((urls ...)
-     url)
+     urls)
-    ((head tail ..1)
-     ;; Currently we don't handle multiple substitute URLs.
-     (warning (_ "these substitute URLs will not be used:~{ ~a~}~%")
-              tail)
-     head)
     (#f
      ;; This can only happen when this script is not invoked by the
      ;; daemon.
-     "http://hydra.gnu.org")))
+     '("http://hydra.gnu.org"))))
 
 (define (guix-substitute . args)
   "Implement the build daemon's substituter protocol."
@@ -901,20 +922,8 @@ (define (guix-substitute . args)
   ;; Starting from commit 22144afa in Nix, we are allowed to bail out directly
   ;; when we know we cannot substitute, but we must emit a newline on stdout
   ;; when everything is alright.
-  (let ((uri (string->uri %cache-url)))
+  (when (null? %cache-urls)
-    (case (uri-scheme uri)
+    (exit 0))
-      ((http)
-       ;; Exit gracefully if there's no network access.
-       (let ((host (uri-host uri)))
-         (catch 'getaddrinfo-error
-           (lambda ()
-             (getaddrinfo host))
-           (lambda (key error)
-             (warning (_ "failed to look up host '~a' (~a), \
-substituter disabled~%")
-                      host (gai-strerror error))
-             (exit 0)))))
-      (else #t)))
 
   ;; Say hello (see above.)
   (newline)
@@ -929,13 +938,13 @@ (define (guix-substitute . args)
             (or (eof-object? command)
                 (begin
                   (process-query command
-                                 #:cache-url %cache-url
+                                 #:cache-urls %cache-urls
                                  #:acl acl)
                   (loop (read-line)))))))
        (("--substitute" store-path destination)
         ;; Download STORE-PATH and add store it as a Nar in file DESTINATION.
         (process-substitution store-path destination
-                              #:cache-url %cache-url
+                              #:cache-urls %cache-urls
                               #:acl (current-acl)))
        (("--version")
         (show-version-and-exit "guix substitute"))

guix/scripts/system.scm

@@ -25,6 +25,7 @@ (define-module (guix scripts system)
   #:use-module (guix packages)
   #:use-module (guix utils)
   #:use-module (guix monads)
+  #:use-module (guix records)
   #:use-module (guix profiles)
   #:use-module (guix scripts)
   #:use-module (guix scripts build)
@@ -41,6 +42,8 @@ (define-module (guix scripts system)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 match)
   #:export (guix-system
@@ -184,6 +187,39 @@ (define (maybe-copy to-copy)
       (mwhen grub?
         (install-grub* grub.cfg device target)))))
 
+
+;;;
+;;; Boot parameters
+;;;
+
+(define-record-type* <boot-parameters>
+  boot-parameters make-boot-parameters boot-parameters?
+  (label            boot-parameters-label)
+  (root-device      boot-parameters-root-device)
+  (kernel           boot-parameters-kernel)
+  (kernel-arguments boot-parameters-kernel-arguments))
+
+(define (read-boot-parameters port)
+  "Read boot parameters from PORT and return the corresponding
+<boot-parameters> object or #f if the format is unrecognized."
+  (match (read port)
+    (('boot-parameters ('version 0)
+                       ('label label) ('root-device root)
+                       ('kernel linux)
+                       rest ...)
+     (boot-parameters
+      (label label)
+      (root-device root)
+      (kernel linux)
+      (kernel-arguments
+       (match (assq 'kernel-arguments rest)
+         ((_ args) args)
+         (#f       '())))))                       ;the old format
+    (x                                            ;unsupported format
+     (warning (_ "unrecognized boot parameters for '~a'~%")
+              system)
+     #f)))
+
 
 ;;;
 ;;; Reconfiguration.
@@ -247,30 +283,22 @@ (define* (previous-grub-entries #:optional (profile %system-profile))
   "Return a list of 'menu-entry' for the generations of PROFILE."
   (define (system->grub-entry system number time)
     (unless-file-not-found
-     (call-with-input-file (string-append system "/parameters")
+     (let ((file (string-append system "/parameters")))
-       (lambda (port)
+       (match (call-with-input-file file read-boot-parameters)
-         (match (read port)
+         (($ <boot-parameters> label root kernel kernel-arguments)
-           (('boot-parameters ('version 0)
+          (menu-entry
-                              ('label label) ('root-device root)
+           (label (string-append label " (#"
-                              ('kernel linux)
+                                 (number->string number) ", "
-                              rest ...)
+                                 (seconds->string time) ")"))
-            (menu-entry
+           (linux kernel)
-             (label (string-append label " (#"
+           (linux-arguments
-                                   (number->string number) ", "
+            (cons* (string-append "--root=" root)
-                                   (seconds->string time) ")"))
+                   #~(string-append "--system=" #$system)
-             (linux linux)
+                   #~(string-append "--load=" #$system "/boot")
-             (linux-arguments
+                   kernel-arguments))
-              (cons* (string-append "--root=" root)
+           (initrd #~(string-append #$system "/initrd"))))
-                     #~(string-append "--system=" #$system)
+         (#f                                      ;invalid format
-                     #~(string-append "--load=" #$system "/boot")
+          #f)))))
-                     (match (assq 'kernel-arguments rest)
-                       ((_ args) args)
-                       (#f       '()))))          ;old format
-             (initrd #~(string-append #$system "/initrd"))))
-           (_                                     ;unsupported format
-            (warning (_ "unrecognized boot parameters for '~a'~%")
-                     system)
-            #f))))))
 
   (let* ((numbers (generation-numbers profile))
          (systems (map (cut generation-file-name profile <>)
@@ -325,6 +353,48 @@ (define (dmd-service-node-type services)
    (label dmd-service-node-label)
    (edges (lift1 (dmd-service-back-edges services) %store-monad))))
 
+
+;;;
+;;; Generations.
+;;;
+
+(define* (display-system-generation number
+                                    #:optional (profile %system-profile))
+  "Display a summary of system generation NUMBER in a human-readable format."
+  (unless (zero? number)
+    (let* ((generation (generation-file-name profile number))
+           (param-file (string-append generation "/parameters"))
+           (params     (call-with-input-file param-file read-boot-parameters)))
+      (display-generation profile number)
+      (format #t (_ "  file name: ~a~%") generation)
+      (format #t (_ "  canonical file name: ~a~%") (readlink* generation))
+      (match params
+        (($ <boot-parameters> label root kernel)
+         ;; TRANSLATORS: Please preserve the two-space indentation.
+         (format #t (_ "  label: ~a~%") label)
+         (format #t (_ "  root device: ~a~%") root)
+         (format #t (_ "  kernel: ~a~%") kernel))
+        (_
+         #f)))))
+
+(define* (list-generations pattern #:optional (profile %system-profile))
+  "Display in a human-readable format all the system generations matching
+PATTERN, a string.  When PATTERN is #f, display all the system generations."
+  (cond ((not (file-exists? profile))             ; XXX: race condition
+         (raise (condition (&profile-not-found-error
+                            (profile profile)))))
+        ((string-null? pattern)
+         (for-each display-system-generation (profile-generations profile)))
+        ((matching-generations pattern profile)
+         =>
+         (lambda (numbers)
+           (if (null-list? numbers)
+               (exit 1)
+               (leave-on-EPIPE
+                (for-each display-system-generation numbers)))))
+        (else
+         (leave (_ "invalid syntax: ~a~%") pattern))))
+
 
 ;;;
 ;;; Action.
@@ -442,13 +512,15 @@ (define (export-dmd-graph os port)
 ;;;
 
 (define (show-help)
-  (display (_ "Usage: guix system [OPTION] ACTION FILE
+  (display (_ "Usage: guix system [OPTION] ACTION [FILE]
 Build the operating system declared in FILE according to ACTION.\n"))
   (newline)
   (display (_ "The valid values for ACTION are:\n"))
   (newline)
   (display (_ "\
    reconfigure      switch to a new operating system configuration\n"))
+  (display (_ "\
+   list-generations list the system generations\n"))
   (display (_ "\
    build            build the operating system without installing anything\n"))
   (display (_ "\
@@ -488,19 +560,6 @@ (define (show-help)
   (newline)
   (show-bug-report-information))
 
-(define (specification->file-system-mapping spec writable?)
-  "Read the SPEC and return the corresponding <file-system-mapping>."
-  (let ((index (string-index spec #\=)))
-    (if index
-        (file-system-mapping
-         (source (substring spec 0 index))
-         (target (substring spec (+ 1 index)))
-         (writable? writable?))
-        (file-system-mapping
-         (source spec)
-         (target spec)
-         (writable? writable?)))))
-
 (define %options
   ;; Specifications of the command-line options.
   (cons* (option '(#\h "help") #f #f
@@ -563,6 +622,71 @@ (define %default-options
 ;;; Entry point.
 ;;;
 
+(define (process-action action args opts)
+  "Process ACTION, a sub-command, with the arguments are listed in ARGS.
+ACTION must be one of the sub-commands that takes an operating system
+declaration as an argument (a file name.)  OPTS is the raw alist of options
+resulting from command-line parsing."
+  (let* ((file     (match args
+                     (() #f)
+                     ((x . _) x)))
+         (system   (assoc-ref opts 'system))
+         (os       (if file
+                       (load* file %user-module
+                              #:on-error (assoc-ref opts 'on-error))
+                       (leave (_ "no configuration file specified~%"))))
+
+         (dry?     (assoc-ref opts 'dry-run?))
+         (grub?    (assoc-ref opts 'install-grub?))
+         (target   (match args
+                     ((first second) second)
+                     (_ #f)))
+         (device   (and grub?
+                        (grub-configuration-device
+                         (operating-system-bootloader os)))))
+
+    (with-store store
+      (set-build-options-from-command-line store opts)
+
+      (run-with-store store
+        (mbegin %store-monad
+          (set-guile-for-build (default-guile))
+          (case action
+            ((extension-graph)
+             (export-extension-graph os (current-output-port)))
+            ((dmd-graph)
+             (export-dmd-graph os (current-output-port)))
+            (else
+             (perform-action action os
+                             #:dry-run? dry?
+                             #:derivations-only? (assoc-ref opts
+                                                            'derivations-only?)
+                             #:use-substitutes? (assoc-ref opts 'substitutes?)
+                             #:image-size (assoc-ref opts 'image-size)
+                             #:full-boot? (assoc-ref opts 'full-boot?)
+                             #:mappings (filter-map (match-lambda
+                                                      (('file-system-mapping . m)
+                                                       m)
+                                                      (_ #f))
+                                                    opts)
+                             #:grub? grub?
+                             #:target target #:device device))))
+        #:system system))))
+
+(define (process-command command args opts)
+  "Process COMMAND, one of the 'guix system' sub-commands.  ARGS is its
+argument list and OPTS is the option alist."
+  (case command
+    ((list-generations)
+     ;; List generations.  No need to connect to the daemon, etc.
+     (let ((pattern (match args
+                      (() "")
+                      ((pattern) pattern)
+                      (x (leave (_ "wrong number of arguments~%"))))))
+       (list-generations pattern)))
+    (else
+     (process-action command args opts))))
+
 (define (guix-system . args)
   (define (parse-sub-command arg result)
     ;; Parse sub-command ARG and augment RESULT accordingly.
@@ -571,7 +695,7 @@ (define (parse-sub-command arg result)
         (let ((action (string->symbol arg)))
           (case action
             ((build vm vm-image disk-image reconfigure init
-              extension-graph dmd-graph)
+              extension-graph dmd-graph list-generations)
              (alist-cons 'action action result))
             (else (leave (_ "~a: unknown action~%") action))))))
 
@@ -613,49 +737,7 @@ (define (fail)
                                          #:argument-handler
                                          parse-sub-command))
            (args     (option-arguments opts))
-           (file     (first args))
+           (command  (assoc-ref opts 'action)))
-           (action   (assoc-ref opts 'action))
+      (process-command command args opts))))
-           (system   (assoc-ref opts 'system))
-           (os       (if file
-                         (load* file %user-module
-                                #:on-error (assoc-ref opts 'on-error))
-                         (leave (_ "no configuration file specified~%"))))
-
-           (dry?     (assoc-ref opts 'dry-run?))
-           (grub?    (assoc-ref opts 'install-grub?))
-           (target   (match args
-                       ((first second) second)
-                       (_ #f)))
-           (device   (and grub?
-                          (grub-configuration-device
-                           (operating-system-bootloader os))))
-
-           (store    (open-connection)))
-      (set-build-options-from-command-line store opts)
-
-      (run-with-store store
-        (mbegin %store-monad
-          (set-guile-for-build (default-guile))
-          (case action
-            ((extension-graph)
-             (export-extension-graph os (current-output-port)))
-            ((dmd-graph)
-             (export-dmd-graph os (current-output-port)))
-            (else
-             (perform-action action os
-                             #:dry-run? dry?
-                             #:derivations-only? (assoc-ref opts
-                                                            'derivations-only?)
-                             #:use-substitutes? (assoc-ref opts 'substitutes?)
-                             #:image-size (assoc-ref opts 'image-size)
-                             #:full-boot? (assoc-ref opts 'full-boot?)
-                             #:mappings (filter-map (match-lambda
-                                                      (('file-system-mapping . m)
-                                                       m)
-                                                      (_ #f))
-                                                    opts)
-                             #:grub? grub?
-                             #:target target #:device device))))
-        #:system system))))
 
 ;;; system.scm ends here

guix/store.scm

@@ -501,11 +501,11 @@ (define* (set-build-options server
                             (build-cores (current-processor-count))
                             (use-substitutes? #t)
 
-                            ;; Client-provided substitute URLs.  For
+                            ;; Client-provided substitute URLs.  If it is #f,
-                            ;; unprivileged clients, these are considered
+                            ;; the daemon's settings are used.  Otherwise, it
-                            ;; "untrusted"; for "trusted" users, they override
+                            ;; overrides the daemons settings; see 'guix
-                            ;; the daemon's settings.
+                            ;; substitute'.
-                            (substitute-urls %default-substitute-urls))
+                            (substitute-urls #f))
   ;; Must be called after `open-connection'.
 
   (define socket
@@ -533,7 +533,10 @@ (define socket
       (let ((pairs `(,@(if timeout
                            `(("build-timeout" . ,(number->string timeout)))
                            '())
-                     ("substitute-urls" . ,(string-join substitute-urls)))))
+                     ,@(if substitute-urls
+                           `(("substitute-urls"
+                              . ,(string-join substitute-urls)))
+                           '()))))
         (send (string-pairs pairs))))
     (let loop ((done? (process-stderr server)))
       (or done? (process-stderr server)))))

guix/ui.scm

@@ -34,6 +34,7 @@ (define-module (guix ui)
   #:use-module (guix serialization)
   #:use-module ((guix build utils) #:select (mkdir-p))
   #:use-module ((guix licenses) #:select (license? license-name))
+  #:use-module (gnu system file-systems)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-19)
@@ -60,6 +61,7 @@ (define-module (guix ui)
             warn-about-load-error
             show-version-and-exit
             show-bug-report-information
+            make-regexp*
             string->number*
             size->number
             show-derivation-outputs
@@ -72,7 +74,6 @@ (define-module (guix ui)
             read/eval
             read/eval-package-expression
             location->string
-            switch-symlinks
             config-directory
             fill-paragraph
             texi->plain-text
@@ -80,8 +81,15 @@ (define-module (guix ui)
             string->recutils
             package->recutils
             package-specification->name+version+output
+            specification->file-system-mapping
             string->generations
             string->duration
+            matching-generations
+            display-generation
+            display-profile-content
+            roll-back*
+            switch-to-generation*
+            delete-generation*
             run-guix-command
             run-guix
             program-name
@@ -343,6 +351,16 @@ (define (show-bug-report-information)
                  (list (strerror (car errno)) target)
                  (list errno)))))))
 
+(define (make-regexp* regexp . flags)
+  "Like 'make-regexp' but error out if REGEXP is invalid, reporting the error
+nicely."
+  (catch 'regular-expression-syntax
+    (lambda ()
+      (apply make-regexp regexp flags))
+    (lambda (key proc message . rest)
+      (leave (_ "'~a' is not a valid regular expression: ~a~%")
+             regexp message))))
+
 (define (string->number* str)
   "Like `string->number', but error out with an error message on failure."
   (or (string->number str)
@@ -710,13 +728,6 @@ (define (location->string loc)
     (($ <location> file line column)
      (format #f "~a:~a:~a" file line column))))
 
-(define (switch-symlinks link target)
-  "Atomically switch LINK, a symbolic link, to point to TARGET.  Works
-both when LINK already exists and when it does not."
-  (let ((pivot (string-append link ".new")))
-    (symlink target pivot)
-    (rename-file pivot link)))
-
 (define (config-directory)
   "Return the name of the configuration directory, after making sure that it
 exists.  Honor the XDG specs,
@@ -946,6 +957,119 @@ (define (hours->duration hours match)
            (hours->duration (* 24 30) match)))
         (else #f)))
 
+(define* (matching-generations str profile
+                               #:key (duration-relation <=))
+  "Return the list of available generations matching a pattern in STR.  See
+'string->generations' and 'string->duration' for the list of valid patterns.
+When STR is a duration pattern, return all the generations whose ctime has
+DURATION-RELATION with the current time."
+  (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 (duration-relation s (cdr x))
+                                (first x)))
+                         generation-ctime-alist))))))
+
+  (cond ((string->generations str)
+         =>
+         filter-generations)
+        ((string->duration str)
+         =>
+         filter-by-duration)
+        (else #f)))
+
+(define (display-generation profile number)
+  "Display a one-line summary of generation NUMBER of PROFILE."
+  (unless (zero? number)
+    (let ((header (format #f (_ "Generation ~a\t~a") number
+                          (date->string
+                           (time-utc->date
+                            (generation-time profile number))
+                           "~b ~d ~Y ~T")))
+          (current (generation-number profile)))
+      (if (= number current)
+          (format #t (_ "~a\t(current)~%") header)
+          (format #t "~a~%" header)))))
+
+(define (display-profile-content profile number)
+  "Display the packages in PROFILE, generation NUMBER, in a human-readable
+way."
+  (for-each (match-lambda
+              (($ <manifest-entry> 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-entries
+              (profile-manifest (generation-file-name profile number))))))
+
+(define (display-generation-change previous current)
+  (format #t (_ "switched from generation ~a to ~a~%") previous current))
+
+(define (roll-back* store profile)
+  "Like 'roll-back', but display what is happening."
+  (call-with-values
+      (lambda ()
+        (roll-back store profile))
+    display-generation-change))
+
+(define (switch-to-generation* profile number)
+  "Like 'switch-generation', but display what is happening."
+  (let ((previous (switch-to-generation profile number)))
+    (display-generation-change previous number)))
+
+(define (delete-generation* store profile generation)
+  "Like 'delete-generation', but display what is going on."
+  (format #t (_ "deleting ~a~%")
+          (generation-file-name profile generation))
+  (delete-generation store profile generation))
+
 (define* (package-specification->name+version+output spec
                                                      #:optional (output "out"))
   "Parse package specification SPEC and return three value: the specified
@@ -966,6 +1090,23 @@ (define* (package-specification->name+version+output spec
                  (package-name->name+version name)))
     (values name version sub-drv)))
 
+(define (specification->file-system-mapping spec writable?)
+  "Read the SPEC and return the corresponding <file-system-mapping>.  SPEC is
+a string of the form \"SOURCE\" or \"SOURCE=TARGET\".  The former specifies
+that SOURCE from the host should be mounted at SOURCE in the other system.
+The latter format specifies that SOURCE from the host should be mounted at
+TARGET in the other system."
+  (let ((index (string-index spec #\=)))
+    (if index
+        (file-system-mapping
+         (source (substring spec 0 index))
+         (target (substring spec (+ 1 index)))
+         (writable? writable?))
+        (file-system-mapping
+         (source spec)
+         (target spec)
+         (writable? writable?)))))
+
 
 ;;;
 ;;; Command-line option processing.

guix/upstream.scm

@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -45,6 +46,7 @@ (define-module (guix upstream)
             upstream-updater
             upstream-updater?
             upstream-updater-name
+            upstream-updater-description
             upstream-updater-predicate
             upstream-updater-latest
 
@@ -109,18 +111,19 @@ (define (release>? r1 r2)
 ;;; Auto-update.
 ;;;
 
-(define-record-type <upstream-updater>
+(define-record-type* <upstream-updater>
-  (upstream-updater name pred latest)
+  upstream-updater make-upstream-updater
   upstream-updater?
-  (name      upstream-updater-name)
+  (name        upstream-updater-name)
-  (pred      upstream-updater-predicate)
+  (description upstream-updater-description)
-  (latest    upstream-updater-latest))
+  (pred        upstream-updater-predicate)
+  (latest      upstream-updater-latest))
 
 (define (lookup-updater package updaters)
   "Return an updater among UPDATERS that matches PACKAGE, or #f if none of
 them matches."
   (any (match-lambda
-         (($ <upstream-updater> _ pred latest)
+         (($ <upstream-updater> _ _ pred latest)
           (and (pred package) latest)))
        updaters))
 

guix/utils.scm

@@ -74,6 +74,7 @@ (define-module (guix utils)
             arguments-from-environment-variable
             file-extension
             file-sans-extension
+            switch-symlinks
             call-with-temporary-output-file
             call-with-temporary-directory
             with-atomic-file-output
@@ -82,6 +83,7 @@ (define-module (guix utils)
             fold-tree-leaves
             split
             cache-directory
+            readlink*
 
             filtered-port
             compressed-port
@@ -556,6 +558,13 @@ (define (file-sans-extension file)
         (substring file 0 dot)
         file)))
 
+(define (switch-symlinks link target)
+  "Atomically switch LINK, a symbolic link, to point to TARGET.  Works
+both when LINK already exists and when it does not."
+  (let ((pivot (string-append link ".new")))
+    (symlink target pivot)
+    (rename-file pivot link)))
+
 (define* (string-replace-substring str substr replacement
                                    #:optional
                                    (start 0)
@@ -710,6 +719,33 @@ (define (cache-directory)
       (and=> (getenv "HOME")
              (cut string-append <> "/.cache/guix"))))
 
+(define (readlink* file)
+  "Call 'readlink' until the result is not a symlink."
+  (define %max-symlink-depth 50)
+
+  (let loop ((file  file)
+             (depth 0))
+    (define (absolute target)
+      (if (absolute-file-name? target)
+          target
+          (string-append (dirname file) "/" target)))
+
+    (if (>= depth %max-symlink-depth)
+        file
+        (call-with-values
+            (lambda ()
+              (catch 'system-error
+                (lambda ()
+                  (values #t (readlink file)))
+                (lambda args
+                  (let ((errno (system-error-errno args)))
+                    (if (or (= errno EINVAL))
+                        (values #f file)
+                        (apply throw args))))))
+          (lambda (success? target)
+            (if success?
+                (loop (absolute target) (+ depth 1))
+                file))))))
 
 ;;;
 ;;; Source location.

po/guix/POTFILES.in

@@ -12,6 +12,7 @@ guix/scripts/package.scm
 guix/scripts/gc.scm
 guix/scripts/hash.scm
 guix/scripts/import.scm
+guix/scripts/import/cran.scm
 guix/scripts/import/elpa.scm
 guix/scripts/pull.scm
 guix/scripts/substitute.scm
@@ -23,6 +24,7 @@ guix/scripts/edit.scm
 guix/scripts/size.scm
 guix/scripts/graph.scm
 guix/scripts/challenge.scm
+guix/gnu-maintenance.scm
 guix/upstream.scm
 guix/ui.scm
 guix/http-client.scm

tests/guix-build.sh

@@ -167,6 +167,33 @@ guix build -e "(begin
 guix build -e '#~(mkdir #$output)' -d
 guix build -e '#~(mkdir #$output)' -d | grep 'gexp\.drv'
 
+# Building from a package file.
+cat > "$module_dir/package.scm"<<EOF
+(use-modules (gnu))
+(use-package-modules bootstrap)
+
+%bootstrap-guile
+EOF
+guix build --file="$module_dir/package.scm"
+
+# Building from a monadic procedure file.
+cat > "$module_dir/proc.scm"<<EOF
+(use-modules (guix gexp))
+(lambda ()
+  (gexp->derivation "test"
+                    (gexp (mkdir (ungexp output)))))
+EOF
+guix build --file="$module_dir/proc.scm" --dry-run
+
+# Building from a gexp file.
+cat > "$module_dir/gexp.scm"<<EOF
+(use-modules (guix gexp))
+
+(gexp (mkdir (ungexp output)))
+EOF
+guix build --file="$module_dir/gexp.scm" -d
+guix build --file="$module_dir/gexp.scm" -d | grep 'gexp\.drv'
+
 # Using 'GUIX_BUILD_OPTIONS'.
 GUIX_BUILD_OPTIONS="--dry-run"
 export GUIX_BUILD_OPTIONS

tests/guix-environment-container.sh

@@ -0,0 +1,76 @@
+# GNU Guix --- Functional package management for GNU
+# Copyright © 2015 David Thompson <davet@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 'guix environment'.
+#
+
+set -e
+
+guix environment --version
+
+tmpdir="t-guix-environment-$$"
+trap 'rm -r "$tmpdir"' EXIT
+
+mkdir "$tmpdir"
+
+# Make sure the exit value is preserved.
+if guix environment --container --ad-hoc --bootstrap guile-bootstrap \
+        -- guile -c '(exit 42)'
+then
+    false
+else
+    test $? = 42
+fi
+
+# Make sure that the right directories are mapped.
+mount_test_code="
+(use-modules (ice-9 rdelim)
+             (ice-9 match)
+             (srfi srfi-1))
+
+(define mappings
+  (filter-map (lambda (line)
+                (match (string-split line #\space)
+                  ;; Empty line.
+                  ((\"\") #f)
+                  ;; Ignore these types of file systems.
+                  ((_ _ (or \"tmpfs\" \"proc\" \"sysfs\" \"devtmpfs\"
+                            \"devpts\" \"cgroup\" \"mqueue\") _ _ _)
+                   #f)
+                  ((_ mount _ _ _ _)
+                   mount)))
+              (string-split (call-with-input-file \"/proc/mounts\" read-string)
+                            #\newline)))
+
+(for-each (lambda (mount)
+            (display mount)
+            (newline))
+          mappings)"
+
+guix environment --container --ad-hoc --bootstrap guile-bootstrap \
+     -- guile -c "$mount_test_code" > $tmpdir/mounts
+
+cat "$tmpdir/mounts"
+test `wc -l < $tmpdir/mounts` -eq 3
+
+grep -e "$PWD$" $tmpdir/mounts # current directory
+grep $(guix build guile-bootstrap) $tmpdir/mounts
+grep -e "$NIX_STORE_DIR/.*-bash" $tmpdir/mounts # bootstrap bash
+
+rm $tmpdir/mounts

tests/guix-environment.sh

@@ -97,4 +97,18 @@ then
 
     # Make sure the "debug" output is not listed.
     if grep -E "$make_boot0_debug" "$tmpdir/a"; then false; else true; fi
+
+    # Compute the build environment for the initial GNU Make, but add in the
+    # bootstrap Guile as an ad-hoc addition.
+    guix environment -e '(@@ (gnu packages commencement) gnu-make-boot0)' \
+         --ad-hoc guile-bootstrap --no-substitutes --search-paths \
+         --pure > "$tmpdir/a"
+
+    # Make sure the bootstrap binaries are all listed where they belong.
+    cat $tmpdir/a
+    grep -E '^export PATH=.*-bootstrap-binaries-0/bin'      "$tmpdir/a"
+    grep -E '^export PATH=.*-guile-bootstrap-2.0/bin'       "$tmpdir/a"
+    grep -E '^export CPATH=.*-gcc-bootstrap-0/include'      "$tmpdir/a"
+    grep -E '^export CPATH=.*-glibc-bootstrap-0/include'    "$tmpdir/a"
+    grep -E '^export LIBRARY_PATH=.*-glibc-bootstrap-0/lib' "$tmpdir/a"
 fi

tests/substitute.scm

@@ -167,8 +167,8 @@ (define-syntax-rule (with-narinfo narinfo body ...)
   (call-with-narinfo narinfo (lambda () body ...)))
 
 ;; Transmit these options to 'guix substitute'.
-(set! (@@ (guix scripts substitute) %cache-url)
+(set! (@@ (guix scripts substitute) %cache-urls)
-      (getenv "GUIX_BINARY_SUBSTITUTE_URL"))
+  (list (getenv "GUIX_BINARY_SUBSTITUTE_URL")))
 
 (test-equal "query narinfo without signature"
   ""                                              ; not substitutable