summary refs log tree commit diff
diff options
context:
space:
mode:
-rw-r--r--gnu.scm6
-rw-r--r--gnu/machine/digital-ocean.scm7
-rw-r--r--gnu/machine/ssh.scm36
-rw-r--r--gnu/packages.scm6
-rw-r--r--gnu/services.scm32
-rw-r--r--gnu/system.scm4
-rw-r--r--gnu/system/mapped-devices.scm34
-rw-r--r--guix/channels.scm14
-rw-r--r--guix/cve.scm15
-rw-r--r--guix/git-authenticate.scm86
-rw-r--r--guix/lint.scm16
-rw-r--r--guix/remote.scm9
-rw-r--r--guix/scripts/graph.scm9
-rw-r--r--guix/scripts/offload.scm10
-rw-r--r--guix/ssh.scm26
-rw-r--r--guix/ui.scm4
-rw-r--r--guix/upstream.scm11
-rw-r--r--tests/channels.scm22
-rw-r--r--tests/lint.scm2
-rw-r--r--tests/packages.scm11
20 files changed, 173 insertions, 187 deletions
diff --git a/gnu.scm b/gnu.scm
index b95082f42e..f139531ef3 100644
--- a/gnu.scm
+++ b/gnu.scm
@@ -78,10 +78,8 @@
                   (raise
                    (apply
                     make-compound-condition
-                    (condition
-                     (&message
-                      (message (format #f (G_ "module ~a not found")
-                                       module))))
+                    (formatted-message (G_ "module ~a not found")
+                                       module)
                     (condition
                      (&error-location (location location)))
                     (or (and=> (make-hint module) list)
diff --git a/gnu/machine/digital-ocean.scm b/gnu/machine/digital-ocean.scm
index 1a91a3a49b..82383a8c7c 100644
--- a/gnu/machine/digital-ocean.scm
+++ b/gnu/machine/digital-ocean.scm
@@ -26,6 +26,7 @@
   #:use-module (guix base32)
   #:use-module (guix derivations)
   #:use-module (guix i18n)
+  #:use-module ((guix diagnostics) #:select (formatted-message))
   #:use-module (guix import json)
   #:use-module (guix monads)
   #:use-module (guix records)
@@ -414,9 +415,7 @@ one procured from https://cloud.digitalocean.com/account/api/tokens.")))))))
   (let ((config (machine-configuration machine))
         (environment (environment-type-name (machine-environment machine))))
     (unless (and config (digital-ocean-configuration? config))
-      (raise (condition
-              (&message
-               (message (format #f (G_ "unsupported machine configuration '~a'
+      (raise (formatted-message (G_ "unsupported machine configuration '~a' \
 for environment of type '~a'")
                                 config
-                                environment))))))))
+                                environment)))))
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index 4148639292..641e871861 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -179,11 +179,9 @@ exist on the machine."
                             (lambda args
                               (system-error-errno args)))))
       (when (number? errno)
-        (raise (condition
-                (&message
-                 (message (format #f (G_ "device '~a' not found: ~a")
+        (raise (formatted-message (G_ "device '~a' not found: ~a")
                                   (file-system-device fs)
-                                  (strerror errno)))))))))
+                                  (strerror errno))))))
 
   (define (check-labeled-file-system fs)
     (define remote-exp
@@ -196,11 +194,9 @@ exist on the machine."
 
     (remote-let ((result remote-exp))
       (unless result
-        (raise (condition
-                (&message
-                 (message (format #f (G_ "no file system with label '~a'")
+        (raise (formatted-message (G_ "no file system with label '~a'")
                                   (file-system-label->string
-                                   (file-system-device fs))))))))))
+                                   (file-system-device fs)))))))
 
   (define (check-uuid-file-system fs)
     (define remote-exp
@@ -217,10 +213,8 @@ exist on the machine."
 
     (remote-let ((result remote-exp))
       (unless result
-        (raise (condition
-                (&message
-                 (message (format #f (G_ "no file system with UUID '~a'")
-                                  (uuid->string (file-system-device fs))))))))))
+        (raise (formatted-message (G_ "no file system with UUID '~a'")
+                                  (uuid->string (file-system-device fs)))))))
 
   (append (map check-literal-file-system
                (filter (lambda (fs)
@@ -285,12 +279,10 @@ by MACHINE."
         (system (remote-system (machine-ssh-session machine))))
     (when (and (machine-ssh-configuration-build-locally? config)
                (not (string= system (machine-ssh-configuration-system config))))
-      (raise (condition
-              (&message
-               (message (format #f (G_ "incorrect target system\
+      (raise (formatted-message (G_ "incorrect target system\
  ('~a' was given, while the system reports that it is '~a')~%")
                                 (machine-ssh-configuration-system config)
-                                system))))))))
+                                system)))))
 
 (define (check-deployment-sanity machine)
   "Raise a '&message' error condition if it is clear that deploying MACHINE's
@@ -402,11 +394,9 @@ environment type of 'managed-host."
   (when (machine-ssh-configuration-authorize?
          (machine-configuration machine))
     (unless (file-exists? %public-key-file)
-      (raise (condition
-              (&message
-               (message (format #f (G_ "no signing key '~a'. \
+      (raise (formatted-message (G_ "no signing key '~a'. \
 have you run 'guix archive --generate-key?'")
-                                %public-key-file))))))
+                                %public-key-file)))
     (remote-authorize-signing-key (call-with-input-file %public-key-file
                                     (lambda (port)
                                       (string->canonical-sexp
@@ -497,9 +487,7 @@ connection to the host.")))
   (let ((config (machine-configuration machine))
         (environment (environment-type-name (machine-environment machine))))
     (unless (and config (machine-ssh-configuration? config))
-      (raise (condition
-              (&message
-               (message (format #f (G_ "unsupported machine configuration '~a'
+      (raise (formatted-message (G_ "unsupported machine configuration '~a'
 for environment of type '~a'")
                                 config
-                                environment))))))))
+                                environment)))))
diff --git a/gnu/packages.scm b/gnu/packages.scm
index d22c992bb1..4e4282645a 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -24,6 +24,7 @@
   #:use-module (guix packages)
   #:use-module (guix ui)
   #:use-module (guix utils)
+  #:use-module (guix diagnostics)
   #:use-module (guix discovery)
   #:use-module (guix memoization)
   #:use-module ((guix build utils)
@@ -92,9 +93,8 @@
 (define (search-patch file-name)
   "Search the patch FILE-NAME.  Raise an error if not found."
   (or (search-path (%patch-path) file-name)
-      (raise (condition
-              (&message (message (format #f (G_ "~a: patch not found")
-                                         file-name)))))))
+      (raise (formatted-message (G_ "~a: patch not found")
+                                file-name))))
 
 (define-syntax-rule (search-patches file-name ...)
   "Return the list of absolute file names corresponding to each
diff --git a/gnu/services.scm b/gnu/services.scm
index 6509a9014e..399a432e3f 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -30,7 +30,7 @@
   #:use-module (guix describe)
   #:use-module (guix sets)
   #:use-module (guix ui)
-  #:use-module ((guix utils) #:select (source-properties->location))
+  #:use-module (guix diagnostics)
   #:autoload   (guix openpgp) (openpgp-format-fingerprint)
   #:use-module (guix modules)
   #:use-module (gnu packages base)
@@ -242,13 +242,13 @@ TYPE does not have a default value, an error is raised."
     (if (eq? default &no-default-value)
         (let ((location (source-properties->location location)))
           (raise
-           (condition
-            (&missing-value-service-error (type type) (location location))
-            (&message
-             (message (format #f (G_ "~a: no value specified \
+           (make-compound-condition
+            (condition
+             (&missing-value-service-error (type type) (location location)))
+            (formatted-message (G_ "~a: no value specified \
 for service of type '~a'")
-                              (location->string location)
-                              (service-type-name type)))))))
+                               (location->string location)
+                               (service-type-name type)))))
         (service type default))))
 
 (define-condition-type &service-error &error
@@ -725,10 +725,8 @@ and FILE could be \"/usr/bin/env\"."
         (() #t)
         (((file _) rest ...)
          (when (set-contains? seen file)
-           (raise (condition
-                   (&message
-                    (message (format #f (G_ "duplicate '~a' entry for /etc")
-                                     file))))))
+           (raise (formatted-message (G_ "duplicate '~a' entry for /etc")
+                                     file)))
          (loop rest (set-insert file seen))))))
 
   ;; Detect duplicates early instead of letting them through, eventually
