diff mbox series

[bug#50814,3/5] guix: Prepare the UI for continuable &warning exceptions.

Message ID 20211018155734.5175-3-attila@lendvai.name
State New
Headers show
Series [bug#50814,1/5] tests: Smarten up git repository testing framework. | expand

Checks

Context Check Description
cbaines/comparison success View comparision
cbaines/git branch success View Git branch
cbaines/applying patch success View Laminar job
cbaines/issue success View issue

Commit Message

Attila Lendvai Oct. 18, 2021, 3:57 p.m. UTC 
* guix/store.scm (call-with-store): Use dynamic-wind so that continuable
exceptions are not broken by being re-raised as non-continuable.  This is
needed for a later commit that uses continuable exceptions from within
git-authenticate to signal warnings to the user.  The reason for this is that
this way tests can explicitly check that a warning was signalled in certain
situations.
* guix/ui.scm (call-with-error-handling): Handle &warning type exceptions by
printing them to the user, and then continuing at the place they were
signalled at.
* guix/diagnostics.scm (emit-formatted-warning): New exported
function.
---
 guix/diagnostics.scm |  4 ++++
 guix/store.scm       |  7 +++++--
 guix/ui.scm          | 11 ++++++++++-
 3 files changed, 19 insertions(+), 3 deletions(-)
diff mbox series

Patch

diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm
index 6a792febd4..343213fb45 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?
@@ -161,6 +162,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 89a719bcfc..1b177cc952 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 1428c254b3..88940f99ef 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)
@@ -689,7 +691,14 @@  (define (port-filename* port)
     (and (not (port-closed? port))
          (port-filename port)))
 
-  (guard* (c ((package-input-error? c)
+  (guard* (c ((warning? c)
+              (if (formatted-message? c)
+                  (apply emit-formatted-warning
+                         (formatted-message-string c)
+                         (formatted-message-arguments c))
+                  (emit-formatted-warning "~a" c))
+              '())
+             ((package-input-error? c)
               (let* ((package  (package-error-package c))
                      (input    (package-error-invalid-input c))
                      (location (package-location package))