branch: main
commit d3be2b99401fcb5d50151d4d7e9cf293de427530
Author: Ludovic Courtès <[email protected]>
AuthorDate: Tue Mar 18 15:38:38 2025 +0100
forges: notification: Keep going when notification handler throws.
Previously, exceptions thrown by ‘handler’ would be caught and logged
but the notification service would then exit (lacking a call to ‘loop’).
This commit fixes that and moves the catch-all ‘guard’ to only apply to
the handler.
* src/cuirass/forges/notification.scm (forge-notification-service)
[handler]: Wrap the handler from ‘forge-notification-handlers’ to catch
its exceptions.
Remove ‘guard’ from the body.
---
src/cuirass/forges/notification.scm | 99 +++++++++++++++++++------------------
1 file changed, 52 insertions(+), 47 deletions(-)
diff --git a/src/cuirass/forges/notification.scm
b/src/cuirass/forges/notification.scm
index aad9de2..4c9022b 100644
--- a/src/cuirass/forges/notification.scm
+++ b/src/cuirass/forges/notification.scm
@@ -84,7 +84,14 @@ when communcating with the forge."
'forge-type))
;; Can't be FALSE because it is checked by
;; SPAWN-FORGE-NOTIFICATION-SERVICE below.
- (define handler (assoc-ref forge-notification-handlers forge-type))
+ (define handler
+ (let ((handler (assoc-ref forge-notification-handlers forge-type)))
+ (lambda args
+ (guard (c (#t
+ (log-error "exception thrown by notification handler \
+of type '~a': ~s"
+ forge-type c)))
+ (apply handler args)))))
(let loop ((spec spec)
;; Keeps track of the evaluations related to our
@@ -114,56 +121,54 @@ when communcating with the forge."
(build-evaluation-id build)))))
(cons build build-results)))))
- (guard (c (#t ; catch all
- (log-error "forge-notification-service: ~s" c)))
- (match (get-message channel)
- (`(jobset-created ,timestamp ,jobset)
- (when (jobset-matches? jobset)
- (handler spec #:jobset-created #t))
- (loop spec evaluation-ids build-results))
+ (match (get-message channel)
+ (`(jobset-created ,timestamp ,jobset)
+ (when (jobset-matches? jobset)
+ (handler spec #:jobset-created #t))
+ (loop spec evaluation-ids build-results))
- (`(jobset-updated ,timestamp ,updated-spec)
- (if (jobset-matches? updated-spec)
- (loop updated-spec evaluation-ids build-results)
- (loop spec evaluation-ids build-results)))
+ (`(jobset-updated ,timestamp ,updated-spec)
+ (if (jobset-matches? updated-spec)
+ (loop updated-spec evaluation-ids build-results)
+ (loop spec evaluation-ids build-results)))
- (`(evaluation-started ,timestamp ,evaluation-id ,evaluated-spec)
- (when (jobset-matches? evaluated-spec)
- (handler spec #:evaluation-started evaluation-id))
- (loop spec evaluation-ids build-results))
+ (`(evaluation-started ,timestamp ,evaluation-id ,evaluated-spec)
+ (when (jobset-matches? evaluated-spec)
+ (handler spec #:evaluation-started evaluation-id))
+ (loop spec evaluation-ids build-results))
- (`(evaluation-completed ,timestamp ,evaluation-id ,evaluated-spec)
- (when (jobset-matches? evaluated-spec)
- ;; (= 0 status) is success.
- (if (= 0 (evaluation-current-status
- (db-get-evaluation evaluation-id)))
- (begin (handler spec #:evaluation-succeeded evaluation-id)
- (loop spec (cons evaluation-id evaluation-ids)
build-results))
- (begin (handler spec #:evaluation-failed evaluation-id)
- (loop spec evaluation-ids build-results))))
- (loop spec evaluation-ids build-results))
+ (`(evaluation-completed ,timestamp ,evaluation-id ,evaluated-spec)
+ (when (jobset-matches? evaluated-spec)
+ ;; (= 0 status) is success.
+ (if (= 0 (evaluation-current-status
+ (db-get-evaluation evaluation-id)))
+ (begin (handler spec #:evaluation-succeeded evaluation-id)
+ (loop spec (cons evaluation-id evaluation-ids)
build-results))
+ (begin (handler spec #:evaluation-failed evaluation-id)
+ (loop spec evaluation-ids build-results))))
+ (loop spec evaluation-ids build-results))
- (`(build-status-changed ,timestamp ,build)
- (let* ((evaluation-id (build-evaluation-id build))
- (build-results (if (build-matches? build)
- (updated-build-results (build))
- build-results))
- (summaries (map db-get-evaluation-summary
- evaluation-ids))
- (pending-builds (reduce + 0 (map
evaluation-summary-scheduled
- summaries))))
- (when (= 0 pending-builds)
- (handler spec #:build-results build-results))
- (loop spec evaluation-ids build-results)))
- ((tag (? time?) _ ...)
- ;; Since potentially many instances of this service ignore
- ;; messages with this tag (e.g., 'jobset-registered'), do not
- ;; flood logs.
- (log-debug "ignoring incoming notification of type '~a'" tag)
- (loop spec evaluation-ids build-results))
- (message
- (log-warning "ignoring malformed notification: ~s" message)
- (loop spec evaluation-ids build-results))))))))
+ (`(build-status-changed ,timestamp ,build)
+ (let* ((evaluation-id (build-evaluation-id build))
+ (build-results (if (build-matches? build)
+ (updated-build-results (build))
+ build-results))
+ (summaries (map db-get-evaluation-summary
+ evaluation-ids))
+ (pending-builds (reduce + 0 (map evaluation-summary-scheduled
+ summaries))))
+ (when (= 0 pending-builds)
+ (handler spec #:build-results build-results))
+ (loop spec evaluation-ids build-results)))
+ ((tag (? time?) _ ...)
+ ;; Since potentially many instances of this service ignore
+ ;; messages with this tag (e.g., 'jobset-registered'), do not
+ ;; flood logs.
+ (log-debug "ignoring incoming notification of type '~a'" tag)
+ (loop spec evaluation-ids build-results))
+ (message
+ (log-warning "ignoring malformed notification: ~s" message)
+ (loop spec evaluation-ids build-results)))))))
(define (spawn-forge-notification-service spec)
"Spawn a forge notification actor that communicates Cuirass events to
external
