Merge branch 'master' into dbus-update

9 files changed, 571 insertions, 427 deletions

diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index a357cf8aa4..644ffe8d6e 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -185,8 +185,7 @@ options handled by 'set-build-options-from-command-line', and listed in
                      #: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)
-                                           %default-substitute-urls)
+                     #:substitute-urls (assoc-ref opts '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 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
   (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 @@ must be one of 'package', 'all', or 'transitive'~%")
          (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 @@ packages."
   (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)
-           ((? 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)))))
+         (object->argument (read/eval str)))
         (opt opt))
        opts))
 
@@ -501,6 +511,8 @@ arguments with packages that use the specified source."
              (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
diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm
index 19a9b061b8..4a0c865b07 100644
--- a/guix/scripts/challenge.scm
+++ b/guix/scripts/challenge.scm
@@ -125,10 +125,8 @@ taken since we do not import the archives."
                                               servers))
                        ;; No 'assert-valid-narinfo' on purpose.
                        (narinfos -> (fold (lambda (narinfo vhash)
-                                            (if narinfo
-                                                (vhash-cons (narinfo-path narinfo) narinfo
-                                                            vhash)
-                                                vhash))
+                                            (vhash-cons (narinfo-path narinfo) narinfo
+                                                        vhash))
                                           vlist-null
                                           remote)))
     (return (filter-map (lambda (item local)
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 2408420e18..188838574f 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -25,13 +25,19 @@
   #: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 @@ OUTPUT) tuples."
 (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 @@ COMMAND or an interactive shell in that environment.\n"))
       --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 @@ COMMAND or an interactive shell in that environment.\n"))
     (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 @@ COMMAND or an interactive shell in that environment.\n"))
                    (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 @@ COMMAND or an interactive shell in that environment.\n"))
                  (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 @@ COMMAND or an interactive shell in that environment.\n"))
             (_ 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
-                (('package . (? string? spec))
-                 (let-values (((package output)
-                               (specification->package+output spec)))
-                   `((package ,package ,output))))
-                (('expression . str)
-                 ;; Add all the outputs of the package STR evaluates to.
-                 (match (read/eval str)
-                   ((? package? package)
+  (compact
+   (append-map (match-lambda
+                 (('package mode (? string? spec))
+                  (let-values (((package output)
+                                (specification->package+output spec)))
+                    (list (list mode package output))))
+                 (('expression mode str)
+                  ;; Add all the outputs of the package STR evaluates to.
+                  (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))
-                         (package-outputs package)))))
-                (('load . file)
-                 ;; Add all the outputs of the package defined in FILE.
-                 (let ((package (load* file (make-user-module '()))))
-                   (map (lambda (output)
-                          `(package ,package ,output))
-                        (package-outputs package))))
-                (opt (list opt)))
-              opts))
+                           (list mode package output))
+                         (package-outputs package))))
+                 (_ '(#f)))
+               opts)))
 
 (define (build-inputs inputs opts)
   "Build the derivations in INPUTS, a list of (DERIVATION) or (DERIVATION
@@ -231,10 +293,135 @@ OUTPUT) tuples, using the build options in 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 @@ OUTPUT) tuples, using the build options in OPTS."
 ;; Entry point.
 (define (guix-environment . args)
   (with-error-handling
-    (let* ((opts     (parse-args args))
-           (pure?    (assoc-ref opts 'pure))
-           (ad-hoc?  (assoc-ref opts 'ad-hoc?))
-           (command  (assoc-ref opts 'exec))
-           (packages (pick-all (options/resolve-packages opts) 'package))
-           (inputs   (if ad-hoc?
-                         (append-map (match-lambda
-                                       ((package output)
-                                        (package+propagated-inputs package
-                                                                   output)))
-                                     packages)
-                         (append-map (compose bag-transitive-inputs
-                                              package->bag
-                                              first)
-                                     packages)))
-           (paths    (delete-duplicates
-                      (cons $PATH
-                            (append-map (match-lambda
-                                          ((label (? package? p) _ ...)
-                                           (package-native-search-paths p))
-                                          (_
-                                           '()))
-                                        inputs))
-                      eq?)))
+    (let* ((opts       (parse-args args))
+           (pure?      (assoc-ref opts 'pure))
+           (container? (assoc-ref opts 'container?))
+           (network?   (assoc-ref opts 'network?))
+           (bootstrap? (assoc-ref opts 'bootstrap?))
+           (system     (assoc-ref opts 'system))
+           (command    (assoc-ref opts 'exec))
+           (packages   (options/resolve-packages opts))
+           (mappings   (pick-all opts 'file-system-mapping))
+           (inputs     (delete-duplicates
+                        (append-map (match-lambda
+                                      (('ad-hoc-package package output)
+                                       (package+propagated-inputs package
+                                                                  output))
+                                      (('package package output)
+                                       (bag-transitive-inputs
+                                        (package->bag package))))
+                                    packages)))
+           (paths      (delete-duplicates
+                        (cons $PATH
+                              (append-map (match-lambda
+                                           ((label (? package? p) _ ...)
+                                            (package-native-search-paths p))
+                                           (_
+                                            '()))
+                                          inputs))
+                        eq?)))
       (with-store store
         (run-with-store store
-          (mlet %store-monad ((inputs (lower-inputs
-                                       (map (match-lambda
+          (mlet* %store-monad ((inputs (lower-inputs
+                                        (map (match-lambda
                                               ((label item)
                                                (list item))
                                               ((label item output)
                                                (list item output)))
-                                            inputs)
-                                       #:system (assoc-ref opts 'system))))
+                                             inputs)
+                                        #: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
-              ;; --search-paths.
-              (build-inputs inputs opts)
-              (cond ((assoc-ref opts 'dry-run?)
-                     (return #t))
-                    ((assoc-ref opts 'search-paths)
-                     (show-search-paths inputs paths pure?)
-                     (return #t))
-                    (else
-                     (create-environment inputs paths pure?)
-                     (return
-                      (exit
-                       (status:exit-val
-                        (apply system* command)))))))))))))
+              ;; First build the inputs.  This is necessary even for
+              ;; --search-paths.  Additionally, we might need to build bash
+              ;; for a container.
+              (build-inputs (if (derivation? bash)
+                                `((,bash "out") ,@inputs)
+                                inputs)
+                            opts)
+              (cond
+               ((assoc-ref opts 'dry-run?)
+                (return #t))
+               ((assoc-ref opts 'search-paths)
+                (show-search-paths inputs paths pure?)
+                (return #t))
+               (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?))))))))))))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index e0fe1ddb27..adbc4a1828 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -48,11 +48,7 @@
   #:use-module (gnu packages base)
   #:use-module (gnu packages guile)
   #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile))
-  #:export (switch-to-generation
-            switch-to-previous-generation
-            roll-back
-            delete-generation
-            delete-generations
+  #:export (delete-generations
             display-search-paths
             guix-package))
 
@@ -100,149 +96,12 @@ indirectly, or 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 @@ return the new list of manifest entries."
   (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 @@ doesn't need it."
 
   (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 @@ more information.~%"))
     ;; 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 @@ more information.~%"))
                                       (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 @@ more information.~%"))
         (('list-generations pattern)
          (define (list-generation number)
            (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)))
-             (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)))))
+             (display-generation profile number)
+             (display-profile-content profile number)
              (newline)))
 
          (cond ((not (file-exists? profile)) ; XXX: race condition
@@ -922,7 +736,7 @@ more information.~%"))
          #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 @@ more information.~%"))
            #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 @@ more information.~%"))
            #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)))
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 56ee9acb18..a4824e4fd7 100644
--- a/guix/scripts/pull.scm
+++ b/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)
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index 6f7ca4a41b..04f6b76edc 100644
--- a/guix/scripts/refresh.scm
+++ b/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 @@
                             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 @@ specified with `--select'.\n"))
   -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 @@ specified with `--select'.\n"))
           (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 @@ downloaded and authenticated; not updating~%")
   (define (options->updaters opts)
     ;; Return the list of updaters to use.
     (match (filter-map (match-lambda
-                         (('updater . name)
-                          (lookup-updater name))
+                         (('updaters . names)
+                          (map lookup-updater names))
                          (_ #f))
                        opts)
       (()
        ;; Use the default updaters.
        %updaters)
-      (lst
-       lst)))
+      (lists
+       (concatenate lists))))
 
   (define (keep-newest package lst)
     ;; If a newer version of PACKAGE is already in LST, return LST; otherwise
diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm
index 44ff92655b..e999cce1fd 100644
--- a/guix/scripts/size.scm
+++ b/guix/scripts/size.scm
@@ -252,8 +252,7 @@ Report the size of PACKAGE and its dependencies.\n"))
                   (show-version-and-exit "guix size")))))
 
 (define %default-options
-  `((system . ,(%current-system))
-    (substitute-urls . ,%default-substitute-urls)))
+  `((system . ,(%current-system))))
 
 
 ;;;
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 8967fa062e..964df9422c 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -72,6 +72,7 @@
             assert-valid-narinfo
 
             lookup-narinfos
+            lookup-narinfos/diverse
             read-narinfo
             write-narinfo
             guix-substitute))
@@ -474,12 +475,13 @@ may be #f, in which case it indicates that PATH is unavailable at CACHE-URL."
                             ".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
-to read the response body.  Return the list of results."
+response, passing it the request object, the response, a port from which to
+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 @@ to read the response body.  Return the list of results."
           ((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 @@ if file doesn't exist, and the narinfo otherwise."
                 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 @@ if file doesn't exist, and the narinfo otherwise."
          (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 @@ if file doesn't exist, and the narinfo otherwise."
            (cache-narinfo! url
                            (find (cut string-contains <> hash-part) paths)
                            #f)
-           (update-progress!))
-         #f)
+           (update-progress!)
+           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 @@ if file doesn't exist, and the narinfo otherwise."
            ((http)
             (let ((requests (map (cut narinfo-request url <>) paths)))
               (update-progress!)
-              (let ((result (http-multiple-get url requests
-                                               handle-narinfo-response)))
+              (let ((result (http-multiple-get url
+                                               handle-narinfo-response '()
+                                               requests)))
                 (newline (current-error-port))
                 result)))
            ((file #f)
@@ -596,7 +599,9 @@ information is available locally."
                          (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 @@ information is available locally."
         (let ((missing (fetch-narinfos cache missing)))
           (append cached (or missing '()))))))
 
-(define (lookup-narinfo cache path)
-  "Return the narinfo for PATH in CACHE, or #f when no substitute for PATH was
-found."
-  (match (lookup-narinfos cache (list path))
-    ((answer) answer)))
+(define (lookup-narinfos/diverse caches paths)
+  "Look up narinfos for PATHS on all of CACHES, a list of URLS, in that order.
+That is, when a cache lacks a narinfo, look it up in the next cache, and so
+on.  Return a list of narinfos for PATHS or a subset thereof."
+  (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 @@ expected by the daemon."
           (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.
-     (let ((substitutable (lookup-narinfos cache-url paths)))
+     ;; Return the subset of PATHS available in CACHE-URLS.
+     (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.
-     (let ((substitutable (lookup-narinfos cache-url paths)))
+     ;; Reply info about PATHS if it's in CACHE-URLS.
+     (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)
-  "Substitute STORE-ITEM (a store file name) from CACHE-URL, and write it to
+                               #:key cache-urls acl)
+  "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 @@ found."
         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)
-     url)
-    ((head tail ..1)
-     ;; Currently we don't handle multiple substitute URLs.
-     (warning (_ "these substitute URLs will not be used:~{ ~a~}~%")
-              tail)
-     head)
+    ((urls ...)
+     urls)
     (#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 @@ found."
   ;; 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)))
-    (case (uri-scheme uri)
-      ((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)))
+  (when (null? %cache-urls)
+    (exit 0))
 
   ;; Say hello (see above.)
   (newline)
@@ -929,13 +938,13 @@ substituter disabled~%")
             (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"))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index b5da57a9ce..d847c75444 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -25,6 +25,7 @@
   #: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 @@
   #: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
@@ -186,6 +189,39 @@ the ownership of '~a' may be incorrect!~%")
 
 
 ;;;
+;;; 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 @@ it atomically, and then run OS's activation script."
   "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")
-       (lambda (port)
-         (match (read port)
-           (('boot-parameters ('version 0)
-                              ('label label) ('root-device root)
-                              ('kernel linux)
-                              rest ...)
-            (menu-entry
-             (label (string-append label " (#"
-                                   (number->string number) ", "
-                                   (seconds->string time) ")"))
-             (linux linux)
-             (linux-arguments
-              (cons* (string-append "--root=" root)
-                     #~(string-append "--system=" #$system)
-                     #~(string-append "--load=" #$system "/boot")
-                     (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 ((file (string-append system "/parameters")))
+       (match (call-with-input-file file read-boot-parameters)
+         (($ <boot-parameters> label root kernel kernel-arguments)
+          (menu-entry
+           (label (string-append label " (#"
+                                 (number->string number) ", "
+                                 (seconds->string time) ")"))
+           (linux kernel)
+           (linux-arguments
+            (cons* (string-append "--root=" root)
+                   #~(string-append "--system=" #$system)
+                   #~(string-append "--load=" #$system "/boot")
+                   kernel-arguments))
+           (initrd #~(string-append #$system "/initrd"))))
+         (#f                                      ;invalid format
+          #f)))))
 
   (let* ((numbers (generation-numbers profile))
          (systems (map (cut generation-file-name profile <>)
@@ -327,6 +355,48 @@ list of services."
 
 
 ;;;
+;;; 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,7 +512,7 @@ building anything."
 ;;;
 
 (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"))
@@ -450,6 +520,8 @@ Build the operating system declared in FILE according to ACTION.\n"))
   (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 (_ "\
    vm               build a virtual machine image that shares the host's store\n"))
@@ -488,19 +560,6 @@ Build the operating system declared in FILE according to ACTION.\n"))
   (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 @@ Build the operating system declared in FILE according to ACTION.\n"))
 ;;; 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 @@ Build the operating system declared in FILE according to ACTION.\n"))
         (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 @@ Build the operating system declared in FILE according to ACTION.\n"))
                                          #:argument-handler
                                          parse-sub-command))
            (args     (option-arguments opts))
-           (file     (first args))
-           (action   (assoc-ref opts 'action))
-           (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))))
+           (command  (assoc-ref opts 'action)))
+      (process-command command args opts))))
 
 ;;; system.scm ends here