ui: 'display-hint' quotes extra arguments for Texinfo.

Fixes <https://issues.guix.gnu.org/61201>.

Previously, common practice was to splice arbitrary strings (user names,
file names, etc.) into Texinfo snippets passed to 'display-hint'.  This
is unsafe in the general case because at signs and braces need to be
escaped to produced valid Texinfo.  This commit addresses that.

* guix/ui.scm (texinfo-quote): New procedure.
(display-hint): When ARGUMENTS is non-empty, pass it to 'texinfo-quote'
and call 'format'.
(report-unbound-variable-error, check-module-matches-file)
(display-collision-resolution-hint, run-guix-command): Remove explicit
'format' call; pass 'format' arguments as extra arguments to 'display-hint'.
* gnu/services/monitoring.scm (zabbix-front-end-config): Likewise.
* guix/scripts.scm (warn-about-disk-space): Likewise.
* guix/scripts/build.scm (%standard-cross-build-options)
(%standard-native-build-options): Likewise.
* guix/scripts/describe.scm (display-checkout-info): Likewise.
* guix/scripts/environment.scm (suggest-command-name): Likewise.
* guix/scripts/home.scm (process-command): Likewise.
* guix/scripts/home/edit.scm (service-type-not-found): Likewise.
* guix/scripts/import.scm (guix-import): Likewise.
* guix/scripts/package.scm (display-search-path-hint): Likewise.
* guix/scripts/pull.scm (build-and-install): Likewise.
* guix/scripts/shell.scm (auto-detect-manifest): Likewise.
* guix/scripts/system.scm (check-file-system-availability): Likewise.
(guix-system): Likewise.
* guix/scripts/system/edit.scm (service-type-not-found): Likewise.
* guix/status.scm (print-build-event): Likewise.

15 files changed, 85 insertions, 64 deletions

diff --git a/gnu/services/monitoring.scm b/gnu/services/monitoring.scm
index 44e2e8886c..bbf8b10f8b 100644
--- a/gnu/services/monitoring.scm
+++ b/gnu/services/monitoring.scm
@@ -662,9 +662,11 @@ $DB['PASSWORD'] = " (let ((file (location-file %location))
                               (string-append "trim(file_get_contents('"
                                              db-secret-file "'));\n"))
                           (begin
-                            (display-hint (format #f (G_ "~a:~a:~a: ~a:
+                            (display-hint (G_ "~a:~a:~a: ~a:
 Consider using @code{db-secret-file} instead of @code{db-password} for better
-security.") file line column 'zabbix-front-end-configuration))
+security.")
+                                          file line column
+                                          'zabbix-front-end-configuration)
                             (format #f "'~a';~%" db-password))))
                      "
 // Schema name. Used for IBM DB2 and PostgreSQL.
diff --git a/guix/scripts.scm b/guix/scripts.scm
index 4de8bc23b3..395df864a3 100644
--- a/guix/scripts.scm
+++ b/guix/scripts.scm
@@ -321,11 +321,11 @@ THRESHOLDS is a pair (ABSOLUTE-THRESHOLD . RELATIVE-THRESHOLD)."
                             absolute-threshold-in-bytes))
       (warning (G_ "only ~,1f GiB of free space available on ~a~%")
                (/ available 1. GiB) (%store-prefix))
-      (display-hint (format #f (G_ "Consider deleting old profile
+      (display-hint (G_ "Consider deleting old profile
 generations and collecting garbage, along these lines:
 
 @example
 guix gc --delete-generations=1m
-@end example\n"))))))
+@end example\n")))))
 
 ;;; scripts.scm ends here
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index b4437172d7..6a4a32fc0a 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2020 Marius Bakke <mbakke@fastmail.com>
 ;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net>
@@ -377,12 +377,12 @@ use '--no-offload' instead~%")))
                       arg)
                      (if closest
                          (display-hint
-                          (format #f (G_ "Did you mean @code{~a}?
+                          (G_ "Did you mean @code{~a}?
 Try @option{--list-targets} to view available targets.~%")
-                                  closest))
+                          closest)
                          (display-hint
-                          (format #f (G_ "\
-Try @option{--list-targets} to view available targets.~%"))))
+                          (G_ "\
+Try @option{--list-targets} to view available targets.~%")))
                      (exit 1))))))))
 
 (define %standard-native-build-options
@@ -404,12 +404,12 @@ Try @option{--list-targets} to view available targets.~%"))))
                                    arg)
                      (if closest
                          (display-hint
-                          (format #f (G_ "Did you mean @code{~a}?
+                          (G_ "Did you mean @code{~a}?
 Try @option{--list-systems} to view available system types.~%")
-                                  closest))
+                          closest)
                          (display-hint
-                          (format #f (G_ "\
-Try @option{--list-systems} to view available system types.~%"))))
+                          (G_ "\
+Try @option{--list-systems} to view available system types.~%")))
                      (exit 1))))))))
 
 
diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm
index 80cd0ce00a..5523aa0ec2 100644
--- a/guix/scripts/describe.scm
+++ b/guix/scripts/describe.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019, 2020, 2021, 2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
 ;;; Copyright © 2020 Ekaitz Zarraga <ekaitz@elenq.tech>
 ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
@@ -154,10 +154,10 @@ within a Git checkout."
          (channel (repository->guix-channel (dirname program))))
     (unless channel
       (report-error (G_ "failed to determine origin~%"))
-      (display-hint (format #f (G_ "Perhaps this
+      (display-hint (G_ "Perhaps this
 @command{guix} command was not obtained with @command{guix pull}?  Its version
 string is ~a.~%")
-                            %guix-version))
+                    %guix-version)
       (exit 1))
 
     (match fmt
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 46435ae48e..44cfcb4f76 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -664,8 +664,8 @@ command name."
         (let ((closest (string-closest executable available
                                        #:threshold 12)))
           (unless (or (not closest) (string=? closest executable))
-            (display-hint (format #f (G_ "Did you mean '~a'?~%")
-                                  closest)))))))))
+            (display-hint (G_ "Did you mean '~a'?~%")
+                          closest))))))))
 
 (define* (launch-environment/fork command profile manifest
                                   #:key pure? (white-list '()))
diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm
index d86094bc43..8ff8182a79 100644
--- a/guix/scripts/home.scm
+++ b/guix/scripts/home.scm
@@ -572,10 +572,10 @@ argument list and OPTS is the option alist."
          (cut import-manifest manifest destination <>))
        (info (G_ "'~a' populated with all the Home configuration files~%")
              destination)
-       (display-hint (format #f (G_ "\
+       (display-hint (G_ "\
 Run @command{guix home reconfigure ~a/home-configuration.scm} to effectively
 deploy the home environment described by these files.\n")
-                             destination))))
+                     destination)))
     ((describe)
      (let ((list-installed-regex (assoc-ref opts 'list-installed)))
        (match (generation-number %guix-home)
diff --git a/guix/scripts/home/edit.scm b/guix/scripts/home/edit.scm
index a6c05675b3..d039179a10 100644
--- a/guix/scripts/home/edit.scm
+++ b/guix/scripts/home/edit.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2022, 2023 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -40,8 +40,8 @@
                                              '()))
          (closest   (string-closest type available)))
     (unless (or (not closest) (string=? closest type))
-      (display-hint (format #f (G_ "Did you mean @code{~a}?~%")
-                            closest))))
+      (display-hint (G_ "Did you mean @code{~a}?~%")
+                    closest)))
 
   (exit 1))
 
diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm
index 2bca927d63..fe1d7a8dda 100644
--- a/guix/scripts/import.scm
+++ b/guix/scripts/import.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012-2014, 2020-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2014, 2020-2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 David Thompson <davet@gnu.org>
 ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
 ;;; Copyright © 2019, 2022 Ricardo Wurmus <rekado@elephly.net>
@@ -106,6 +106,5 @@ Run IMPORTER with ARGS.\n"))
          (let ((hint (string-closest importer importers #:threshold 3)))
            (report-error (G_ "~a: invalid importer~%") importer)
            (when hint
-             (display-hint
-              (format #f (G_ "Did you mean @code{~a}?~%") hint)))
+             (display-hint (G_ "Did you mean @code{~a}?~%") hint))
            (exit 1))))))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index b9090307ac..945e2f2cca 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com>
@@ -322,7 +322,7 @@ of manifest entries, in the context of PROFILE."
          (settings (search-path-environment-variables entries (list profile)
                                                       #:kind 'prefix)))
     (unless (null? settings)
-      (display-hint (format #f (G_ "Consider setting the necessary environment
+      (display-hint (G_ "Consider setting the necessary environment
 variables by running:
 
 @example
@@ -331,7 +331,7 @@ GUIX_PROFILE=\"~a\"
 @end example
 
 Alternately, see @command{guix package --search-paths -p ~s}.")
-                            profile profile)))))
+                    profile profile))))
 
 
 ;;;
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 7b6c58dbc3..2be8de3b9c 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013-2015, 2017-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2015, 2017-2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
 ;;; Copyright © 2020, 2021 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;;
