[no subject]

[Ludovic Courtès]

branch: master
commit 93d51df182756fe3bbb82b149e230a06eceafedb
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Thu Jun 1 23:56:34 2023 +0200

    base: Catch all errors occurring while processing a spec.
    
    Previously, an error such as 'system-error would be uncaught, which
    would (presumably) lead 'cuirass register' to exit right away, via
    'essential-task'.
    
    * src/cuirass/base.scm (process-specs): Use 'with-exception-handler' +
    'let/ec' instead of 'catch'.  Report 'system-error' exceptions in
    detail.  Print other exceptions as well.
---
 src/cuirass/base.scm | 40 +++++++++++++++++++++++++++++-----------
 1 file changed, 29 insertions(+), 11 deletions(-)

diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index ed768c6..d3e2d3b 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -41,9 +41,7 @@
   #:use-module ((guix config) #:select (%state-directory))
   #:use-module (git)
   #:use-module (ice-9 binary-ports)
-  #:use-module ((ice-9 suspendable-ports)
-                #:select (current-read-waiter
-                          current-write-waiter))
+  #:use-module (ice-9 control)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (ice-9 popen)
@@ -619,6 +617,9 @@ specification."
              (db-get-latest-checkout name channel eval-id)))
          channels)))
 
+(define exception-with-kind-and-args?
+  (exception-predicate &exception-with-kind-and-args))
+
 (define (process-specs jobspecs)
   "Evaluate and build JOBSPECS and store results in the database."
   (define (new-eval? spec)
@@ -674,12 +675,29 @@ specification."
 
   (for-each (lambda (spec)
               ;; Catch Git errors, which might be transient, and keep going.
-              (catch 'git-error
-                (lambda ()
-                  (and (new-eval? spec)
-                       (process spec)))
-                (lambda (key error)
-                  (log-error "Git error while fetching inputs of '~a': ~s~%"
-                             (specification-name spec)
-                             (git-error-message error)))))
+              (let/ec return
+                (with-exception-handler
+                    (lambda (exception)
+                      (if (exception-with-kind-and-args? exception)
+                          (match (exception-kind exception)
+                            ('git-error
+                             (log-error "Git error while fetching inputs of 
'~a': ~a"
+                                        (specification-name spec)
+                                        (git-error-message
+                                         (first (exception-args exception)))))
+                            ('system-error
+                             (log-error "while processing '~a': ~s"
+                                        (strerror
+                                         (system-error-errno
+                                          (cons 'system-error
+                                                (exception-args exception))))))
+                            (kind
+                             (log-error
+                              (log-error "uncaught '~a' exception: ~s"
+                                         kind (exception-args exception)))))
+                          (log-error "uncaught exception: ~s" exception))
+                      (return #f))
+                  (lambda ()
+                    (and (new-eval? spec)
+                         (process spec))))))
             jobspecs))