@@ -1000,12 +998,12 @@ TARGET-TYPE; return the root service adjusted accordingly."
        vlist-null))
     (()
      (raise
-      (condition (&missing-target-service-error
-                  (service #f)
-                  (target-type target-type))
-                 (&message
-                  (message (format #f (G_ "service of type '~a' not found")
-                                   (service-type-name target-type)))))))
+      (make-compound-condition
+       (condition (&missing-target-service-error
+                   (service #f)
+                   (target-type target-type)))
+       (formatted-message (G_ "service of type '~a' not found")
+                          (service-type-name target-type)))))
     (x
      (raise
       (condition (&ambiguous-target-service-error
diff --git a/gnu/system.scm b/gnu/system.scm
index 6ae15ab23b..c8ef641695 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -1113,9 +1113,7 @@ TYPE (one of 'iso9660 or 'dce).  Return a UUID object."
   "Variant of 'locale-name->definition' that raises an error upon failure."
   (match (locale-name->definition name)
     (#f
-     (raise (condition
-             (&message
-              (message (format #f (G_ "~a: invalid locale name") name))))))
+     (raise (formatted-message (G_ "~a: invalid locale name") name)))
     (def def)))
 
 (define (operating-system-locale-directory os)
diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm
index 00f235e6b6..31c50c4e40 100644
--- a/gnu/system/mapped-devices.scm
+++ b/gnu/system/mapped-devices.scm
@@ -25,6 +25,7 @@
   #:use-module (guix i18n)
   #:use-module ((guix diagnostics)
                 #:select (source-properties->location
+                          formatted-message
                           &fix-hint
                           &error-location))
   #:use-module (gnu services)
@@ -132,13 +133,13 @@ DEVICE must be a \"/dev\" file name."
     ;; "usb_storage"), not file names (e.g., "usb-storage.ko").  This is
     ;; OK because we have machinery that accepts both the hyphen and the
     ;; underscore version.
-    (raise (condition
-            (&message
-             (message (format #f (G_ "you may need these modules \
+    (raise (make-compound-condition
+            (formatted-message (G_ "you may need these modules \
 in the initrd for ~a:~{ ~a~}")
-                              device missing)))
-            (&fix-hint
-             (hint (format #f (G_ "Try adding them to the
+                               device missing)
+            (condition
+             (&fix-hint
+              (hint (format #f (G_ "Try adding them to the
 @code{initrd-modules} field of your @code{operating-system} declaration, along
 these lines:
 
@@ -151,9 +152,10 @@ these lines:
 
 If you think this diagnostic is inaccurate, use the @option{--skip-checks}
 option of @command{guix system}.\n")
-                           missing)))
-            (&error-location
-             (location (source-properties->location location)))))))
+                            missing))))
+            (condition
+             (&error-location
+              (location (source-properties->location location))))))))
 
 
 ;;;
@@ -215,13 +217,13 @@ option of @command{guix system}.\n")
         (if (uuid? source)
             (match (find-partition-by-luks-uuid (uuid-bytevector source))
               (#f
-               (raise (condition
-                       (&message
-                        (message (format #f (G_ "no LUKS partition with UUID '~a'")
-                                         (uuid->string source))))
-                       (&error-location
-                        (location (source-properties->location
-                                   (mapped-device-location md)))))))
+               (raise (make-compound-condition
+                       (formatted-message (G_ "no LUKS partition with UUID '~a'")
+                                          (uuid->string source))
+                       (condition
+                        (&error-location
+                         (location (source-properties->location
+                                    (mapped-device-location md))))))))
               ((? string? device)
                (check-device-initrd-modules device initrd-modules location)))
             (check-device-initrd-modules source initrd-modules location)))))
