Merge remote-tracking branch 'origin/master' into staging

17 files changed, 204 insertions, 117 deletions

diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index 41a2a42c21..f3b86fba14 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -380,6 +380,8 @@ output port."
                    (with-build-handler
                        (build-notifier #:use-substitutes?
                                        (assoc-ref opts 'substitutes?)
+                                       #:verbosity
+                                       (assoc-ref opts 'verbosity)
                                        #:dry-run?
                                        (assoc-ref opts 'dry-run?))
                      (cond ((assoc-ref opts 'export)
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 8ff2fd1910..6286a43c02 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -961,6 +961,8 @@ needed."
 
         (with-build-handler (build-notifier #:use-substitutes?
                                             (assoc-ref opts 'substitutes?)
+                                            #:verbosity
+                                            (assoc-ref opts 'verbosity)
                                             #:dry-run?
                                             (assoc-ref opts 'dry-run?))
           (parameterize ((current-terminal-columns (terminal-columns))
diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm
index f6f64d0a11..274620fc1e 100644
--- a/guix/scripts/copy.scm
+++ b/guix/scripts/copy.scm
@@ -20,6 +20,7 @@
   #:use-module (guix ui)
   #:use-module (guix scripts)
   #:use-module (guix ssh)
+  #:use-module ((ssh session) #:select (disconnect!))
   #:use-module (guix store)
   #:use-module ((guix status) #:select (with-status-verbosity))
   #:use-module (guix utils)
@@ -71,9 +72,10 @@ package names, build the underlying packages before sending them."
     (and (build-derivations local drv)
          (let* ((session (open-ssh-session host #:user user
                                            #:port (or port 22)))
-                (sent    (send-files local items
-                                     (connect-to-remote-daemon session)
+                (remote  (connect-to-remote-daemon session))
+                (sent    (send-files local items remote
                                      #:recursive? #t)))
+           (close-connection remote)
            (format #t "~{~a~%~}" sent)
            sent))))
 
@@ -93,6 +95,8 @@ package names, build the underlying packages before sending them."
                    (options->derivations+files local opts))
                   ((retrieved)
                    (retrieve-files local items remote #:recursive? #t)))
+      (close-connection remote)
+      (disconnect! session)
       (format #t "~{~a~%~}" retrieved)
       retrieved)))
 
@@ -175,6 +179,8 @@ Copy ITEMS to or from the specified host over SSH.\n"))
         (set-build-options-from-command-line store opts)
         (with-build-handler (build-notifier #:use-substitutes?
                                             (assoc-ref opts 'substitutes?)
+                                            #:verbosity
+                                            (assoc-ref opts 'verbosity)
                                             #:dry-run?
                                             (assoc-ref opts 'dry-run?))
           (with-status-verbosity (assoc-ref opts 'verbosity)
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index 4466a0c632..4a68197620 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -140,18 +140,21 @@ Perform the deployment specified by FILE.\n"))
   (define (handle-argument arg result)
     (alist-cons 'file arg result))
 
-  (let* ((opts (parse-command-line args %options (list %default-options)
-                                   #:argument-handler handle-argument))
-         (file (assq-ref opts 'file))
-         (machines (or (and file (load-source-file file)) '())))
-    (show-what-to-deploy machines)
+  (with-error-handling
+    (let* ((opts (parse-command-line args %options (list %default-options)
+                                     #:argument-handler handle-argument))
+           (file (assq-ref opts 'file))
+           (machines (or (and file (load-source-file file)) '())))
+      (show-what-to-deploy machines)
 
-    (with-status-verbosity (assoc-ref opts 'verbosity)
-      (with-store store
-        (set-build-options-from-command-line store opts)
-        (with-build-handler (build-notifier #:use-substitutes?
-                                            (assoc-ref opts 'substitutes?))
-          (parameterize ((%graft? (assq-ref opts 'graft?)))
-            (map/accumulate-builds store
-                                   (cut deploy-machine* store <>)
-                                   machines)))))))
+      (with-status-verbosity (assoc-ref opts 'verbosity)
+        (with-store store
+          (set-build-options-from-command-line store opts)
+          (with-build-handler (build-notifier #:use-substitutes?
+                                              (assoc-ref opts 'substitutes?)
+                                              #:verbosity
+                                              (assoc-ref opts 'verbosity))
+            (parameterize ((%graft? (assq-ref opts 'graft?)))
+              (map/accumulate-builds store
+                                     (cut deploy-machine* store <>)
+                                     machines))))))))
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index d3b8b57ccc..1fb3505307 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -477,6 +477,7 @@ WHILE-LIST."
                             (group-entry (gid 65534) ;the overflow GID
                                          (name "overflow"))))
             (home-dir (password-entry-directory passwd))
+            (logname  (password-entry-name passwd))
             (environ  (filter (match-lambda
                                 ((variable . value)
                                  (find (cut regexp-exec <> variable)
@@ -528,6 +529,10 @@ WHILE-LIST."
                       ;; The same variables as in Nix's 'build.cc'.
                       '("TMPDIR" "TEMPDIR" "TMP" "TEMP"))
 
+            ;; Some programs expect USER and/or LOGNAME to be set.
+            (setenv "LOGNAME" logname)
+            (setenv "USER" logname)
+
             ;; Create a dummy home directory.
             (mkdir-p home-dir)
             (setenv "HOME" home-dir)
@@ -708,6 +713,8 @@ message if any test fails."
       (with-store store
         (with-build-handler (build-notifier #:use-substitutes?
                                             (assoc-ref opts 'substitutes?)
+                                            #:verbosity
+                                            (assoc-ref opts 'verbosity)
                                             #:dry-run?
                                             (assoc-ref opts 'dry-run?))
           (with-status-verbosity (assoc-ref opts 'verbosity)
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index 489931d5bb..73d9269de2 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -32,7 +32,8 @@
   #:use-module ((guix build-system gnu) #:select (standard-packages))
   #:use-module (gnu packages)
   #:use-module (guix sets)
-  #:use-module ((guix utils) #:select (location-file))
+  #:use-module ((guix diagnostics)
+                #:select (location-file formatted-message))
   #:use-module ((guix scripts build)
                 #:select (show-transformation-options-help
                           options->transformation
@@ -90,10 +91,8 @@ name."
      package)
     (x
      (raise
-      (condition
-       (&message
-        (message (format #f (G_ "~a: invalid argument (package name expected)")
-                         x))))))))
+      (formatted-message (G_ "~a: invalid argument (package name expected)")
+                         x)))))
 
 (define nodes-from-package
   ;; The default conversion method.
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 97ffd57301..5168a1ca17 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
 ;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org>
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
 ;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org>
 ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
@@ -174,23 +174,24 @@ run the checkers on all packages.\n"))
     (when (assoc-ref opts 'list?)
       (list-checkers-and-exit checkers))
 
-    (let ((any-lint-checker-requires-store?
-           (any lint-checker-requires-store? checkers)))
+    (with-error-handling
+      (let ((any-lint-checker-requires-store?
+             (any lint-checker-requires-store? checkers)))
 
-      (define (call-maybe-with-store proc)
-        (if any-lint-checker-requires-store?
-            (with-store store
-              (proc store))
-            (proc #f)))
+        (define (call-maybe-with-store proc)
+          (if any-lint-checker-requires-store?
+              (with-store store
+                (proc store))
+              (proc #f)))
 
-      (call-maybe-with-store
-       (lambda (store)
-         (cond
-          ((null? args)
-           (fold-packages (lambda (p r) (run-checkers p checkers
-                                                      #:store store)) '()))
-          (else
-           (for-each (lambda (spec)
-                       (run-checkers (specification->package spec) checkers
-                                     #:store store))
-                     args))))))))
+        (call-maybe-with-store
+         (lambda (store)
+           (cond
+            ((null? args)
+             (fold-packages (lambda (p r) (run-checkers p checkers
+                                                        #:store store)) '()))
+            (else
+             (for-each (lambda (spec)
+                         (run-checkers (specification->package spec) checkers
+                                       #:store store))
+                       args)))))))))
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index e81b6c25f2..1e0e9d7905 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -33,11 +34,12 @@
   #:use-module ((guix serialization)
                 #:select (nar-error? nar-error-file))
   #:use-module (guix nar)
-  #:use-module (guix utils)
+  #:use-module ((guix utils) #:select (%current-system))
   #:use-module ((guix build syscalls)
                 #:select (fcntl-flock set-thread-name))
   #:use-module ((guix build utils) #:select (which mkdir-p))
   #:use-module (guix ui)
+  #:use-module (guix diagnostics)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
@@ -65,14 +67,16 @@
 ;;;
 ;;; Code:
 
-
 (define-record-type* <build-machine>
   build-machine make-build-machine
   build-machine?
   (name            build-machine-name)            ; string
   (port            build-machine-port             ; number
                    (default 22))
-  (system          build-machine-system)          ; string
+  (systems         %build-machine-systems         ; list of strings
+                   (default #f))                  ; drop default after system is removed
+  (system          %build-machine-system          ; deprecated
+                   (default #f))
   (user            build-machine-user)            ; string
   (private-key     build-machine-private-key      ; file name
                    (default (user-openssh-private-key)))
@@ -90,6 +94,19 @@
   (features        build-machine-features         ; list of strings
                    (default '())))
 
+;;; Deprecated.
+(define (build-machine-system machine)
+  (warning (G_ "The 'system' field is deprecated, \
+please use 'systems' instead.~%"))
+  (%build-machine-system machine))
+
+;;; TODO: Remove after the deprecated 'system' field is removed.
+(define (build-machine-systems machine)
+  (or (%build-machine-systems machine)
+      (list (build-machine-system machine))
+      (leave (G_ "The build-machine object lacks a value for its 'systems'
+field."))))
+
 (define-record-type* <build-requirements>
   build-requirements make-build-requirements
   build-requirements?
@@ -156,10 +173,9 @@ can interpret meaningfully."
     (lambda ()
       (private-key-from-file file))
     (lambda (key proc str . rest)
-      (raise (condition
-              (&message (message (format #f (G_ "failed to load SSH \
+      (raise (formatted-message (G_ "failed to load SSH \
 private key from '~a': ~a")
-                                         file str))))))))
+                                file str)))))
 
 (define* (open-ssh-session machine #:optional (max-silent-time -1))
   "Open an SSH session for MACHINE and return it.  Throw an error on failure."
@@ -349,6 +365,8 @@ of free disk space on '~a'~%")
                                        #:log-port (current-error-port)
                                        #:lock? #f)))
 
+  (close-connection store)
+  (disconnect! session)
   (format (current-error-port) "done with offloaded '~a'~%"
           (derivation-file-name drv)))
 
@@ -359,8 +377,8 @@ of free disk space on '~a'~%")
 
 (define (machine-matches? machine requirements)
   "Return #t if MACHINE matches REQUIREMENTS."
-  (and (string=? (build-requirements-system requirements)
-                 (build-machine-system machine))
+  (and (member (build-requirements-system requirements)
+               (build-machine-systems machine))
        (lset<= string=?
                (build-requirements-features requirements)
                (build-machine-features machine))))
@@ -779,7 +797,8 @@ machine."
     (("--version")
      (show-version-and-exit "guix offload"))
     (("--help")
-     (format #t (G_ "Usage: guix offload SYSTEM PRINT-BUILD-TRACE
+     (format #t (G_ "Usage: guix offload SYSTEM MAX-SILENT-TIME \
+PRINT-BUILD-TRACE? BUILD-TIMEOUT
 Process build offload requests written on the standard input, possibly
 offloading builds to the machines listed in '~a'.~%")
              %machine-file)
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 5fb6aaae0c..9d6881fdaf 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -744,11 +744,13 @@ last resort for relocation."
     (with-imported-modules (source-module-closure
                             '((guix build utils)
                               (guix build union)
+                              (guix build gremlin)
                               (guix elf)))
       #~(begin
           (use-modules (guix build utils)
                        ((guix build union) #:select (relative-file-name))
                        (guix elf)
+                       (guix build gremlin)
                        (ice-9 binary-ports)
                        (ice-9 ftw)
                        (ice-9 match)
@@ -786,6 +788,14 @@ last resort for relocation."
                                    bv 0 (bytevector-length bv))
                  (utf8->string bv)))))
 
+          (define (runpath file)
+            ;; Return the RUNPATH of FILE as a list of directories.
+            (let* ((bv      (call-with-input-file file get-bytevector-all))
+                   (elf     (parse-elf bv))
+                   (dyninfo (elf-dynamic-info elf)))
+              (or (and=> dyninfo elf-dynamic-info-runpath)
+                  '())))
+
           (define (elf-loader-compile-flags program)
             ;; Return the cpp flags defining macros for the ld.so/fakechroot
             ;; wrapper of PROGRAM.
@@ -807,6 +817,13 @@ last resort for relocation."
 
                             (string-append "-DLOADER_AUDIT_MODULE=\""
                                            #$(audit-module) "\"")
+                            (string-append "-DLOADER_AUDIT_RUNPATH={ "
+                                           (string-join
+                                            (map object->string
+                                                 (runpath
+                                                  #$(audit-module)))
+                                            ", " 'suffix)
+                                           "NULL }")
                             (if gconv
                                 (string-append "-DGCONV_DIRECTORY=\""
                                                gconv "\"")
@@ -1136,6 +1153,8 @@ Create a bundle of PACKAGE.\n"))
 
         (with-build-handler (build-notifier #:dry-run?
                                             (assoc-ref opts 'dry-run?)
+                                            #:verbosity
+                                            (assoc-ref opts 'verbosity)
                                             #:use-substitutes?
                                             (assoc-ref opts 'substitutes?))
           (parameterize ((%graft? (assoc-ref opts 'graft?))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 1246147798..ac8dedb5f3 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -965,6 +965,8 @@ option processing with 'parse-command-line'."
             (set-build-options-from-command-line (%store) opts)
             (with-build-handler (build-notifier #:use-substitutes?
                                                 (assoc-ref opts 'substitutes?)
+                                                #:verbosity
+                                                (assoc-ref opts 'verbosity)
                                                 #:dry-run?
                                                 (assoc-ref opts 'dry-run?))
               (parameterize ((%guile-for-build
diff --git a/guix/scripts/processes.scm b/guix/scripts/processes.scm
index 01f7213e8c..35698a0216 100644
--- a/guix/scripts/processes.scm
+++ b/guix/scripts/processes.scm
@@ -235,4 +235,7 @@ List the current Guix sessions and their processes."))
     (for-each (lambda (session)
                 (daemon-session->recutils session port)
                 (newline port))
-              (daemon-sessions))))
+              (daemon-sessions))
+
+    ;; Pass 'R' (instead of 'r') so 'less' correctly estimates line length.
+    #:less-options "FRX"))
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index a00f08f9d9..61542f83a0 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -50,10 +50,9 @@
   #:use-module (guix workers)
   #:use-module (guix store)
   #:use-module ((guix serialization) #:select (write-file))
-  #:use-module (guix zlib)
-  #:autoload   (guix lzlib) (lzlib-available?
-                             call-with-lzip-output-port
-                             make-lzip-output-port)
+  #:use-module (zlib)
+  #:autoload   (lzlib) (call-with-lzip-output-port
+                        make-lzip-output-port)
   #:use-module (guix cache)
   #:use-module (guix ui)
   #:use-module (guix scripts)
@@ -880,8 +879,8 @@ blocking."
   "Return a symbol denoting the compression method expressed by STRING; return
 #f if STRING doesn't match any supported method."
   (match string
-    ("gzip" (and (zlib-available?) 'gzip))
-    ("lzip" (and (lzlib-available?) 'lzip))
+    ("gzip" 'gzip)
+    ("lzip" 'lzip)
     (_      #f)))
 
 (define (effective-compression requested-type compressions)
@@ -1032,9 +1031,7 @@ methods, return the applicable compression."
                                             opts)
                            (()
                             ;; Default to fast & low compression.
-                            (list (if (zlib-available?)
-                                      %default-gzip-compression
-                                      %no-compression)))
+                            (list %default-gzip-compression))
                            (lst (reverse lst))))
            (address (let ((addr (assoc-ref opts 'address)))
                       (make-socket-address (sockaddr:fam addr)
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 807daec593..3b980b8f3f 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -507,6 +507,7 @@ true, display what would be built without actually building it."
   ;; workaround, skip this code when $SUDO_USER is set.  See
   ;; <https://bugs.gnu.org/36785>.
   (unless (or (getenv "SUDO_USER")
+              (not (file-exists? %user-profile-directory))
               (string=? %profile-directory
                         (dirname
                          (canonicalize-profile %user-profile-directory))))
@@ -773,6 +774,8 @@ Use '~/.config/guix/channels.scm' instead."))
                                  (%graft? (assoc-ref opts 'graft?)))
                     (with-build-handler (build-notifier #:use-substitutes?
                                                         substitutes?
+                                                        #:verbosity
+                                                        (assoc-ref opts 'verbosity)
                                                         #:dry-run? dry-run?)
                       (set-build-options-from-command-line store opts)
                       (ensure-default-profile)
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index ba2b2d2d4e..117d824449 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -41,7 +41,6 @@
   #:use-module (guix progress)
   #:use-module ((guix build syscalls)
                 #:select (set-thread-name))
-  #:autoload   (guix lzlib) (lzlib-available?)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 match)
@@ -912,7 +911,7 @@ authorized substitutes."
   ;; Known compression methods and a thunk to determine whether they're
   ;; supported.  See 'decompressed-port' in (guix utils).
   `(("gzip"  . ,(const #t))
-    ("lzip"  . ,lzlib-available?)
+    ("lzip"  . ,(const #t))
     ("xz"    . ,(const #t))
     ("bzip2" . ,(const #t))
     ("none"  . ,(const #t))))
@@ -1127,12 +1126,13 @@ default value."
   ;; Sanity-check SUBSTITUTE-URLS so we can provide a meaningful error message.
   (for-each validate-uri (substitute-urls))
 
-  ;; Attempt to install the client's locale, mostly so that messages are
-  ;; suitably translated.
+  ;; Attempt to install the client's locale so that messages are suitably
+  ;; translated.  LC_CTYPE must be a UTF-8 locale; it's the case by default so
+  ;; don't change it.
   (match (or (find-daemon-option "untrusted-locale")
              (find-daemon-option "locale"))
     (#f     #f)
-    (locale (false-if-exception (setlocale LC_ALL locale))))
+    (locale (false-if-exception (setlocale LC_MESSAGES locale))))
 
   (catch 'system-error
     (lambda ()
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 79bfcd7db2..b75b0e5b60 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -6,6 +6,7 @@
 ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -271,28 +272,33 @@ expression in %STORE-MONAD."
 
 (define (report-shepherd-error error)
   "Report ERROR, a '&shepherd-error' error condition object."
-  (cond ((service-not-found-error? error)
-         (report-error (G_ "service '~a' could not be found~%")
-                       (service-not-found-error-service error)))
-        ((action-not-found-error? error)
-         (report-error (G_ "service '~a' does not have an action '~a'~%")
-                       (action-not-found-error-service error)
-                       (action-not-found-error-action error)))
-        ((action-exception-error? error)
-         (report-error (G_ "exception caught while executing '~a' \
+  (when error
+    (cond ((service-not-found-error? error)
+           (warning (G_ "service '~a' could not be found~%")
+                    (service-not-found-error-service error)))
+          ((action-not-found-error? error)
+           (warning (G_ "service '~a' does not have an action '~a'~%")
+                    (action-not-found-error-service error)
+                    (action-not-found-error-action error)))
+          ((action-exception-error? error)
+           (warning (G_ "exception caught while executing '~a' \
 on service '~a':~%")
-                       (action-exception-error-action error)
-                       (action-exception-error-service error))
-         (print-exception (current-error-port) #f
-                          (action-exception-error-key error)
-                          (action-exception-error-arguments error)))
-        ((unknown-shepherd-error? error)
-         (report-error (G_ "something went wrong: ~s~%")
-                       (unknown-shepherd-error-sexp error)))
-        ((shepherd-error? error)
-         (report-error (G_ "shepherd error~%")))
-        ((not error)                              ;not an error
-         #t)))
+                    (action-exception-error-action error)
+                    (action-exception-error-service error))
+           (print-exception (current-error-port) #f
+                            (action-exception-error-key error)
+                            (action-exception-error-arguments error)))
+          ((unknown-shepherd-error? error)
+           (warning (G_ "something went wrong: ~s~%")
+                    (unknown-shepherd-error-sexp error)))
+          ((shepherd-error? error)
+           (warning (G_ "shepherd error~%"))))
+
+    ;; Don't leave users out in the cold and explain what that means and what
+    ;; they can do.
+    (warning (G_ "some services could not be upgraded~%"))
+    (display-hint (G_ "To allow changes to all the system services to take
+effect, you will need to reboot."))))
 
 (define-syntax-rule (unless-file-not-found exp)
   (catch 'system-error
@@ -565,16 +571,14 @@ any, are available.  Raise an error if they're not."
   (define fail? #f)
 
   (define (file-system-location* fs)
-    (location->string
-     (source-properties->location
-      (file-system-location fs))))
+    (and=> (file-system-location fs)
+           source-properties->location))
 
   (let-syntax ((error (syntax-rules ()
                         ((_ args ...)
                          (begin
                            (set! fail? #t)
-                           (format (current-error-port)
-                                   args ...))))))
+                           (report-error args ...))))))
     (for-each (lambda (fs)
                 (catch 'system-error
                   (lambda ()
@@ -582,9 +586,9 @@ any, are available.  Raise an error if they're not."
                   (lambda args
                     (let ((errno  (system-error-errno args))
                           (device (file-system-device fs)))
-                      (error (G_ "~a: error: device '~a' not found: ~a~%")
-                             (file-system-location* fs) device
-                             (strerror errno))
+                      (error (file-system-location* fs)
+                             (G_ "device '~a' not found: ~a~%")
+                             device (strerror errno))
                       (unless (string-prefix? "/" device)
                         (display-hint (format #f (G_ "If '~a' is a file system
 label, write @code{(file-system-label ~s)} in your @code{device} field.")
@@ -594,13 +598,14 @@ label, write @code{(file-system-label ~s)} in your @code{device} field.")
                 (let ((label (file-system-label->string
                               (file-system-device fs))))
                   (unless (find-partition-by-label label)
-                    (error (G_ "~a: error: file system with label '~a' not found~%")
-                           (file-system-location* fs) label))))
+                    (error (file-system-location* fs)
+                           (G_ "file system with label '~a' not found~%")
+                           label))))
               labeled)
     (for-each (lambda (fs)
                 (unless (find-partition-by-uuid (file-system-device fs))
-                  (error (G_ "~a: error: file system with UUID '~a' not found~%")
-                         (file-system-location* fs)
+                  (error (file-system-location* fs)
+                         (G_ "file system with UUID '~a' not found~%")
                          (uuid->string (file-system-device fs)))))
               uuid)
 
@@ -663,7 +668,7 @@ checking this by themselves in their 'check' procedure."
 (define* (system-derivation-for-action os base-image action
                                        #:key image-size file-system-type
                                        full-boot? container-shared-network?
-                                       mappings)
+                                       mappings label)
   "Return as a monadic value the derivation for OS according to ACTION."
   (case action
     ((build init reconfigure)
@@ -687,7 +692,7 @@ checking this by themselves in their 'check' procedure."
      (lower-object
       (system-image
        (image
-        (inherit base-image)
+        (inherit (if label (image-with-label base-image label) base-image))
         (size image-size)
         (operating-system os)))))
     ((docker-image)
@@ -742,7 +747,7 @@ and TARGET arguments."
                          install-bootloader?
                          dry-run? derivations-only?
                          use-substitutes? bootloader-target target
-                         image-size file-system-type full-boot?
+                         image-size file-system-type full-boot? label
                          container-shared-network?
                          (mappings '())
                          (gc-root #f))
@@ -796,6 +801,7 @@ static checks."
       ((target*   (current-target-system))
        (image ->  (find-image file-system-type target*))
        (sys       (system-derivation-for-action os image action
+                                                #:label label
                                                 #:file-system-type file-system-type
                                                 #:image-size image-size
                                                 #:full-boot? full-boot?
@@ -836,7 +842,9 @@ static checks."
                  (upgrade-shepherd-services local-eval os)
                  (return (format #t (G_ "\
 To complete the upgrade, run 'herd restart SERVICE' to stop,
-upgrade, and restart each service that was not automatically restarted.\n"))))))
+upgrade, and restart each service that was not automatically restarted.\n")))
+                 (return (format #t (G_ "\
+Run 'herd status' to view the list of services on your system.\n"))))))
             ((init)
              (newline)
              (format #t (G_ "initializing operating system under '~a'...~%")
@@ -944,6 +952,8 @@ Some ACTIONS support additional ARGS.\n"))
   (display (G_ "
       --no-bootloader    for 'init', do not install a bootloader"))
   (display (G_ "
+      --label=LABEL      for 'disk-image', label disk image with LABEL"))
+  (display (G_ "
       --save-provenance  save provenance information"))
   (display (G_ "
       --share=SPEC       for 'vm', share host file system according to SPEC"))
@@ -1009,6 +1019,9 @@ Some ACTIONS support additional ARGS.\n"))
          (option '("no-bootloader" "no-grub") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'install-bootloader? #f result)))
+         (option '("label") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'label arg result)))
          (option '("full-boot") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'full-boot? #t result)))
@@ -1066,7 +1079,14 @@ Some ACTIONS support additional ARGS.\n"))
     (validate-reconfigure . ,ensure-forward-reconfigure)
     (file-system-type . "ext4")
     (image-size . guess)
-    (install-bootloader? . #t)))
+    (install-bootloader? . #t)
+    (label . #f)))
+
+(define (verbosity-level opts)
+  "Return the verbosity level based on OPTS, the alist of parsed options."
+  (or (assoc-ref opts 'verbosity)
+      (if (eq? (assoc-ref opts 'action) 'build)
+          2 1)))
 
 
 ;;;
@@ -1114,6 +1134,7 @@ resulting from command-line parsing."
 
          (dry?        (assoc-ref opts 'dry-run?))
          (bootloader? (assoc-ref opts 'install-bootloader?))
+         (label       (assoc-ref opts 'label))
          (target-file (match args
                         ((first second) second)
                         (_ #f)))
@@ -1127,6 +1148,8 @@ resulting from command-line parsing."
 
       (with-build-handler (build-notifier #:use-substitutes?
                                           (assoc-ref opts 'substitutes?)
+                                          #:verbosity
+                                          (verbosity-level opts)
                                           #:dry-run?
                                           (assoc-ref opts 'dry-run?))
         (run-with-store store
@@ -1162,6 +1185,7 @@ resulting from command-line parsing."
                                                         (_ #f))
                                                       opts)
                                #:install-bootloader? bootloader?
+                               #:label label
                                #:target target-file
                                #:bootloader-target bootloader-target
                                #:gc-root (assoc-ref opts 'gc-root)))))
@@ -1283,8 +1307,7 @@ argument list and OPTS is the option alist."
            (args     (option-arguments opts))
            (command  (assoc-ref opts 'action)))
       (parameterize ((%graft? (assoc-ref opts 'graft?)))
-        (with-status-verbosity (or (assoc-ref opts 'verbosity)
-                                   (if (eq? command 'build) 2 1))
+        (with-status-verbosity (verbosity-level opts)
           (process-command command args opts))))))
 
 ;;; Local Variables:
diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm
index 9013e035f7..45bb1d5d3b 100644
--- a/guix/scripts/system/reconfigure.scm
+++ b/guix/scripts/system/reconfigure.scm
@@ -39,7 +39,6 @@
   #:autoload   (guix git) (update-cached-checkout)
   #:use-module (guix i18n)
   #:use-module (guix diagnostics)
-  #:use-module ((guix utils) #:select (&fix-hint))
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
@@ -340,24 +339,25 @@ to commits of channels in NEW."
               old))
 
 (define* (check-forward-update #:optional
-                               (validate-reconfigure ensure-forward-reconfigure))
+                               (validate-reconfigure
+                                ensure-forward-reconfigure)
+                               #:key
+                               (current-channels
+                                (system-provenance "/run/current-system")))
   "Call VALIDATE-RECONFIGURE passing it, for each channel, the channel, the
-currently-deployed commit (as returned by 'guix system describe') and the
-target commit (as returned by 'guix describe')."
-  ;; TODO: Make that functionality available to 'guix deploy'.
+currently-deployed commit (from CURRENT-CHANNELS, which is as returned by
+'guix system describe' by default) and the target commit (as returned by 'guix
+describe')."
   (define new
     (or (and=> (current-profile) profile-channels)
         '()))
 
-  (define old
-    (system-provenance "/run/current-system"))
-
-  (when (null? old)
-    (warning (G_ "cannot determine provenance for /run/current-system~%")))
+  (when (null? current-channels)
+    (warning (G_ "cannot determine provenance for current system~%")))
   (when (and (null? new) (not (getenv "GUIX_UNINSTALLED")))
     (warning (G_ "cannot determine provenance of ~a~%") %guix-package-name))
 
   (for-each (match-lambda
               ((channel old new relation)
                (validate-reconfigure channel old new relation)))
-            (channel-relations old new)))
+            (channel-relations current-channels new)))
diff --git a/guix/scripts/upgrade.scm b/guix/scripts/upgrade.scm
index 7f14a2fdbe..d2784669be 100644
--- a/guix/scripts/upgrade.scm
+++ b/guix/scripts/upgrade.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -60,7 +61,7 @@ This is an alias for 'guix package -u'.\n"))
          ;; Preserve some of the 'guix package' options.
          (append (filter (lambda (option)
                            (any (cut member <> (option-names option))
-                                '("profile" "dry-run" "verbosity")))
+                                '("profile" "dry-run" "verbosity" "do-not-upgrade")))
                          %package-options)
 
                  %transformation-options