aboutsummaryrefslogtreecommitdiff
path: root/guix-build-coordinator
diff options
context:
space:
mode:
authorChristopher Baines <mail@cbaines.net>2023-12-23 22:28:21 +0000
committerChristopher Baines <mail@cbaines.net>2023-12-23 22:28:21 +0000
commit9ec4c59c2ca094138b9ee639856990b755c428d2 (patch)
tree6d18d73e59ebd6564d48042480133149dcd7db58 /guix-build-coordinator
parente4af682452580298b34681d37818a16771a17c66 (diff)
downloadbuild-coordinator-9ec4c59c2ca094138b9ee639856990b755c428d2.tar
build-coordinator-9ec4c59c2ca094138b9ee639856990b755c428d2.tar.gz
Rewrite process-event
Just in case this helps to avoid the "conversion to port encoding failed" issue.
Diffstat (limited to 'guix-build-coordinator')
-rw-r--r--guix-build-coordinator/coordinator.scm112
1 files changed, 61 insertions, 51 deletions
diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index 2055c19..7ac0853 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -1085,57 +1085,67 @@
#:labels '(event)))
(define (process-event id event arguments handler)
- (let/ec cancel
- (with-exception-handler
- (lambda (exn)
- (log-msg (build-coordinator-logger build-coordinator)
- 'ERROR
- "error running " event " (" id ") hook: "
- exn)
- (let* ((stack (make-stack #t 3))
- (backtrace
- (call-with-output-string
- (lambda (port)
- (display-backtrace stack port)
- (newline port)))))
- (display
- backtrace
- (current-output-port)))
- (metric-increment failure-counter-metric
- #:label-values
- `((event . ,event)))
- (core-guile-sleep 10)
- (cancel #f))
- (lambda ()
- (log-msg (build-coordinator-logger build-coordinator)
- 'DEBUG
- "running " event " handler (id: " id
- ", arguments: " arguments ")")
- (call-with-duration-metric
- (build-coordinator-metrics-registry build-coordinator)
- "hook_duration_seconds"
- (lambda ()
- (start-stack
- 'hook
- (apply handler build-coordinator arguments)))
- #:labels '(event)
- #:label-values `((event . ,event)))))
- (log-msg (build-coordinator-logger build-coordinator)
- 'DEBUG
- event " (" id ") handler finished")
- (datastore-delete-unprocessed-hook-event datastore id)
-
- ;; If this is the hook for a successful build, once the hook
- ;; completed successfully, delete the nar files for this build.
- (when (eq? 'build-success event)
- (match arguments
- ((build-id)
- (let ((data-location (build-data-location build-id)))
- (when (file-exists? data-location)
- (delete-file-recursively data-location))))))
- (metric-increment success-counter-metric
- #:label-values
- `((event . ,event)))))
+ (log-msg (build-coordinator-logger build-coordinator)
+ 'DEBUG
+ "running " event " handler (id: " id
+ ", arguments: " arguments ")")
+ (and
+ (with-exception-handler
+ (lambda (exn)
+ (log-msg (build-coordinator-logger build-coordinator)
+ 'ERROR
+ "error running " event " (" id ") hook: "
+ exn)
+ (metric-increment failure-counter-metric
+ #:label-values
+ `((event . ,event)))
+ (sleep 10)
+ #f)
+ (lambda ()
+ (call-with-duration-metric
+ (build-coordinator-metrics-registry build-coordinator)
+ "hook_duration_seconds"
+ (lambda ()
+ (with-throw-handler #t
+ (lambda ()
+ (start-stack
+ 'hook
+ (apply handler build-coordinator arguments)))
+ (lambda (key . args)
+ (log-msg (build-coordinator-logger build-coordinator)
+ 'ERROR
+ "error running " event " (" id ") hook: "
+ key " " args)
+ (let* ((stack (make-stack #t 3))
+ (backtrace
+ (call-with-output-string
+ (lambda (port)
+ (display-backtrace stack port)
+ (newline port)))))
+ (display
+ backtrace
+ (current-output-port))))))
+ #:labels '(event)
+ #:label-values `((event . ,event)))
+ #t)
+ #:unwind? #t)
+ (begin
+ (log-msg (build-coordinator-logger build-coordinator)
+ 'DEBUG
+ event " (" id ") handler finished")
+ (datastore-delete-unprocessed-hook-event datastore id)
+
+ ;; If this is the hook for a successful build, once the hook
+ ;; completed successfully, delete the nar files for this build.
+ (when (eq? 'build-success event)
+ (match arguments
+ ((build-id)
+ (let ((data-location (build-data-location build-id)))
+ (when (file-exists? data-location)
+ (delete-file-recursively data-location))))))
+ (metric-increment success-counter-metric
+ #:label-values
+ `((event . ,event))))))
(define (single-thread-process-events event-name handler)
(let ((mtx (make-mutex))