@@ -469,9 +469,9 @@ true, display what would be built without actually building it."
             ;; Is the 'guix' command previously in $PATH the same as the new
             ;; one?  If the answer is "no", then suggest 'hash guix'.
             (unless (member guix-command new)
-              (display-hint (format #f (G_ "After setting @code{PATH}, run
+              (display-hint (G_ "After setting @code{PATH}, run
 @command{hash guix} to make sure your shell refers to @file{~a}.")
-                                    (first new))))
+                            (first new)))
             (return #f))
           (return #f)))))
 
diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm
index 64b5c2e8e9..92bbfb04d0 100644
--- a/guix/scripts/shell.scm
+++ b/guix/scripts/shell.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021-2023 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -305,16 +305,16 @@ Return the modified OPTS."
                (report-error
                 (G_ "not loading '~a' because not authorized to do so~%")
                 file)
-               (display-hint (format #f (G_ "To allow automatic loading of
+               (display-hint (G_ "To allow automatic loading of
 @file{~a} when running @command{guix shell}, you must explicitly authorize its
 directory, like so:
 
 @example
 echo ~a >> ~a
 @end example\n")
-                                     file
-                                     (dirname file)
-                                     (authorized-directory-file)))
+                             file
+                             (dirname file)
+                             (authorized-directory-file))
                (exit 1)))))))
 
 
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 6fd915cb5e..c0bc295c00 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2017, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
@@ -633,9 +633,9 @@ any, are available.  Raise an error if they're not."
                              (G_ "device '~a' not found: ~a~%")
                              device (strerror errno))
                       (unless (string-prefix? "/" device)
-                        (display-hint (format #f (G_ "If '~a' is a file system
+                        (display-hint (G_ "If '~a' is a file system
 label, write @code{(file-system-label ~s)} in your @code{device} field.")
-                                              device device)))))))
+                                      device device))))))
               literal)
     (for-each (lambda (fs)
                 (let ((label (file-system-label->string
@@ -1417,8 +1417,7 @@ argument list and OPTS is the option alist."
            (let ((hint (string-closest arg actions #:threshold 3)))
              (report-error (G_ "~a: unknown action~%") arg)
              (when hint
-               (display-hint
-                (format #f (G_ "Did you mean @code{~a}?~%") hint)))
+               (display-hint (G_ "Did you mean @code{~a}?~%") hint))
              (exit 1)))))
 
   (define (match-pair car)
diff --git a/guix/scripts/system/edit.scm b/guix/scripts/system/edit.scm
index d966ee0aaa..0afb071650 100644
--- a/guix/scripts/system/edit.scm
+++ b/guix/scripts/system/edit.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2022, 2023 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -39,8 +39,8 @@
                                         '()))
          (closest   (string-closest type available)))
     (unless (or (not closest) (string=? closest type))
-      (display-hint (format #f (G_ "Did you mean @code{~a}?~%")
-                            closest))))
+      (display-hint (G_ "Did you mean @code{~a}?~%")
+                    closest)))
 
   (exit 1))
 
diff --git a/guix/status.scm b/guix/status.scm
index 5580c80ea9..a192cd789a 100644
--- a/guix/status.scm
+++ b/guix/status.scm
@@ -533,15 +533,15 @@ substitutes being downloaded."
        (when (and (pair? properties)
                   (eq? (assq-ref properties 'type) 'profile-hook)
                   (eq? (assq-ref properties 'hook) 'package-cache))
-         (display-hint (format #f (G_ "This usually indicates a bug in one of
+         (display-hint (G_ "This usually indicates a bug in one of
 the channels you are pulling from, or some incompatibility among them.  You
 can check the build log and report the issue to the channel developers.
 
 The channels you are pulling from are: ~a.")
-                               (string-join
-                                (map symbol->string
-                                     (or (assq-ref properties 'channels)
-                                         '(guix))))))))
+                       (string-join
+                        (map symbol->string
+                             (or (assq-ref properties 'channels)
+                                 '(guix)))))))
      (match (derivation-log-file drv)
        (#f
         (format port (failure (G_ "Could not find build log for '~a'."))
diff --git a/guix/ui.scm b/guix/ui.scm
index 9f81ff3b8e..b6c3bd04ba 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -296,9 +296,22 @@ VARIABLE and return it, or #f if none was found."
 
 (define %hint-color (color BOLD CYAN))
 
-(define* (display-hint message #:optional (port (current-error-port)))
-  "Display MESSAGE, a l10n message possibly containing Texinfo markup, to
-PORT."
+(define (texinfo-quote str)
+  "Quote at signs and braces in STR to obtain its Texinfo represention."
+  (list->string
+   (string-fold-right (lambda (chr result)
+                        (if (memq chr '(#\@ #\{ #\}))
+                            (cons* #\@ chr result)
+                            (cons chr result)))
+                      '()
+                      str)))
+
+(define* (display-hint message
+                       #:key (port (current-error-port))
+                       #:rest arguments)
+  "Display MESSAGE, a l10n message possibly containing Texinfo markup and
+'format' escape, to PORT.  ARGUMENTS is a (possibly empty) list of strings or
+other objects that must match the 'format' escapes in MESSAGE."
   (define colorize
     (if (color-output? port)
         (lambda (str)
@@ -309,7 +322,16 @@ PORT."
   (display
    ;; XXX: We should arrange so that the initial indent is wider.
    (parameterize ((%text-width (max 15 (- (terminal-columns) 5))))
-     (texi->plain-text message))
+     (texi->plain-text (match arguments
+                         (() message)
+                         (_  (apply format #f message
+                                    (map (match-lambda
+                                           ((? string? str)
+                                            (texinfo-quote str))
+                                           (obj
+                                            (texinfo-quote
+                                             (object->string obj))))
+                                         arguments))))))
    port))
 
 (define* (report-unbound-variable-error args #:key frame)
@@ -324,8 +346,8 @@ arguments."
        (#f
         (display-hint (G_ "Did you forget a @code{use-modules} form?")))
        ((? module? module)
-        (display-hint (format #f (G_ "Did you forget @code{(use-modules ~a)}?")
-                              (module-name module))))))))
+        (display-hint (G_ "Did you forget @code{(use-modules ~a)}?")
+                      (module-name module)))))))
 
 (define (check-module-matches-file module file)
   "Check whether FILE starts with 'define-module MODULE' and print a hint if
@@ -334,10 +356,10 @@ it doesn't."
   ;; definitions and try loading them with 'guix build -L …', so help them
   ;; diagnose the problem.
   (define (hint)
-    (display-hint (format #f (G_ "File @file{~a} should probably start with:
+    (display-hint (G_ "File @file{~a} should probably start with:
 
 @example\n(define-module ~a)\n@end example")
-                          file module)))
+                  file module))
 
   (catch 'system-error
     (lambda ()
@@ -663,12 +685,12 @@ interpreted."
          (name1  (manifest-entry-name (top-most-entry first)))
          (name2  (manifest-entry-name (top-most-entry second))))
     (if (string=? name1 name2)
-        (display-hint (format #f (G_ "You cannot have two different versions
+        (display-hint (G_ "You cannot have two different versions
 or variants of @code{~a} in the same profile.")
-                              name1))
-        (display-hint (format #f (G_ "Try upgrading both @code{~a} and @code{~a},
+                      name1)
+        (display-hint (G_ "Try upgrading both @code{~a} and @code{~a},
 or remove one of them from the profile.")
-                              name1 name2)))))
+                      name1 name2))))
 
 ;; On Guile 3.0, in 'call-with-error-handling' we need to re-raise.  To
 ;; preserve useful backtraces in case of unhandled errors, we want that to
@@ -2226,8 +2248,7 @@ found."
              (format (current-error-port)
                      (G_ "guix: ~a: command not found~%") command)
              (when hint
-               (display-hint (format #f (G_ "Did you mean @code{~a}?")
-                                     hint)))
+               (display-hint (G_ "Did you mean @code{~a}?") hint))
              (show-guix-usage)))))
       (file
        (load file)