Merge branch 'master' into core-updates

3 files changed, 40 insertions, 57 deletions

diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index ebc99e52cc..6a67985c8b 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -28,6 +28,8 @@
   #:use-module (guix grafts)
   #:use-module (ice-9 format)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-37)
   #:export (guix-deploy))
 
@@ -43,8 +45,6 @@
 (define (show-help)
   (display (G_ "Usage: guix deploy [OPTION] FILE...
 Perform the deployment specified by FILE.\n"))
-  (display (G_ "
-  -s, --system=SYSTEM    attempt to build for SYSTEM--e.g., \"i686-linux\""))
   (show-build-options-help)
   (newline)
   (display (G_ "
@@ -66,8 +66,7 @@ Perform the deployment specified by FILE.\n"))
          %standard-build-options))
 
 (define %default-options
-  `((system . ,(%current-system))
-    (substitutes? . #t)
+  `((substitutes? . #t)
     (build-hook? . #t)
     (graft? . #t)
     (debug . 0)
@@ -91,8 +90,18 @@ Perform the deployment specified by FILE.\n"))
     (with-store store
       (set-build-options-from-command-line store opts)
       (for-each (lambda (machine)
-                  (info (G_ "deploying to ~a...") (machine-display-name machine))
-                  (parameterize ((%current-system (assq-ref opts 'system))
-                                 (%graft? (assq-ref opts 'graft?)))
-                    (run-with-store store (deploy-machine machine))))
+                  (info (G_ "deploying to ~a...~%")
+                        (machine-display-name machine))
+                  (parameterize ((%graft? (assq-ref opts 'graft?)))
+                    (guard (c ((message-condition? c)
+                               (report-error (G_ "failed to deploy ~a: '~a'~%")
+                                             (machine-display-name machine)
+                                             (condition-message c)))
+                              ((deploy-error? c)
+                               (when (deploy-error-should-roll-back c)
+                                 (info (G_ "rolling back ~a...~%")
+                                       (machine-display-name machine))
+                                 (run-with-store store (roll-back-machine machine)))
+                               (apply throw (deploy-error-captured-args c))))
+                      (run-with-store store (deploy-machine machine)))))
                 machines))))
diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm
index fa6b6cae37..99a88c50fa 100644
--- a/guix/scripts/describe.scm
+++ b/guix/scripts/describe.scm
@@ -153,30 +153,9 @@ in the format specified by FMT."
     (generation-number profile))
 
   (define channels
-    (map (lambda (entry)
-           (match (assq 'source (manifest-entry-properties entry))
-             (('source ('repository ('version 0)
-                                    ('url url)
-                                    ('branch branch)
-                                    ('commit commit)
-                                    _ ...))
-              (channel (name (string->symbol (manifest-entry-name entry)))
-                       (url url)
-                       (commit commit)))
-
-             ;; Pre-0.15.0 Guix does not provide that information,
-             ;; so there's not much we can do in that case.
-             (_ (channel (name 'guix)
-                         (url "?")
-                         (commit "?")))))
-
-         ;; Show most recently installed packages last.
-         (reverse
-          (manifest-entries
-           (profile-manifest
-            (if (zero? number)
-                profile
-                (generation-file-name profile number)))))))
+    (profile-channels (if (zero? number)
+                          profile
+                          (generation-file-name profile number))))
 
   (match fmt
     ('human
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index dd7026a6a4..4591d0f308 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -285,10 +285,9 @@ update would trigger a complete rebuild."
   (exit 0))
 
 (define (warn-no-updater package)
-  (format (current-error-port)
-          (G_ "~a: warning: no updater for ~a~%")
-          (location->string (package-location package))
-          (package-name package)))
+  (warning (package-location package)
+           (G_ "no updater for ~a~%")
+           (package-name package)))
 
 (define* (update-package store package updaters
                          #:key (key-download 'interactive) warn?)
@@ -306,11 +305,10 @@ warn about packages that have no matching updater."
         (when version
           (if (and=> tarball file-exists?)
               (begin
-                (format (current-error-port)
-                        (G_ "~a: ~a: updating from version ~a to version ~a...~%")
-                        (location->string loc)
-                        (package-name package)
-                        (package-version package) version)
+                (info loc
+                      (G_ "~a: updating from version ~a to version ~a...~%")
+                      (package-name package)
+                      (package-version package) version)
                 (for-each
                  (lambda (change)
                    (format (current-error-port)
@@ -350,27 +348,24 @@ WARN? is true and no updater exists for PACKAGE, print a warning."
        (case (version-compare (upstream-source-version source)
                               (package-version package))
          ((>)
-          (format (current-error-port)
-                  (G_ "~a: ~a would be upgraded from ~a to ~a~%")
-                  (location->string loc)
-                  (package-name package) (package-version package)
-                  (upstream-source-version source)))
+          (info loc
+                (G_ "~a would be upgraded from ~a to ~a~%")
+                (package-name package) (package-version package)
+                (upstream-source-version source)))
          ((=)
           (when warn?
-            (format (current-error-port)
-                    (G_ "~a: info: ~a is already the latest version of ~a~%")
-                    (location->string loc)
-                    (package-version package)
-                    (package-name package))))
+            (info loc
+                  (G_ "~a is already the latest version of ~a~%")
+                  (package-version package)
+                  (package-name package))))
          (else
           (when warn?
-            (format (current-error-port)
-                    (G_ "~a: warning: ~a is greater than \
+            (warning loc
+                     (G_ "~a is greater than \
 the latest known version of ~a (~a)~%")
-                    (location->string loc)
-                    (package-version package)
-                    (package-name package)
-                    (upstream-source-version source)))))))
+                     (package-version package)
+                     (package-name package)
+                     (upstream-source-version source)))))))
     (#f
      (when warn?
        (warn-no-updater package)))))