Merge branch 'master' into core-updates

11 files changed, 511 insertions, 281 deletions

diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm
index e9900689fa..eedebb4bac 100644
--- a/guix/scripts/authenticate.scm
+++ b/guix/scripts/authenticate.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>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -82,12 +82,6 @@ to stdout upon success."
         (leave (_ "error: corrupt signature data: ~a~%")
                (canonical-sexp->string signature)))))
 
-(define %default-port-conversion-strategy
-  ;; This fluid is in Guile > 2.0.5.
-  (if (defined? '%default-port-conversion-strategy)
-      (@ (guile) %default-port-conversion-strategy)
-      (make-fluid #f)))
-
 
 ;;;
 ;;; Entry point with 'openssl'-compatible interface.  We support this
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 370c2a37ff..2307f76b42 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -37,6 +37,7 @@
   #:autoload   (guix download) (download-to-store)
   #:export (%standard-build-options
             set-build-options-from-command-line
+            set-build-options-from-command-line*
             show-build-options-help
 
             guix-build))
@@ -139,6 +140,9 @@ options handled by 'set-build-options-from-command-line', and listed in
                      #:print-build-trace (assoc-ref opts 'print-build-trace?)
                      #:verbosity (assoc-ref opts 'verbosity)))
 
+(define set-build-options-from-command-line*
+  (store-lift set-build-options-from-command-line))
+
 (define %standard-build-options
   ;; List of standard command-line options for tools that build something.
   (list (option '(#\L "load-path") #t #f
@@ -228,6 +232,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
   (display (_ "
   -S, --source           build the packages' source derivations"))
   (display (_ "
+      --sources[=TYPE]   build source derivations; TYPE may optionally be one
+                         of \"package\", \"all\" (default), or \"transitive\""))
+  (display (_ "
   -s, --system=SYSTEM    attempt to build for SYSTEM--e.g., \"i686-linux\""))
   (display (_ "
       --target=TRIPLET   cross-build for TRIPLET--e.g., \"armel-linux-gnu\""))
@@ -262,10 +269,22 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
          (option '(#\V "version") #f #f
                  (lambda args
                    (show-version-and-exit "guix build")))
-
          (option '(#\S "source") #f #f
                  (lambda (opt name arg result)
-                   (alist-cons 'source? #t result)))
+                   (alist-cons 'source #t result)))
+         (option '("sources") #f #t
+                 (lambda (opt name arg result)
+                   (match arg
+                     ("package"
+                      (alist-cons 'source #t result))
+                     ((or "all" #f)
+                      (alist-cons 'source package-direct-sources result))
+                     ("transitive"
+                      (alist-cons 'source package-transitive-sources result))
+                     (else
+                      (leave (_ "invalid argument: '~a' option argument: ~a, ~
+must be one of 'package', 'all', or 'transitive'~%")
+                             name arg)))))
          (option '(#\s "system") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'system arg
@@ -308,28 +327,34 @@ build."
       (triplet
        (cut package-cross-derivation <> <> triplet <>))))
 
-  (define src?   (assoc-ref opts 'source?))
+  (define src    (assoc-ref opts 'source))
   (define sys    (assoc-ref opts 'system))
   (define graft? (assoc-ref opts 'graft?))
 
   (parameterize ((%graft? graft?))
     (let ((opts (options/with-source store
                                      (options/resolve-packages store opts))))
-      (filter-map (match-lambda
-                   (('argument . (? package? p))
-                    (if src?
+      (concatenate
+       (filter-map (match-lambda
+                    (('argument . (? package? p))
+                     (match src
+                       (#f
+                        (list (package->derivation store p sys)))
+                       (#t
                         (let ((s (package-source p)))
-                          (package-source-derivation store s))
-                        (package->derivation store p sys)))
-                   (('argument . (? derivation? drv))
-                    drv)
-                   (('argument . (? derivation-path? drv))
-                    (call-with-input-file drv read-derivation))
-                   (('argument . (? store-path?))
-                    ;; Nothing to do; maybe for --log-file.
-                    #f)
-                   (_ #f))
-                  opts))))
+                          (list (package-source-derivation store s))))
+                       (proc
+                        (map (cut package-source-derivation store <>)
+                             (proc p)))))
+                    (('argument . (? derivation? drv))
+                     (list drv))
+                    (('argument . (? derivation-path? drv))
+                     (list (call-with-input-file drv read-derivation)))
+                    (('argument . (? store-path?))
+                     ;; Nothing to do; maybe for --log-file.
+                     #f)
+                    (_ #f))
+                   opts)))))
 
 (define (options/resolve-packages store opts)
   "Return OPTS with package specification strings replaced by actual
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 80ae924410..42178091e6 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014 David Thompson <davet@gnu.org>
+;;; Copyright © 2014, 2015 David Thompson <davet@gnu.org>
+;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -22,9 +23,9 @@
   #:use-module (guix derivations)
   #:use-module (guix packages)
   #:use-module (guix profiles)
+  #:use-module (guix search-paths)
   #:use-module (guix utils)
   #:use-module (guix monads)
-  #:use-module (guix build utils)
   #:use-module (guix scripts build)
   #:use-module (gnu packages)
   #:use-module (ice-9 format)
@@ -35,32 +36,20 @@
   #:use-module (srfi srfi-98)
   #:export (guix-environment))
 
-(define (for-each-search-path proc inputs derivations pure?)
-  "Apply PROC for each native search path in INPUTS in addition to 'PATH'.
-Use the output paths of DERIVATIONS to build each search path.  When PURE? is
-#t, the existing search path value is ignored.  Otherwise, the existing search
-path value is appended."
-  (let ((paths (append-map (lambda (drv)
-                             (map (match-lambda
-                                   ((_ . output)
-                                    (derivation-output-path output)))
-                                  (derivation-outputs drv)))
-                           derivations)))
-    (for-each (match-lambda
-               (($ <search-path-specification>
-                   variable directories separator)
-                (let* ((current (getenv variable))
-                       (path    (search-path-as-list directories paths))
-                       (value   (list->search-path-as-string path separator)))
-                  (proc variable
-                        (if (and current (not pure?))
-                            (string-append value separator current)
-                            value)))))
-              (cons* (search-path-specification
-                      (variable "PATH")
-                      (files '("bin" "sbin")))
-                     (delete-duplicates
-                      (append-map package-native-search-paths inputs))))))
+(define (evaluate-input-search-paths inputs derivations)
+  "Evaluate the native search paths of INPUTS, a list of packages, of the
+outputs of DERIVATIONS, and return a list of search-path/value pairs."
+  (let ((directories (append-map (lambda (drv)
+                                   (map (match-lambda
+                                          ((_ . output)
+                                           (derivation-output-path output)))
+                                        (derivation-outputs drv)))
+                                 derivations))
+        (paths       (cons $PATH
+                           (delete-duplicates
+                            (append-map package-native-search-paths
+                                        inputs)))))
+    (evaluate-search-paths paths directories)))
 
 ;; Protect some env vars from purification.  Borrowed from nix-shell.
 (define %precious-variables
@@ -80,15 +69,26 @@ as 'HOME' and 'USER' are left untouched."
 PURE? is #t, unset the variables in the current environment.  Otherwise,
 augment existing enviroment variables with additional search paths."
   (when pure? (purify-environment))
-  (for-each-search-path setenv inputs derivations pure?))
+  (for-each (match-lambda
+              ((($ <search-path-specification> variable _ separator) . value)
+               (let ((current (getenv variable)))
+                 (setenv variable
+                         (if (and current (not pure?))
+                             (string-append value separator current)
+                             value)))))
+            (evaluate-input-search-paths inputs derivations)))
 
 (define (show-search-paths inputs derivations pure?)
   "Display the needed search paths to build an environment that contains the
 packages within INPUTS.  When PURE? is #t, do not augment existing environment
 variables with additional search paths."
-  (for-each-search-path (lambda (variable value)
-                          (format #t "export ~a=\"~a\"~%" variable value))
-                        inputs derivations pure?))
+  (for-each (match-lambda
+              ((search-path . value)
+               (display
+                (search-path-definition search-path value
+                                        #:kind (if pure? 'exact 'prefix)))
+               (newline)))
+            (evaluate-input-search-paths inputs derivations)))
 
 (define (show-help)
   (display (_ "Usage: guix environment [OPTION]... PACKAGE...
@@ -103,6 +103,9 @@ shell command in that environment.\n"))
   (display (_ "
   -E, --exec=COMMAND     execute COMMAND in new environment"))
   (display (_ "
+      --ad-hoc           include all specified packages in the environment instead
+                         of only their inputs"))
+  (display (_ "
       --pure             unset existing environment variables"))
   (display (_ "
       --search-paths     display needed environment variable definitions"))
@@ -147,6 +150,9 @@ shell command in that environment.\n"))
          (option '(#\e "expression") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'expression arg result)))
+         (option '("ad-hoc") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'ad-hoc? #t result)))
          (option '(#\n "dry-run") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'dry-run? #t result)))
@@ -191,12 +197,17 @@ packages."
   (delete-duplicates
    (append-map transitive-inputs packages)))
 
-;; TODO: Deduplicate these.
-(define show-what-to-build*
-  (store-lift show-what-to-build))
-
-(define set-build-options-from-command-line*
-  (store-lift set-build-options-from-command-line))
+(define (packages+propagated-inputs packages)
+  "Return a list containing PACKAGES plus all of their propagated inputs."
+  (delete-duplicates
+   (append packages
+           (map (match-lambda
+                  ((or (_ (? package? package))
+                       (_ (? package? package) _))
+                   package)
+                  (_ #f))
+                (append-map package-transitive-propagated-inputs
+                            packages)))))
 
 (define (build-inputs inputs opts)
   "Build the packages in INPUTS using the build options in OPTS."
@@ -225,9 +236,12 @@ packages."
       (let* ((opts  (parse-command-line args %options (list %default-options)
                                         #:argument-handler handle-argument))
              (pure? (assoc-ref opts 'pure))
+             (ad-hoc? (assoc-ref opts 'ad-hoc?))
              (command (assoc-ref opts 'exec))
-             (inputs (packages->transitive-inputs
-                      (pick-all (options/resolve-packages opts) 'package)))
+             (packages (pick-all (options/resolve-packages opts) 'package))
+             (inputs (if ad-hoc?
+                         (packages+propagated-inputs packages)
+                         (packages->transitive-inputs packages)))
              (drvs (run-with-store store
                      (mbegin %store-monad
                        (set-guile-for-build (default-guile))
diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm
index ed16cab8f9..6403893687 100644
--- a/guix/scripts/gc.scm
+++ b/guix/scripts/gc.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -44,6 +44,8 @@ Invoke the garbage collector.\n"))
   (display (_ "
   -d, --delete           attempt to delete PATHS"))
   (display (_ "
+      --optimize         optimize the store by deduplicating identical files"))
+  (display (_ "
       --list-dead        list dead paths"))
   (display (_ "
       --list-live        list live paths"))
@@ -56,6 +58,11 @@ Invoke the garbage collector.\n"))
       --referrers        list the referrers of PATHS"))
   (newline)
   (display (_ "
+      --verify[=OPTS]    verify the integrity of the store; OPTS is a
+                         comma-separated combination of 'repair' and
+                         'contents'"))
+  (newline)
+  (display (_ "
   -h, --help             display this help and exit"))
   (display (_ "
   -V, --version          display version information and exit"))
@@ -88,6 +95,21 @@ Invoke the garbage collector.\n"))
                 (lambda (opt name arg result)
                   (alist-cons 'action 'delete
                               (alist-delete 'action result))))
+        (option '("optimize") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'action 'optimize
+                              (alist-delete 'action result))))
+        (option '("verify") #f #t
+                (let ((not-comma (char-set-complement (char-set #\,))))
+                  (lambda (opt name arg result)
+                    (let ((options (if arg
+                                       (map string->symbol
+                                            (string-tokenize arg not-comma))
+                                       '())))
+                      (alist-cons 'action 'verify
+                                  (alist-cons 'verify-options options
+                                              (alist-delete 'action
+                                                            result)))))))
         (option '("list-dead") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'action 'list-dead
@@ -162,13 +184,21 @@ Invoke the garbage collector.\n"))
                (collect-garbage store min-freed)
                (collect-garbage store))))
         ((delete)
-         (delete-paths store paths))
+         (delete-paths store (map direct-store-path paths)))
         ((list-references)
          (list-relatives references))
         ((list-requisites)
          (list-relatives requisites))
         ((list-referrers)
          (list-relatives referrers))
+        ((optimize)
+         (optimize-store store))
+        ((verify)
+         (let ((options (assoc-ref opts 'verify-options)))
+           (exit
+            (verify-store store
+                          #:check-contents? (memq 'contents options)
+                          #:repair? (memq 'repair options)))))
         ((list-dead)
          (for-each (cut simple-format #t "~a~%" <>)
                    (dead-paths store)))
diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm
index 06b4c17573..45ce092f13 100644
--- a/guix/scripts/import.scm
+++ b/guix/scripts/import.scm
@@ -86,6 +86,7 @@ rather than \\n."
 Run IMPORTER with ARGS.\n"))
   (newline)
   (display (_ "IMPORTER must be one of the importers listed below:\n"))
+  (newline)
   (format #t "~{   ~a~%~}" importers)
   (display (_ "
   -h, --help             display this help and exit"))
diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm
index f7c18cd3bf..e5e9b0ed64 100644
--- a/guix/scripts/import/hackage.scm
+++ b/guix/scripts/import/hackage.scm
@@ -34,7 +34,9 @@
 ;;;
 
 (define %default-options
-  '((include-test-dependencies? . #t)))
+  '((include-test-dependencies? . #t)
+    (read-from-stdin? . #f)
+    ('cabal-environment . '())))
 
 (define (show-help)
   (display (_ "Usage: guix import hackage PACKAGE-NAME
@@ -45,8 +47,13 @@ package will be generated.  If no version suffix is pecified, then the
 generated package definition will correspond to the latest available
 version.\n"))
   (display (_ "
+  -e ALIST, --cabal-environment=ALIST   
+                               specify environment for Cabal evaluation"))
+  (display (_ "
   -h, --help                   display this help and exit"))
   (display (_ "
+  -s, --stdin                  read from standard input"))
+  (display (_ "
   -t, --no-test-dependencies   don't include test only dependencies"))
   (display (_ "
   -V, --version                display version information and exit"))
@@ -67,6 +74,16 @@ version.\n"))
                    (alist-cons 'include-test-dependencies? #f
                                (alist-delete 'include-test-dependencies?
                                              result))))
+         (option '(#\s "stdin") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'read-from-stdin? #t
+                               (alist-delete 'read-from-stdin?
+                                             result))))
+         (option '(#\e "cabal-environment") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'cabal-environment (read/eval arg)
+                               (alist-delete 'cabal-environment
+                                             result))))
          %standard-import-options))
 
 
@@ -84,23 +101,42 @@ version.\n"))
                   (alist-cons 'argument arg result))
                 %default-options))
 
+  (define (run-importer package-name opts error-fn)
+    (let ((sexp (hackage->guix-package
+                 package-name
+                 #:include-test-dependencies?
+                 (assoc-ref opts 'include-test-dependencies?)
+                 #:port (if (assoc-ref opts 'read-from-stdin?)
+                            (current-input-port)
+                            #f)
+                 #:cabal-environment
+                 (assoc-ref opts 'cabal-environment))))
+      (unless sexp (error-fn))
+      sexp))
+
   (let* ((opts (parse-options))
          (args (filter-map (match-lambda
                             (('argument . value)
                              value)
                             (_ #f))
                            (reverse opts))))
-    (match args
-      ((package-name)
-       (let ((sexp (hackage->guix-package
-                    package-name
-                    #:include-test-dependencies?
-                    (assoc-ref opts 'include-test-dependencies?))))
-         (unless sexp
-           (leave (_ "failed to download cabal file for package '~a'~%")
-                  package-name))
-         sexp))
-      (()
-       (leave (_ "too few arguments~%")))
-      ((many ...)
-       (leave (_ "too many arguments~%"))))))
+    (if (assoc-ref opts 'read-from-stdin?)
+        (match args
+          (()
+           (run-importer "stdin" opts
+                         (lambda ()
+                           (leave (_ "failed to import cabal file from '~a'~%"))
+                           package-name)))
+          ((many ...)
+           (leave (_ "too many arguments~%"))))
+        (match args
+          ((package-name)
+           (run-importer package-name opts
+                         (lambda ()
+                           (leave
+                            (_ "failed to download cabal file for package '~a'~%"))
+                           package-name)))
+          (()
+           (leave (_ "too few arguments~%")))
+          ((many ...)
+           (leave (_ "too many arguments~%")))))))
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index cced1bda66..3740b71d5e 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -28,6 +28,7 @@
   #:use-module (guix ui)
   #:use-module (guix utils)
   #:use-module (guix gnu-maintenance)
+  #:use-module (guix monads)
   #:use-module (gnu packages)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
@@ -41,6 +42,7 @@
   #:use-module (web request)
   #:use-module (web response)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-6)                      ;Unicode string ports
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
@@ -71,6 +73,25 @@
             (package-full-name package)
             message)))
 
+(define (call-with-accumulated-warnings thunk)
+  "Call THUNK, accumulating any warnings in the current state, using the state
+monad."
+  (let ((port (open-output-string)))
+    (mlet %state-monad ((state      (current-state))
+                        (result ->  (parameterize ((guix-warning-port port))
+                                      (thunk)))
+                        (warning -> (get-output-string port)))
+      (mbegin %state-monad
+        (munless (string=? "" warning)
+          (set-current-state (cons warning state)))
+        (return result)))))
+
+(define-syntax-rule (with-accumulated-warnings exp ...)
+  "Evaluate EXP and accumulate warnings in the state monad."
+  (call-with-accumulated-warnings
+   (lambda ()
+     exp ...)))
+
 
 ;;;
 ;;; Checkers
@@ -287,20 +308,22 @@ response from URI, and additional details, such as the actual HTTP response."
        (values 'unknown-protocol #f)))))
 
 (define (validate-uri uri package field)
-  "Return #t if the given URI can be reached, otherwise emit a
+  "Return #t if the given URI can be reached, otherwise return #f and emit a
 warning for PACKAGE mentionning the FIELD."
   (let-values (((status argument)
                 (probe-uri uri)))
     (case status
       ((http-response)
        (or (= 200 (response-code argument))
-           (emit-warning package
-                         (format #f
-                                 (_ "URI ~a not reachable: ~a (~s)")
-                                 (uri->string uri)
-                                 (response-code argument)
-                                 (response-reason-phrase argument))
-                         field)))
+           (begin
+             (emit-warning package
+                           (format #f
+                                   (_ "URI ~a not reachable: ~a (~s)")
+                                   (uri->string uri)
+                                   (response-code argument)
+                                   (response-reason-phrase argument))
+                           field)
+             #f)))
       ((ftp-response)
        (match argument
          (('ok) #t)
@@ -309,7 +332,8 @@ warning for PACKAGE mentionning the FIELD."
                         (format #f
                                 (_ "URI ~a not reachable: ~a (~s)")
                                 (uri->string uri)
-                                code (string-trim-both message))))))
+                                code (string-trim-both message)))
+          #f)))
       ((getaddrinfo-error)
        (emit-warning package
                      (format #f
@@ -432,6 +456,16 @@ descriptions maintained upstream."
 (define (check-source package)
   "Emit a warning if PACKAGE has an invalid 'source' field, or if that
 'source' is not reachable."
+  (define (try-uris uris)
+    (run-with-state
+        (anym %state-monad
+              (lambda (uri)
+                (with-accumulated-warnings
+                 (validate-uri uri package 'source)))
+              (append-map (cut maybe-expand-mirrors <> %mirrors)
+                          uris))
+      '()))
+
   (let ((origin (package-source package)))
     (when (and origin
                (eqv? (origin-method origin) url-fetch))
@@ -439,10 +473,24 @@ descriptions maintained upstream."
              (uris (if (list? strings)
                        (map string->uri strings)
                        (list (string->uri strings)))))
+
         ;; Just make sure that at least one of the URIs is valid.
-        (any (cut validate-uri <> package 'source)
-             (append-map (cut maybe-expand-mirrors <> %mirrors)
-                         uris))))))
+        (call-with-values
+            (lambda () (try-uris uris))
+          (lambda (success? warnings)
+            ;; When everything fails, report all of WARNINGS, otherwise don't
+            ;; report anything.
+            ;;
+            ;; XXX: Ideally we'd still allow warnings to be raised if *some*
+            ;; URIs are unreachable, but distinguish that from the error case
+            ;; where *all* the URIs are unreachable.
+            (unless success?
+              (emit-warning package
+                            (_ "all the source URIs are unreachable:")
+                            'source)
+              (for-each (lambda (warning)
+                          (display warning (guix-warning-port)))
+                        (reverse warnings)))))))))
 
 (define (check-derivation package)
   "Emit a warning if we fail to compile PACKAGE to a derivation."
@@ -527,7 +575,8 @@ descriptions maintained upstream."
 
 (define (show-help)
   (display (_ "Usage: guix lint [OPTION]... [PACKAGE]...
-Run a set of checkers on the specified package; if none is specified, run the checkers on all packages.\n"))
+Run a set of checkers on the specified package; if none is specified,
+run the checkers on all packages.\n"))
   (display (_ "
   -c, --checkers=CHECKER1,CHECKER2...
                          only run the specificed checkers"))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 1e724b4e19..d9f38fb8bc 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -25,6 +25,7 @@
   #:use-module (guix derivations)
   #:use-module (guix packages)
   #:use-module (guix profiles)
+  #:use-module (guix search-paths)
   #:use-module (guix monads)
   #:use-module (guix utils)
   #:use-module (guix config)
@@ -52,6 +53,7 @@
             roll-back
             delete-generation
             delete-generations
+            display-search-paths
             guix-package))
 
 (define %store
@@ -89,6 +91,15 @@ return PROFILE unchanged.  The goal is to treat '-p ~/.guix-profile' as if
       %current-profile
       profile))
 
+(define (user-friendly-profile profile)
+  "Return either ~/.guix-profile if that's what PROFILE refers to, directly or
+indirectly, or PROFILE."
+  (if (and %user-profile-directory
+           (false-if-exception
+            (string=? (readlink %user-profile-directory) 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
@@ -365,77 +376,35 @@ an output path different than CURRENT-PATH."
 ;;; Search paths.
 ;;;
 
-(define-syntax-rule (with-null-error-port exp)
-  "Evaluate EXP with the error port pointing to the bit bucket."
-  (with-error-to-port (%make-void-port "w")
-    (lambda () exp)))
-
 (define* (search-path-environment-variables entries profile
-                                            #:optional (getenv getenv))
+                                            #:optional (getenv getenv)
+                                            #:key (kind 'exact))
   "Return environment variable definitions that may be needed for the use of
 ENTRIES, a list of manifest entries, in PROFILE.  Use GETENV to determine the
-current settings and report only settings not already effective."
-
-  ;; Prefer ~/.guix-profile to the real profile directory name.
-  (let ((profile (if (and %user-profile-directory
-                          (false-if-exception
-                           (string=? (readlink %user-profile-directory)
-                                     profile)))
-                     %user-profile-directory
-                     profile)))
-
-    ;; The search path info is not stored in the manifest.  Thus, we infer the
-    ;; search paths from same-named packages found in the distro.
-
-    (define manifest-entry->package
-      (match-lambda
-       (($ <manifest-entry> name version)
-        ;; Use 'find-best-packages-by-name' and not 'find-packages-by-name';
-        ;; the former traverses the module tree only once and then allows for
-        ;; efficient access via a vhash.
-        (match (find-best-packages-by-name name version)
-          ((p _ ...) p)
-          (_
-           (match (find-best-packages-by-name name #f)
-             ((p _ ...) p)
-             (_ #f)))))))
-
-    (define search-path-definition
-      (match-lambda
-       (($ <search-path-specification> variable files separator
-                                       type pattern)
-        (let* ((values (or (and=> (getenv variable)
-                                  (cut string-tokenize* <> separator))
-                           '()))
-               ;; Add a trailing slash to force symlinks to be treated as
-               ;; directories when 'find-files' traverses them.
-               (files  (if pattern
-                           (map (cut string-append <> "/") files)
-                           files))
-
-               ;; XXX: Silence 'find-files' when it stumbles upon non-existent
-               ;; directories (see
-               ;; <http://lists.gnu.org/archive/html/guix-devel/2015-01/msg00269.html>.)
-               (path   (with-null-error-port
-                        (search-path-as-list files (list profile)
-                                             #:type type
-                                             #:pattern pattern))))
-          (if (every (cut member <> values) path)
-              #f
-              (format #f "export ~a=\"~a\""
-                      variable
-                      (string-join path separator)))))))
-
-    (let* ((packages     (filter-map manifest-entry->package entries))
-           (search-paths (delete-duplicates
-                          (append-map package-native-search-paths
-                                      packages))))
-      (filter-map search-path-definition search-paths))))
-
-(define (display-search-paths entries profile)
+current settings and report only settings not already effective.  KIND
+must be one of 'exact, 'prefix, or 'suffix, depending on the kind of search
+path definition to be returned."
+  (let ((search-paths (delete-duplicates
+                       (cons $PATH
+                             (append-map manifest-entry-search-paths
+                                         entries)))))
+    (filter-map (match-lambda
+                  ((spec . value)
+                   (let ((variable (search-path-specification-variable spec))
+                         (sep      (search-path-specification-separator spec)))
+                     (environment-variable-definition variable value
+                                                      #:separator sep
+                                                      #:kind kind))))
+                (evaluate-search-paths search-paths (list profile)
+                                       getenv))))
+
+(define* (display-search-paths entries profile
+                               #:key (kind 'exact))
   "Display the search path environment variables that may need to be set for
 ENTRIES, a list of manifest entries, in the context of PROFILE."
-  (let ((settings (search-path-environment-variables entries profile)))
+  (let* ((profile  (user-friendly-profile profile))
+         (settings (search-path-environment-variables entries profile
+                                                      #:kind kind)))
     (unless (null? settings)
       (format #t (_ "The following environment variable definitions may be needed:~%"))
       (format #t "~{   ~a~%~}" settings))))
@@ -453,23 +422,29 @@ ENTRIES, a list of manifest entries, in the context of PROFILE."
     (substitutes? . #t)))
 
 (define (show-help)
-  (display (_ "Usage: guix package [OPTION]... PACKAGES...
-Install, remove, or upgrade PACKAGES in a single transaction.\n"))
+  (display (_ "Usage: guix package [OPTION]...
+Install, remove, or upgrade packages in a single transaction.\n"))
   (display (_ "
-  -i, --install=PACKAGE  install PACKAGE"))
+  -i, --install PACKAGE ...
+                         install PACKAGEs"))
   (display (_ "
   -e, --install-from-expression=EXP
                          install the package EXP evaluates to"))
   (display (_ "
-  -r, --remove=PACKAGE   remove PACKAGE"))
+  -r, --remove PACKAGE ...
+                         remove PACKAGEs"))
   (display (_ "
   -u, --upgrade[=REGEXP] upgrade all the installed packages matching REGEXP"))
   (display (_ "
+  -m, --manifest=FILE    create a new profile generation with the manifest
+                         from FILE"))
+  (display (_ "
       --do-not-upgrade[=REGEXP] do not upgrade any packages matching REGEXP"))
   (display (_ "
       --roll-back        roll back to the previous generation"))
   (display (_ "
-      --search-paths     display needed environment variable definitions"))
+      --search-paths[=KIND]
+                         display needed environment variable definitions"))
   (display (_ "
   -l, --list-generations[=PATTERN]
                          list generations matching PATTERN"))
@@ -496,7 +471,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
   -A, --list-available[=REGEXP]
                          list available packages matching REGEXP"))
   (display (_ "
-  --show=PACKAGE         show details about PACKAGE"))
+      --show=PACKAGE     show details about PACKAGE"))
   (newline)
   (show-build-options-help)
   (newline)
@@ -556,6 +531,10 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
                  (lambda (opt name arg result arg-handler)
                    (values (alist-cons 'roll-back? #t result)
                            #f)))
+         (option '(#\m "manifest") #t #f
+                 (lambda (opt name arg result arg-handler)
+                   (values (alist-cons 'manifest arg result)
+                           arg-handler)))
          (option '(#\l "list-generations") #f #t
                  (lambda (opt name arg result arg-handler)
                    (values (cons `(query list-generations ,(or arg ""))
@@ -570,10 +549,20 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
                  (lambda (opt name arg result arg-handler)
                    (values (alist-cons 'switch-generation arg result)
                            #f)))
-         (option '("search-paths") #f #f
+         (option '("search-paths") #f #t
                  (lambda (opt name arg result arg-handler)
-                   (values (cons `(query search-paths) result)
-                           #f)))
+                   (let ((kind (match arg
+                                 ((or "exact" "prefix" "suffix")
+                                  (string->symbol arg))
+                                 (#f
+                                  'exact)
+                                 (x
+                                  (leave (_ "~a: unsupported \
+kind of search path~%")
+                                         x)))))
+                     (values (cons `(query search-paths ,kind)
+                                   result)
+                             #f))))
          (option '(#\p "profile") #t #f
                  (lambda (opt name arg result arg-handler)
                    (values (alist-cons 'profile (canonicalize-profile arg)
@@ -822,6 +811,50 @@ more information.~%"))
     (define dry-run? (assoc-ref opts 'dry-run?))
     (define profile  (assoc-ref opts 'profile))
 
+    (define (build-and-use-profile manifest)
+      (let* ((bootstrap?  (assoc-ref opts 'bootstrap?)))
+
+        (when (equal? profile %current-profile)
+          (ensure-default-profile))
+
+        (let* ((prof-drv (run-with-store (%store)
+                           (profile-derivation
+                            manifest
+                            #:hooks (if bootstrap?
+                                        '()
+                                        %default-profile-hooks))))
+               (prof     (derivation->output-path prof-drv)))
+          (show-what-to-build (%store) (list prof-drv)
+                              #:use-substitutes?
+                              (assoc-ref opts 'substitutes?)
+                              #:dry-run? dry-run?)
+
+          (cond
+           (dry-run? #t)
+           ((and (file-exists? profile)
+                 (and=> (readlink* profile) (cut string=? prof <>)))
+            (format (current-error-port) (_ "nothing to be done~%")))
+           (else
+            (let* ((number (generation-number profile))
+
+                   ;; Always use NUMBER + 1 for the new profile,
+                   ;; possibly overwriting a "previous future
+                   ;; generation".
+                   (name   (generation-file-name profile
+                                                 (+ 1 number))))
+              (and (build-derivations (%store) (list prof-drv))
+                   (let* ((entries (manifest-entries manifest))
+                          (count   (length entries)))
+                     (switch-symlinks name prof)
+                     (switch-symlinks profile name)
+                     (unless (string=? profile %current-profile)
+                       (register-gc-root (%store) name))
+                     (format #t (N_ "~a package in profile~%"
+                                    "~a packages in profile~%"
+                                    count)
+                             count)
+                     (display-search-paths entries profile)))))))))
+
     ;; First roll back if asked to.
     (cond ((and (assoc-ref opts 'roll-back?)
                 (not dry-run?))
@@ -856,60 +889,30 @@ more information.~%"))
                (alist-delete 'delete-generations opts)))
              (_ #f))
             opts))
+          ((assoc-ref opts 'manifest)
+           (let* ((file-name   (assoc-ref opts 'manifest))
+                  (user-module (make-user-module '((guix profiles)
+                                                   (gnu))))
+                  (manifest    (load* file-name user-module)))
+             (if (assoc-ref opts 'dry-run?)
+                 (format #t (_ "would install new manifest from '~a' with ~d entries~%")
+                         file-name (length (manifest-entries manifest)))
+                 (format #t (_ "installing new manifest from '~a' with ~d entries~%")
+                         file-name (length (manifest-entries manifest))))
+             (build-and-use-profile manifest)))
           (else
            (let* ((manifest    (profile-manifest profile))
                   (install     (options->installable opts manifest))
                   (remove      (options->removable opts manifest))
-                  (bootstrap?  (assoc-ref opts 'bootstrap?))
                   (transaction (manifest-transaction (install install)
                                                      (remove remove)))
                   (new         (manifest-perform-transaction
                                 manifest transaction)))
 
-             (when (equal? profile %current-profile)
-               (ensure-default-profile))
-
              (unless (and (null? install) (null? remove))
-               (let* ((prof-drv (run-with-store (%store)
-                                  (profile-derivation
-                                   new
-                                   #:hooks (if bootstrap?
-                                               '()
-                                               %default-profile-hooks))))
-                      (prof     (derivation->output-path prof-drv)))
-                 (show-manifest-transaction (%store) manifest transaction
-                                            #:dry-run? dry-run?)
-                 (show-what-to-build (%store) (list prof-drv)
-                                     #:use-substitutes?
-                                     (assoc-ref opts 'substitutes?)
-                                     #:dry-run? dry-run?)
-
-                 (cond
-                  (dry-run? #t)
-                  ((and (file-exists? profile)
-                        (and=> (readlink* profile) (cut string=? prof <>)))
-                   (format (current-error-port) (_ "nothing to be done~%")))
-                  (else
-                   (let* ((number (generation-number profile))
-
-                          ;; Always use NUMBER + 1 for the new profile,
-                          ;; possibly overwriting a "previous future
-                          ;; generation".
-                          (name   (generation-file-name profile
-                                                        (+ 1 number))))
-                     (and (build-derivations (%store) (list prof-drv))
-                          (let* ((entries (manifest-entries new))
-                                 (count   (length entries)))
-                            (switch-symlinks name prof)
-                            (switch-symlinks profile name)
-                            (unless (string=? profile %current-profile)
-                              (register-gc-root (%store) name))
-                            (format #t (N_ "~a package in profile~%"
-                                           "~a packages in profile~%"
-                                           count)
-                                    count)
-                            (display-search-paths entries
-                                                  profile))))))))))))
+               (show-manifest-transaction (%store) manifest transaction
+                                          #:dry-run? dry-run?)
+               (build-and-use-profile new))))))
 
   (define (process-query opts)
     ;; Process any query specified by OPTS.  Return #t when a query was
@@ -1014,11 +1017,13 @@ more information.~%"))
                       (find-packages-by-name name version)))
            #t))
 
-        (('search-paths)
+        (('search-paths kind)
          (let* ((manifest (profile-manifest profile))
                 (entries  (manifest-entries manifest))
+                (profile  (user-friendly-profile profile))
                 (settings (search-path-environment-variables entries profile
-                                                             (const #f))))
+                                                             (const #f)
+                                                             #:kind kind)))
            (format #t "~{~a~%~}" settings)
            #t))
 
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index c7c66fefbe..7bad2619b9 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -51,6 +51,10 @@ Publish ~a over HTTP.\n") %store-directory)
   (display (_ "
   -p, --port=PORT        listen on PORT"))
   (display (_ "
+      --listen=HOST      listen on the network interface for HOST"))
+  (display (_ "
+  -u, --user=USER        change privileges to USER as soon as possible"))
+  (display (_ "
   -r, --repl[=PORT]      spawn REPL server on PORT"))
   (newline)
   (display (_ "
@@ -60,6 +64,15 @@ Publish ~a over HTTP.\n") %store-directory)
   (newline)
   (show-bug-report-information))
 
+(define (getaddrinfo* host)
+  "Like 'getaddrinfo', but properly report errors."
+  (catch 'getaddrinfo-error
+    (lambda ()
+      (getaddrinfo host))
+    (lambda (key error)
+      (leave (_ "lookup of host '~a' failed: ~a~%")
+             host (gai-strerror error)))))
+
 (define %options
   (list (option '(#\h "help") #f #f
                 (lambda _
@@ -68,9 +81,21 @@ Publish ~a over HTTP.\n") %store-directory)
         (option '(#\V "version") #f #f
                 (lambda _
                   (show-version-and-exit "guix publish")))
+        (option '(#\u "user") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'user arg result)))
         (option '(#\p "port") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'port (string->number* arg) result)))
+        (option '("listen") #t #f
+                (lambda (opt name arg result)
+                  (match (getaddrinfo* arg)
+                    ((info _ ...)
+                     (alist-cons 'address (addrinfo:addr info)
+                                 result))
+                    (()
+                     (leave (_ "lookup of host '~a' returned nothing")
+                            name)))))
         (option '(#\r "repl") #f #t
                 (lambda (opt name arg result)
                   ;; If port unspecified, use default Guile REPL port.
@@ -78,7 +103,8 @@ Publish ~a over HTTP.\n") %store-directory)
                     (alist-cons 'repl (or port 37146) result))))))
 
 (define %default-options
-  '((port . 8080)
+  `((port . 8080)
+    (address . ,(make-socket-address AF_INET INADDR_ANY 0))
     (repl . #f)))
 
 (define (lazy-read-file-sexp file)
@@ -220,24 +246,69 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
           (_ (not-found request)))
         (not-found request))))
 
-(define (run-publish-server port store)
+(define (run-publish-server socket store)
   (run-server (make-request-handler store)
               'http
-              `(#:addr ,INADDR_ANY
-                #:port ,port)))
+              `(#:socket ,socket)))
+
+(define (open-server-socket address)
+  "Return a TCP socket bound to ADDRESS, a socket address."
+  (let ((sock (socket (sockaddr:fam address) SOCK_STREAM 0)))
+    (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
+    (bind sock address)
+    sock))
+
+(define (gather-user-privileges user)
+  "Switch to the identity of USER, a user name."
+  (catch 'misc-error
+    (lambda ()
+      (let ((user (getpw user)))
+        (setgroups #())
+        (setgid (passwd:gid user))
+        (setuid (passwd:uid user))))
+    (lambda (key proc message args . rest)
+      (leave (_ "user '~a' not found: ~a~%")
+             user (apply format #f message args)))))
+
+
+;;;
+;;; Entry point.
+;;;
 
 (define (guix-publish . args)
   (with-error-handling
-    (let* ((opts (args-fold* args %options
-                             (lambda (opt name arg result)
-                               (leave (_ "~A: unrecognized option~%") name))
-                             (lambda (arg result)
-                               (leave (_ "~A: extraneuous argument~%") arg))
-                             %default-options))
-           (port (assoc-ref opts 'port))
+    (let* ((opts    (args-fold* args %options
+                                (lambda (opt name arg result)
+                                  (leave (_ "~A: unrecognized option~%") name))
+                                (lambda (arg result)
+                                  (leave (_ "~A: extraneuous argument~%") arg))
+                                %default-options))
+           (user    (assoc-ref opts 'user))
+           (port    (assoc-ref opts 'port))
+           (address (let ((addr (assoc-ref opts 'address)))
+                      (make-socket-address (sockaddr:fam addr)
+                                           (sockaddr:addr addr)
+                                           port)))
+           (socket  (open-server-socket address))
            (repl-port (assoc-ref opts 'repl)))
-      (format #t (_ "publishing ~a on port ~d~%") %store-directory port)
+      ;; Read the key right away so that (1) we fail early on if we can't
+      ;; access them, and (2) we can then drop privileges.
+      (force %private-key)
+      (force %public-key)
+
+      (when user
+        ;; Now that we've read the key material and opened the socket, we can
+        ;; drop privileges.
+        (gather-user-privileges user))
+
+      (when (zero? (getuid))
+        (warning (_ "server running as root; \
+consider using the '--user' option!~%")))
+      (format #t (_ "publishing ~a on ~a, port ~d~%")
+              %store-directory
+              (inet-ntop (sockaddr:fam address) (sockaddr:addr address))
+              (sockaddr:port address))
       (when repl-port
         (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port)))
       (with-store store
-        (run-publish-server (assoc-ref opts 'port) store)))))
+        (run-publish-server socket store)))))
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index b9983c5b9c..8b4fa36d2a 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -84,8 +84,10 @@ disabled!~%"))
 
 (define %narinfo-ttl
   ;; Number of seconds during which cached narinfo lookups are considered
-  ;; valid.
-  (* 24 3600))
+  ;; valid.  This is a reasonable default value (corresponds to the TTL for
+  ;; nginx's .nar cache on hydra.gnu.org) but we'd rather want publishers to
+  ;; state what their TTL is in /nix-cache-info.  (XXX)
+  (* 36 3600))
 
 (define %narinfo-negative-ttl
   ;; Likewise, but for negative lookups---i.e., cached lookup failures.
@@ -155,15 +157,12 @@ to the caller without emitting an error message."
                       (leave (_ "download from '~a' failed: ~a, ~s~%")
                              (uri->string (http-get-error-uri c))
                              code (http-get-error-reason c))))))
-       ;; On Guile 2.0.5, `http-fetch' fetches the whole thing at once.  So
-       ;; honor TIMEOUT? to disable the timeout when fetching a nar.
-       ;;
        ;; Test this with:
        ;;   sudo tc qdisc add dev eth0 root netem delay 1500ms
        ;; and then cancel with:
        ;;   sudo tc qdisc del dev eth0 root
        (let ((port #f))
-         (with-timeout (if (or timeout? (guile-version>? "2.0.5"))
+         (with-timeout (if timeout?
                            %fetch-timeout
                            0)
            (begin
@@ -180,7 +179,9 @@ to the caller without emitting an error message."
                  (close-port port))))
            (begin
              (when (or (not port) (port-closed? port))
-               (set! port (open-socket-for-uri uri #:buffered? buffered?)))
+               (set! port (open-socket-for-uri uri))
+               (unless buffered?
+                 (setvbuf port _IONBF)))
              (http-fetch uri #:text? #f #:port port))))))))
 
 (define-record-type <cache>
@@ -645,17 +646,9 @@ PORT.  REPORT-PROGRESS is a two-argument procedure such as that returned by
       ;; XXX: We're not in control, so we always return anyway.
       n))
 
-  ;; Since `http-fetch' in Guile 2.0.5 returns all the data once it's done,
-  ;; don't pretend to report any progress in that case.
-  (if (guile-version>? "2.0.5")
-      (make-custom-binary-input-port "progress-port-proc"
-                                     read! #f #f
-                                     (cut close-port port))
-      (begin
-        (format (current-error-port) (_ "Downloading, please wait...~%"))
-        (format (current-error-port)
-                (_ "(Please consider upgrading Guile to get proper progress report.)~%"))
-        port)))
+  (make-custom-binary-input-port "progress-port-proc"
+                                 read! #f #f
+                                 (cut close-port port)))
 
 (define-syntax with-networking
   (syntax-rules ()
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 1838e89452..aa9b3f838a 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -48,28 +48,14 @@
 
 (define %user-module
   ;; Module in which the machine description file is loaded.
-  (let ((module (make-fresh-user-module)))
-    (for-each (lambda (iface)
-                (module-use! module (resolve-interface iface)))
-              '((gnu system)
-                (gnu services)
-                (gnu system shadow)))
-    module))
+  (make-user-module '((gnu system)
+                      (gnu services)
+                      (gnu system shadow))))
 
 (define (read-operating-system file)
   "Read the operating-system declaration from FILE and return it."
-  ;; TODO: Factorize.
-  (catch #t
-    (lambda ()
-      ;; Avoid ABI incompatibility with the <operating-system> record.
-      (set! %fresh-auto-compile #t)
+  (load* file %user-module))
 
-      (save-module-excursion
-       (lambda ()
-         (set-current-module %user-module)
-         (primitive-load file))))
-    (lambda args
-      (report-load-error file args))))
 
 
 ;;;
@@ -81,8 +67,6 @@
   (store-lift references))
 (define topologically-sorted*
   (store-lift topologically-sorted))
-(define show-what-to-build*
-  (store-lift show-what-to-build))
 
 
 (define* (copy-item item target
@@ -92,6 +76,13 @@
     (let ((dest  (string-append target item))
           (state (string-append target "/var/guix")))
       (format log-port "copying '~a'...~%" item)
+
+      ;; Remove DEST if it exists to make sure that (1) we do not fail badly
+      ;; while trying to overwrite it (see <http://bugs.gnu.org/20722>), and
+      ;; (2) we end up with the right contents.
+      (when (file-exists? dest)
+        (delete-file-recursively dest))
+
       (copy-recursively item dest
                         #:log (%make-void-port "w"))
 
@@ -144,8 +135,9 @@ TARGET, and register them."
 (define* (install os-drv target
                   #:key (log-port (current-output-port))
                   grub? grub.cfg device)
-  "Copy the output of OS-DRV and its dependencies to directory TARGET.  TARGET
-must be an absolute directory name since that's what 'guix-register' expects.
+  "Copy the closure of GRUB.CFG, which includes the output of OS-DRV, to
+directory TARGET.  TARGET must be an absolute directory name since that's what
+'guix-register' expects.
 
 When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG."
   (define (maybe-copy to-copy)
@@ -161,12 +153,24 @@ When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG."
             ;; Copy items to the new store.
             (copy-closure to-copy target #:log-port log-port)))))
 
+  ;; Make sure TARGET is root-owned when running as root, but still allow
+  ;; non-root uses (useful for testing.)  See
+  ;; <http://lists.gnu.org/archive/html/guix-devel/2015-05/msg00452.html>.
+  (if (zero? (geteuid))
+      (chown target 0 0)
+      (warning (_ "not running as 'root', so \
+the ownership of '~a' may be incorrect!~%")
+               target))
+
+  (chmod target #o755)
   (let ((os-dir   (derivation->output-path os-drv))
         (format   (lift format %store-monad))
         (populate (lift2 populate-root-file-system %store-monad)))
 
     (mbegin %store-monad
-      (maybe-copy os-dir)
+      ;; Copy the closure of GRUB.CFG, which includes OS-DIR, GRUB's
+      ;; background image and so on.
+      (maybe-copy grub.cfg)
 
       ;; Create a bunch of additional files.
       (format log-port "populating '~a'...~%" target)
@@ -290,10 +294,6 @@ it atomically, and then run OS's activation script."
     ((disk-image)
      (system-disk-image os #:disk-image-size image-size))))
 
-(define (grub.cfg os)
-  "Return the GRUB configuration file for OS."
-  (operating-system-grub.cfg os (previous-grub-entries)))
-
 (define* (maybe-build drvs
                       #:key dry-run? use-substitutes?)
   "Show what will/would be built, and actually build DRVS, unless DRY-RUN? is
@@ -323,7 +323,10 @@ boot directly to the kernel or to the bootloader."
                                                 #:full-boot? full-boot?
                                                 #:mappings mappings))
        (grub      (package->derivation grub))
-       (grub.cfg  (grub.cfg os))
+       (grub.cfg  (operating-system-grub.cfg os
+                                             (if (eq? 'init action)
+                                                 '()
+                                                 (previous-grub-entries))))
        (drvs   -> (if (and grub? (memq action '(init reconfigure)))
                       (list sys grub grub.cfg)
                       (list sys)))
@@ -372,21 +375,25 @@ boot directly to the kernel or to the bootloader."
 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"))
+   reconfigure      switch to a new operating system configuration\n"))
   (display (_ "\
-  - 'build', build the operating system without installing anything\n"))
+   build            build the operating system without installing anything\n"))
   (display (_ "\
-  - 'vm', build a virtual machine image that shares the host's store\n"))
+   vm               build a virtual machine image that shares the host's store\n"))
   (display (_ "\
-  - 'vm-image', build a freestanding virtual machine image\n"))
+   vm-image         build a freestanding virtual machine image\n"))
   (display (_ "\
-  - 'disk-image', build a disk image, suitable for a USB stick\n"))
+   disk-image       build a disk image, suitable for a USB stick\n"))
   (display (_ "\
-  - 'init', initialize a root file system to run GNU.\n"))
+   init             initialize a root file system to run GNU.\n"))
 
   (show-build-options-help)
   (display (_ "
+      --on-error=STRATEGY
+                         apply STRATEGY when an error occurs while reading FILE"))
+  (display (_ "
       --image-size=SIZE  for 'vm-image', produce an image of SIZE"))
   (display (_ "
       --no-grub          for 'init', do not install GRUB"))
@@ -426,6 +433,10 @@ Build the operating system declared in FILE according to ACTION.\n"))
          (option '(#\V "version") #f #f
                  (lambda args
                    (show-version-and-exit "guix system")))
+         (option '("on-error") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'on-error (string->symbol arg)
+                               result)))
          (option '("image-size") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'image-size (size->number arg)
@@ -518,7 +529,8 @@ Build the operating system declared in FILE according to ACTION.\n"))
            (action   (assoc-ref opts 'action))
            (system   (assoc-ref opts 'system))
            (os       (if file
-                         (read-operating-system file)
+                         (load* file %user-module
+                                #:on-error (assoc-ref opts 'on-error))
                          (leave (_ "no configuration file specified~%"))))
 
            (dry?     (assoc-ref opts 'dry-run?))