diff --git a/guix/channels.scm b/guix/channels.scm
index 21a2fdb631..ad2442f50e 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -378,16 +378,16 @@ their relation.  When AUTHENTICATE? is false, CHANNEL is not authenticated."
             ;; TODO: Warn for all the channels once the authentication interface
             ;; is public.
             (when (guix-channel? channel)
-              (raise (condition
-                      (&message
-                       (message (format #f (G_ "channel '~a' lacks an \
+              (raise (make-compound-condition
+                      (formatted-message (G_ "channel '~a' lacks an \
 introduction and cannot be authenticated~%")
-                                        (channel-name channel))))
-                      (&fix-hint
-                       (hint (G_ "Add the missing introduction to your
+                                         (channel-name channel))
+                      (condition
+                       (&fix-hint
+                        (hint (G_ "Add the missing introduction to your
 channels file to address the issue.  Alternatively, you can pass
 @option{--disable-authentication}, at the risk of running unauthenticated and
-thus potentially malicious code.")))))))
+thus potentially malicious code."))))))))
         (warning (G_ "channel authentication disabled~%")))
 
     (when (guix-channel? channel)
diff --git a/guix/cve.scm b/guix/cve.scm
index 7dd9005f09..ae9cca2341 100644
--- a/guix/cve.scm
+++ b/guix/cve.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -21,6 +21,7 @@
   #:use-module (guix http-client)
   #:use-module (guix json)
   #:use-module (guix i18n)
+  #:use-module ((guix diagnostics) #:select (formatted-message))
   #:use-module (json)
   #:use-module (web uri)
   #:use-module (srfi srfi-1)
@@ -194,15 +195,11 @@ records."
       (raise (condition (&message
                          (message "invalid CVE feed")))))
     (unless (equal? format "MITRE")
-      (raise (condition
-              (&message
-               (message (format #f (G_ "unsupported CVE format: '~a'")
-                                format))))))
+      (raise (formatted-message (G_ "unsupported CVE format: '~a'")
+                                format)))
     (unless (equal? version "4.0")
-      (raise (condition
-              (&message
-               (message (format #f (G_ "unsupported CVE data version: '~a'")
-                                version))))))
+      (raise (formatted-message (G_ "unsupported CVE data version: '~a'")
+                                version)))
 
     (map json->cve-item
          (vector->list (assoc-ref alist "CVE_Items")))))
diff --git a/guix/git-authenticate.scm b/guix/git-authenticate.scm
index 6cfc7fabe1..4ab5419bd6 100644
--- a/guix/git-authenticate.scm
+++ b/guix/git-authenticate.scm
@@ -24,6 +24,7 @@
   #:use-module ((guix git)
                 #:select (commit-difference false-if-git-not-found))
   #:use-module (guix i18n)
+  #:use-module ((guix diagnostics) #:select (formatted-message))
   #:use-module (guix openpgp)
   #:use-module ((guix utils)
                 #:select (cache-directory with-atomic-file-output))
@@ -105,23 +106,21 @@ not in KEYRING."
                   (lambda _
                     (values #f #f)))))
     (unless signature
-      (raise (condition
-              (&unsigned-commit-error (commit commit-id))
-              (&message
-               (message (format #f (G_ "commit ~a lacks a signature")
-                                (oid->string commit-id)))))))
+      (raise (make-compound-condition
+              (condition (&unsigned-commit-error (commit commit-id)))
+              (formatted-message (G_ "commit ~a lacks a signature")
+                                 (oid->string commit-id)))))
 
     (let ((signature (string->openpgp-packet signature)))
       (when (memq (openpgp-signature-hash-algorithm signature)
                   `(,@disallowed-hash-algorithms md5))
-        (raise (condition
-                (&unsigned-commit-error (commit commit-id))
-                (&message
-                 (message (format #f (G_ "commit ~a has a ~a signature, \
+        (raise (make-compound-condition
+                (condition (&unsigned-commit-error (commit commit-id)))
+                (formatted-message (G_ "commit ~a has a ~a signature, \
 which is not permitted")
-                                  (oid->string commit-id)
-                                  (openpgp-signature-hash-algorithm
-                                   signature)))))))
+                                   (oid->string commit-id)
+                                   (openpgp-signature-hash-algorithm
+                                    signature)))))
 
       (with-fluids ((%default-port-encoding "UTF-8"))
         (let-values (((status data)
@@ -130,23 +129,22 @@ which is not permitted")
           (match status
             ('bad-signature
              ;; There's a signature but it's invalid.
-             (raise (condition
-                     (&signature-verification-error (commit commit-id)
-                                                    (signature signature)
-                                                    (keyring keyring))
-                     (&message
-                      (message (format #f (G_ "signature verification failed \
+             (raise (make-compound-condition
+                     (condition
+                      (&signature-verification-error (commit commit-id)
+                                                     (signature signature)
+                                                     (keyring keyring)))
+                     (formatted-message (G_ "signature verification failed \
 for commit ~a")
-                                       (oid->string commit-id)))))))
+                                        (oid->string commit-id)))))
             ('missing-key
-             (raise (condition
-                     (&missing-key-error (commit commit-id)
-                                         (signature signature))
-                     (&message
-                      (message (format #f (G_ "could not authenticate \
+             (raise (make-compound-condition
+                     (condition (&missing-key-error (commit commit-id)
+                                                    (signature signature)))
+                     (formatted-message (G_ "could not authenticate \
 commit ~a: key ~a is missing")
-                                       (oid->string commit-id)
-                                       (openpgp-format-fingerprint data)))))))
+                                        (oid->string commit-id)
+                                        (openpgp-format-fingerprint data)))))
             ('good-signature data)))))))
 
 (define (read-authorizations port)
@@ -179,13 +177,13 @@ does not specify anything, fall back to DEFAULT-AUTHORIZATIONS."
     ;; If COMMIT removes the '.guix-authorizations' file found in one of its
     ;; parents, raise an error.
     (when (parents-have-authorizations-file? commit)
-      (raise (condition
-              (&unauthorized-commit-error (commit (commit-id commit))
-                                          (signing-key #f))
-              (&message
-               (message (format #f (G_ "commit ~a attempts \
+      (raise (make-compound-condition
+              (condition
+               (&unauthorized-commit-error (commit (commit-id commit))
+                                           (signing-key #f)))
+              (formatted-message (G_ "commit ~a attempts \
 to remove '.guix-authorizations' file")
-                                (oid->string (commit-id commit)))))))))
+                                 (oid->string (commit-id commit)))))))
 
   (define (commit-authorizations commit)
     (catch 'git-error
@@ -234,16 +232,16 @@ not specify anything, fall back to DEFAULT-AUTHORIZATIONS."
   (unless (member (openpgp-public-key-fingerprint signing-key)
                   (commit-authorized-keys repository commit
                                           default-authorizations))
-    (raise (condition
-            (&unauthorized-commit-error (commit id)
-                                        (signing-key signing-key))
-            (&message
-             (message (format #f (G_ "commit ~a not signed by an authorized \
+    (raise (make-compound-condition
+            (condition
+             (&unauthorized-commit-error (commit id)
+                                         (signing-key signing-key)))
+            (formatted-message (G_ "commit ~a not signed by an authorized \
 key: ~a")
-                              (oid->string id)
-                              (openpgp-format-fingerprint
-                               (openpgp-public-key-fingerprint
-                                signing-key))))))))
+                               (oid->string id)
+                               (openpgp-format-fingerprint
+                                (openpgp-public-key-fingerprint
+                                 signing-key))))))
 
   signing-key)
 
@@ -366,13 +364,11 @@ EXPECTED-SIGNER."
      (commit-signing-key repository (commit-id commit) keyring)))
 
   (unless (bytevector=? expected-signer actual-signer)
-    (raise (condition
-            (&message
-             (message (format #f (G_ "initial commit ~a is signed by '~a' \
+    (raise (formatted-message (G_ "initial commit ~a is signed by '~a' \
 instead of '~a'")
                               (oid->string (commit-id commit))
                               (openpgp-format-fingerprint actual-signer)
-                              (openpgp-format-fingerprint expected-signer))))))))
+                              (openpgp-format-fingerprint expected-signer)))))
 
 (define* (authenticate-repository repository start signer
                                   #:key
diff --git a/guix/lint.scm b/guix/lint.scm
index e7855678ca..8a55f3e744 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -668,7 +668,12 @@ patch could not be found."
               ;; Use %make-warning, as condition-mesasge is already
               ;; translated.
               (%make-warning package (condition-message c)
-                             #:field 'patch-file-names))))
+                             #:field 'patch-file-names)))
+            ((formatted-message? c)
+             (list (%make-warning package
+                                  (apply format #f
+                                         (G_ (formatted-message-string c))
+                                         (formatted-message-arguments c))))))
     (define patches
       (match (package-source package)
         ((? origin? origin) (origin-patches origin))
@@ -955,7 +960,14 @@ descriptions maintained upstream."
                    (make-warning package
                                  (G_ "failed to create ~a derivation: ~a")
                                  (list system
-                                       (condition-message c)))))
+                                       (condition-message c))))
+                  ((formatted-message? c)
+                   (let ((str (apply format #f
+                                     (formatted-message-string c)
+                                     (formatted-message-arguments c))))
+                     (make-warning package
+                                   (G_ "failed to create ~a derivation: ~a")
+                                   (list system str)))))
           (parameterize ((%graft? #f))
             (package-derivation store package system #:graft? #f)
 
diff --git a/guix/remote.scm b/guix/remote.scm
index a227540728..f6adb22846 100644
--- a/guix/remote.scm
+++ b/guix/remote.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -20,6 +20,7 @@
   #:use-module (guix ssh)
   #:use-module (guix gexp)
   #:use-module (guix i18n)
+  #:use-module ((guix diagnostics) #:select (formatted-message))
   #:use-module (guix inferior)
   #:use-module (guix store)
   #:use-module (guix monads)
@@ -72,11 +73,9 @@ BECOME-COMMAND is given, use that to invoke the remote Guile REPL."
     (when (eof-object? (peek-char pipe))
       (let ((status (channel-get-exit-status pipe)))
         (close-port pipe)
-        (raise (condition
-                (&message
-                 (message (format #f (G_ "remote command '~{~a~^ ~}' failed \
+        (raise (formatted-message (G_ "remote command '~{~a~^ ~}' failed \
 with status ~a")
-                                  repl-command status)))))))
+                                  repl-command status))))
     pipe))
 
 (define* (%remote-eval lowered session #:optional become-command)
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/offload.scm b/guix/scripts/offload.scm
index e81b6c25f2..77ff3d2694 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -1,5 +1,5 @@
 ;;; 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>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -33,11 +33,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)
@@ -156,10 +157,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."
diff --git a/guix/ssh.scm b/guix/ssh.scm
index 418443992b..a36f72bb67 100644
--- a/guix/ssh.scm
+++ b/guix/ssh.scm
@@ -20,7 +20,7 @@
   #:use-module (guix store)
   #:use-module (guix inferior)
   #:use-module (guix i18n)
-  #:use-module ((guix diagnostics) #:select (&fix-hint))
+  #:use-module ((guix diagnostics) #:select (&fix-hint formatted-message))
   #:use-module (gcrypt pk-crypto)
   #:use-module (ssh session)
   #:use-module (ssh auth)
@@ -88,14 +88,12 @@ actual key does not match."
       ;; provided its Ed25519 key when we where expecting its RSA key.  XXX:
       ;; Guile-SSH 0.10.1 doesn't know about ed25519 keys and 'get-key-type'
       ;; returns #f in that case.
-      (raise (condition
-              (&message
-               (message (format #f (G_ "server at '~a' returned host key \
+      (raise (formatted-message (G_ "server at '~a' returned host key \
 '~a' of type '~a' instead of '~a' of type '~a'~%")
                                 (session-get session 'host)
                                 (public-key->string server)
                                 (get-key-type server)
-                                key type))))))))
+                                key type)))))
 
 (define* (open-ssh-session host #:key user port identity
                            host-key
@@ -148,12 +146,10 @@ Throw an error on failure."
            (match (authenticate-server session)
              ('ok #f)
              (reason
-              (raise (condition
-                      (&message
-                       (message (format #f (G_ "failed to authenticate \
+              (raise (formatted-message (G_ "failed to authenticate \
 server at '~a': ~a")
                                         (session-get session 'host)
-                                        reason))))))))
+                                        reason)))))
 
        ;; Use public key authentication, via the SSH agent if it's available.
        (match (userauth-public-key/auto! session)
@@ -173,10 +169,8 @@ server at '~a': ~a")
                                        host (get-error session)))))))))))
       (x
        ;; Connection failed or timeout expired.
-       (raise (condition
-               (&message
-                (message (format #f (G_ "SSH connection to '~a' failed: ~a~%")
-                                 host (get-error session))))))))))
+       (raise (formatted-message (G_ "SSH connection to '~a' failed: ~a~%")
+                                 host (get-error session)))))))
 
 (define* (remote-inferior session #:optional become-command)
   "Return a remote inferior for the given SESSION.  If BECOME-COMMAND is
@@ -187,11 +181,9 @@ given, use that to invoke the remote Guile REPL."
     (when (eof-object? (peek-char pipe))
       (let ((status (channel-get-exit-status pipe)))
         (close-port pipe)
-        (raise (condition
-                (&message
-                 (message (format #f (G_ "remote command '~{~a~^ ~}' failed \
+        (raise (formatted-message (G_ "remote command '~{~a~^ ~}' failed \
 with status ~a")
-                                  repl-command status)))))))
+                                  repl-command status))))
     (port->inferior pipe)))
 
 (define* (inferior-remote-eval exp session #:optional become-command)
diff --git a/guix/ui.scm b/guix/ui.scm
index 162eb35d26..420c9689ae 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -1796,9 +1796,7 @@ DURATION-RELATION with the current time."
          filter-by-duration)
         (else
          (raise
-          (condition (&message
-                      (message (format #f (G_ "invalid syntax: ~a~%")
-                                       str))))))))
+          (formatted-message (G_ "invalid syntax: ~a~%") str)))))
 
 (define (display-generation profile number)
   "Display a one-line summary of generation NUMBER of PROFILE."
diff --git a/guix/upstream.scm b/guix/upstream.scm
index 70cbfb45e8..ca184601b2 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -417,12 +417,13 @@ values: 'always', 'never', and 'interactive' (default)."
                       #f))))
        (match (assq method %method-updates)
          (#f
-          (raise (condition (&message
-                             (message (format #f (G_ "cannot download for \
+          (raise (make-compound-condition
+                  (formatted-message (G_ "cannot download for \
 this method: ~s")
-                                              method)))
-                            (&error-location
-                             (location (package-location package))))))
+                                     method)
+                  (condition
+                   (&error-location
+                    (location (package-location package)))))))
          ((_ . update)
           (update store package source
                   #:key-download key-download)))))
diff --git a/tests/channels.scm b/tests/channels.scm
index 55a0537e0f..1b6f640c4a 100644
--- a/tests/channels.scm
+++ b/tests/channels.scm
@@ -27,7 +27,11 @@
   #:use-module (guix sets)
   #:use-module (guix gexp)
   #:use-module ((guix diagnostics)
-                #:select (error-location? error-location location-line))
+                #:select (error-location?
+                          error-location location-line
+                          formatted-message?
+                          formatted-message-string
+                          formatted-message-arguments))
   #:use-module ((guix build utils) #:select (which))
   #:use-module (git)
   #:use-module (guix git)
@@ -415,8 +419,8 @@
              (channel (channel (url (string-append "file://" directory))
                                (name 'guix))))
 
-        (guard (c ((message-condition? c)
-                   (->bool (string-contains (condition-message c)
+        (guard (c ((formatted-message? c)
+                   (->bool (string-contains (formatted-message-string c)
                                             "introduction"))))
           (with-store store
             ;; Attempt a downgrade from NEW to OLD.
@@ -459,9 +463,15 @@
                (channel (channel (name 'example)
                                  (url (string-append "file://" directory))
                                  (introduction intro))))
-          (guard (c ((message-condition? c)
-                     (->bool (string-contains (condition-message c)
-                                              "initial commit"))))
+          (guard (c ((formatted-message? c)
+                     (and (string-contains (formatted-message-string c)
+                                           "initial commit")
+                          (equal? (formatted-message-arguments c)
+                                  (list
+                                   (oid->string (commit-id commit1))
+                                   (key-fingerprint %ed25519-public-key-file)
+                                   (key-fingerprint
+                                    %ed25519bis-public-key-file))))))
             (authenticate-channel channel directory
                                   (commit-id-string commit2)
                                   #:keyring-reference-prefix "")
diff --git a/tests/lint.scm b/tests/lint.scm
index 2f5e5623c1..95abd71378 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -334,7 +334,7 @@
      (check-patch-file-names pkg))))
 
 (test-equal "patches: not found"
-  "this-patch-does-not-exist!: patch not found"
+  "this-patch-does-not-exist!: patch not found\n"
   (single-lint-warning-message
    (let ((pkg (dummy-package
                "x"
diff --git a/tests/packages.scm b/tests/packages.scm
index 0a4bf83c40..596a2d1f83 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -618,12 +618,11 @@
          (string=? (derivation->output-path drv)
                    (package-output %store package "out")))))
 
-(test-assert "patch not found yields a run-time error"
-  (guard (c ((condition-has-type? c &message)
-             (and (string-contains (condition-message c)
-                                   "does-not-exist.patch")
-                  (string-contains (condition-message c)
-                                   "not found"))))
+(test-equal "patch not found yields a run-time error"
+  '("~a: patch not found\n" "does-not-exist.patch")
+  (guard (c ((formatted-message? c)
+             (cons (formatted-message-string c)
+                   (formatted-message-arguments c))))
     (let ((p (package
                (inherit (dummy-package "p"))
                (source (origin