[bug#52724] [PATCH v2] guix: Prepare the UI for continuable &warning exceptions.

[Attila Lendvai]

* guix/store.scm (call-with-store): Use RAISE-CONTINUABLE to resignal
exceptions.  This is needed for a later commit that uses continuable
exceptions from within GIT-AUTHENTICATE to signal warnings that are meant to
be displayed to the user.  The reason for this is that this way unit tests
can use a handler to explicitly check that a warning was indeed signalled.
* guix/ui.scm (call-with-error-handling): Handle &WARNING type exceptions by
printing them to the user, and then continuing at the place where they were
signalled at.
(maybe-display-fix-hint): New procedure.
* guix/diagnostics.scm (emit-formatted-warning): New procedure. Exported.
---

thanks for the feedback! i've applied everything you pointed out.

i didn't merge it with the formatted-message? entry, because i'd
like a place where every warning ends up. instead, i have factored
out a maybe-display-fix-hint function, and used it there, too.

> Also, you can't meaningfully stringify a condition.

in case of warnings, you're right. i just have a knee-jerk reaction
against silently swallowing errors, and it kicked in here, too.

> Also, a test or two would be great

i don't really know how to write a test for this.

the way i was testing it is that a future commit will add a warning
when the channel intro commit doesn't set up .guix-authorizations properly,
and i had set up a branch from which i tried to pull.

 guix/diagnostics.scm |  4 ++++
 guix/store.scm       |  7 +++++--
 guix/ui.scm          | 30 ++++++++++++++++++++++++------
 3 files changed, 33 insertions(+), 8 deletions(-)

diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm
index 337a73c1a2..8e13e5e30a 100644
--- a/guix/diagnostics.scm
+++ b/guix/diagnostics.scm
@@ -48,6 +48,7 @@ (define-module (guix diagnostics)
             formatted-message?
             formatted-message-string
             formatted-message-arguments
+            emit-formatted-warning
 
             &fix-hint
             fix-hint?
@@ -163,6 +164,9 @@ (define-syntax-rule (leave args ...)
     (report-error args ...)
     (exit 1)))
 
+(define* (emit-formatted-warning fmt . args)
+  (emit-diagnostic fmt args #:prefix (G_ "warning: ") #:colors %warning-color))
+
 (define* (emit-diagnostic fmt args
                           #:key location (colors (color)) (prefix ""))
   "Report diagnostic message FMT with the given ARGS and the specified
diff --git a/guix/store.scm b/guix/store.scm
index a93e9596d9..a2b3b2f05a 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -34,6 +34,8 @@ (define-module (guix store)
   #:use-module (guix profiling)
   #:autoload   (guix build syscalls) (terminal-columns)
   #:use-module (rnrs bytevectors)
+  #:use-module ((rnrs conditions) #:select (warning?))
+  #:use-module ((rnrs exceptions) #:select (raise-continuable))
   #:use-module (ice-9 binary-ports)
   #:use-module ((ice-9 control) #:select (let/ec))
   #:use-module (ice-9 atomic)
@@ -661,8 +663,9 @@ (define (thunk)
             (apply values results)))))
 
     (with-exception-handler (lambda (exception)
-                              (close-connection store)
-                              (raise-exception exception))
+                              (unless (warning? exception)
+                                (close-connection store))
+                              (raise-continuable exception))
       thunk)))
 
 (define-syntax-rule (with-store store exp ...)
diff --git a/guix/ui.scm b/guix/ui.scm
index bd999103ff..96f9db722c 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -69,6 +69,8 @@ (define-module (guix ui)
   #:use-module (srfi srfi-31)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
+  #:use-module ((rnrs conditions)
+                #:select (warning?))
   #:autoload   (ice-9 ftw)  (scandir)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
@@ -299,6 +301,11 @@ (define (module<? m1 m2)
 
 (define %hint-color (color BOLD CYAN))
 
+(define (maybe-display-fix-hint obj)
+  (when (fix-hint? obj)
+    (display-hint (condition-fix-hint obj)))
+  obj)
+
 (define* (display-hint message #:optional (port (current-error-port)))
   "Display MESSAGE, a l10n message possibly containing Texinfo markup, to
 PORT."
@@ -398,8 +405,7 @@ (define* (report-load-error file args #:optional frame)
                    (formatted-message-arguments obj)))
            (else
             (report-error (G_ "exception thrown: ~s~%") obj)))
-     (when (fix-hint? obj)
-       (display-hint (condition-fix-hint obj))))
+     (maybe-display-fix-hint obj))
     ((key args ...)
      (report-error (G_ "failed to load '~a':~%") file)
      (match args
@@ -796,13 +802,26 @@ (define (manifest-entry-output* entry)
                      (cons (invoke-error-program c)
                            (invoke-error-arguments c))))
 
+             ((warning? c)
+              (match c
+                ((? formatted-message? c)
+                 (apply emit-formatted-warning
+                        (formatted-message-string c)
+                        (formatted-message-arguments c)))
+                (_
+                 ;; Ignore warnings that we cannot display in a meaningful way
+                 ;; to the user.  As a developer, you may peek using:
+                 ;; (emit-formatted-warning "~a" c)
+                 (values)))
+              (maybe-display-fix-hint c)
+              (values))
+
              ((formatted-message? c)
               (apply report-error
                      (and (error-location? c) (error-location c))
                      (gettext (formatted-message-string c) %gettext-domain)
                      (formatted-message-arguments c))
-              (when (fix-hint? c)
-                (display-hint (condition-fix-hint c)))
+              (maybe-display-fix-hint c)
               (exit 1))
 
              ;; On Guile 3.0.0, exceptions such as 'unbound-variable' are
@@ -826,8 +845,7 @@ (define (manifest-entry-output* entry)
               (report-error (and (error-location? c) (error-location c))
                             (G_ "~a~%")
                             (gettext (condition-message c) %gettext-domain))
-              (when (fix-hint? c)
-                (display-hint (condition-fix-hint c)))
+              (maybe-display-fix-hint c)
               (exit 1)))
       (thunk)))
 
-- 
2.34.0