cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Use with-exception-handler in place of with-throw-handler

Browse source
This commit is contained in:
Christopher Baines 2025-02-25 10:38:10 +00:00
parent 1da2a09cfb
commit e591346684
7 changed files with 109 additions and 98 deletions
Download patch file Download diff file Expand all files Collapse all files

42
guix-data-service/database.scm
View file

@ -180,8 +180,11 @@
(define* (with-postgresql-connection name f #:key (statement-timeout #f)) (define* (with-postgresql-connection name f #:key (statement-timeout #f))
(let ((conn (open-postgresql-connection name statement-timeout))) (let ((conn (open-postgresql-connection name statement-timeout)))
(with-throw-handler (with-exception-handler
#t (lambda (exn)
(pg-conn-finish conn)
(decrement-connection-gauge name)
(raise-exception exn))
(lambda () (lambda ()
(call-with-values (call-with-values
(lambda () (lambda ()
@ -191,10 +194,7 @@
(decrement-connection-gauge name) (decrement-connection-gauge name)
(apply values vals)))) (apply values vals)))))))
(lambda (key . args)
(pg-conn-finish conn)
(decrement-connection-gauge name)))))
(define %postgresql-connection-parameters (define %postgresql-connection-parameters
(make-parameter #f)) (make-parameter #f))
@ -209,15 +209,20 @@
#:key always-rollback?) #:key always-rollback?)
(exec-query conn "BEGIN;") (exec-query conn "BEGIN;")
(with-throw-handler #t (with-exception-handler
(lambda (exn)
(with-exception-handler
(const #f)
(lambda ()
(exec-query conn "ROLLBACK;"))
#:unwind? #t)
(raise-exception exn))
(lambda () (lambda ()
(let ((result (f conn))) (let ((result (f conn)))
(exec-query conn (if always-rollback? (exec-query conn (if always-rollback?
"ROLLBACK;" "ROLLBACK;"
"COMMIT;")) "COMMIT;"))
result)) result))))
(lambda (key . args)
(exec-query conn "ROLLBACK;"))))
(define (check-test-database! conn) (define (check-test-database! conn)
(match (exec-query conn "SELECT current_database()") (match (exec-query conn "SELECT current_database()")
@ -247,17 +252,22 @@
(exec-query conn (exec-query conn
"SELECT pg_advisory_lock($1)" "SELECT pg_advisory_lock($1)"
(list lock-number)) (list lock-number))
(with-throw-handler #t (with-exception-handler
(lambda (exn)
(with-exception-handler
(const #f)
(lambda ()
(exec-query conn
"SELECT pg_advisory_unlock($1)"
(list lock-number)))
#:unwind? #t)
(raise-exception exn))
(lambda () (lambda ()
(let ((result (f))) (let ((result (f)))
(exec-query conn (exec-query conn
"SELECT pg_advisory_unlock($1)" "SELECT pg_advisory_unlock($1)"
(list lock-number)) (list lock-number))
result)) result)))))
(lambda (key . args)
(exec-query conn
"SELECT pg_advisory_unlock($1)"
(list lock-number))))))
(define (with-advisory-session-lock/log-time conn lock f) (define (with-advisory-session-lock/log-time conn lock f)
(simple-format #t "debug: Acquiring advisory session lock: ~A\n" lock) (simple-format #t "debug: Acquiring advisory session lock: ~A\n" lock)

10
guix-data-service/poll-git-repository.scm
View file

@ -22,6 +22,7 @@
#:use-module (srfi srfi-71) #:use-module (srfi srfi-71)
#:use-module (ice-9 threads) #:use-module (ice-9 threads)
#:use-module (squee) #:use-module (squee)
#:use-module (knots)
#:use-module (git) #:use-module (git)
#:use-module (guix git) #:use-module (guix git)
#:use-module (guix channels) #:use-module (guix channels)
@ -57,11 +58,12 @@
(simple-format #t "exception when polling git repository (~A): ~A\n" (simple-format #t "exception when polling git repository (~A): ~A\n"
git-repository-id exn)) git-repository-id exn))
(lambda () (lambda ()
(with-throw-handler #t (with-exception-handler
(lambda (exn)
(print-backtrace-and-exception/knots exn)
(raise-exception exn))
(lambda () (lambda ()
(poll-git-repository conn git-repository-id)) (poll-git-repository conn git-repository-id))))
(lambda _
(backtrace))))
#:unwind? #t) #:unwind? #t)
(and=> (and=>

33
guix-data-service/substitutes.scm
View file

@ -27,6 +27,7 @@
#:use-module (guix narinfo) #:use-module (guix narinfo)
#:use-module ((guix build syscalls) #:use-module ((guix build syscalls)
#:select (set-thread-name)) #:select (set-thread-name))
#:use-module (knots)
#:use-module (guix-data-service utils) #:use-module (guix-data-service utils)
#:use-module (guix-data-service database) #:use-module (guix-data-service database)
#:use-module (guix-data-service model build) #:use-module (guix-data-service model build)
@ -56,17 +57,18 @@
(member id build-server-ids)) (member id build-server-ids))
(when lookup-all-derivations? (when lookup-all-derivations?
(simple-format #t "\nQuerying ~A\n" url) (simple-format #t "\nQuerying ~A\n" url)
(with-throw-handler #t (with-exception-handler
(lambda (exn)
(simple-format
(current-error-port)
"exception in query-build-server ~A ~A\n"
id url)
(print-backtrace-and-exception/knots exn)
(raise-exception exn))
(lambda () (lambda ()
(fetch-narinfo-files conn id url revision-commits (fetch-narinfo-files conn id url revision-commits
#:specific-outputs #:specific-outputs
outputs)) outputs)))))))
(lambda (key . args)
(simple-format
(current-error-port)
"exception in query-build-server: ~A ~A\n"
key args)
(backtrace)))))))
build-servers)))) build-servers))))
(define %narinfo-max-size (define %narinfo-max-size
@ -167,14 +169,17 @@
(sleep 1)) (sleep 1))
(while #t (while #t
(with-exception-handler
(lambda (exn)
#f)
(lambda ()
(with-exception-handler (with-exception-handler
(lambda (exn) (lambda (exn)
(simple-format (simple-format
(current-error-port) (current-error-port)
"exception in request substitute query thread: ~A\n" "exception in request substitute query thread:\n")
exn)) (print-backtrace-and-exception/knots exn)
(lambda () (raise-exception exn))
(with-throw-handler #t
(lambda () (lambda ()
(with-postgresql-connection (with-postgresql-connection
"request-substitute-query-thread" "request-substitute-query-thread"
@ -200,9 +205,7 @@
conn conn
(list build-server-id) (list build-server-id)
#f #f
outputs)))))))) outputs))))))))))
(lambda _
(backtrace))))
#:unwind? #t)))) #:unwind? #t))))
(call-with-new-thread (call-with-new-thread

11
guix-data-service/web/build-server/controller.scm
View file

@ -22,6 +22,7 @@
#:use-module (json) #:use-module (json)
#:use-module (squee) #:use-module (squee)
#:use-module (fibers) #:use-module (fibers)
#:use-module (knots)
#:use-module (knots resource-pool) #:use-module (knots resource-pool)
#:use-module (prometheus) #:use-module (prometheus)
#:use-module (guix-data-service utils) #:use-module (guix-data-service utils)
@ -134,12 +135,12 @@
"exception in build event handler: ~A\n" "exception in build event handler: ~A\n"
exn)) exn))
(lambda () (lambda ()
(with-throw-handler #t (with-exception-handler
(lambda (exn)
(print-backtrace-and-exception/knots exn)
(raise-exception exn))
(lambda () (lambda ()
(handler conn)) (handler conn))))
(lambda _
(display (backtrace) (current-error-port))
(display "\n" (current-error-port)))))
#:unwind? #t)) #:unwind? #t))
#:timeout #f)))) #:timeout #f))))

24
scripts/guix-data-service-process-branch-updated-email.in
View file

@ -27,6 +27,7 @@
(rnrs bytevectors) (rnrs bytevectors)
(squee) (squee)
(email email) (email email)
(knots)
(guix-data-service database) (guix-data-service database)
(guix-data-service branch-updated-emails)) (guix-data-service branch-updated-emails))
@ -35,20 +36,17 @@
(lambda (conn) (lambda (conn)
(let* ((email-bytevector (let* ((email-bytevector
(get-bytevector-all (current-input-port)))) (get-bytevector-all (current-input-port))))
(catch (with-exception-handler
#t (lambda _ #f)
(lambda () (lambda ()
(with-throw-handler #t (with-exception-handler
(lambda (exn)
(display "\nerror: while parsing email\n"
(current-error-port))
(print-backtrace-and-exception/knots exn)
(raise-exception exn))
(lambda () (lambda ()
(enqueue-job-for-email (enqueue-job-for-email
conn conn
(parse-email email-bytevector))) (parse-email email-bytevector)))))
(lambda (key . args) #:unwind? #t))))
(display "\nerror: while parsing email\n"
(current-error-port))
(simple-format (current-error-port)
"~A: ~A\n\n"
key
args)
(display-backtrace (make-stack #t) (current-error-port)))))
(lambda (key . args) #f)))))

25
scripts/guix-data-service-process-branch-updated-mbox.in
View file

@ -27,6 +27,7 @@
(rnrs bytevectors) (rnrs bytevectors)
(squee) (squee)
(email email) (email email)
(knots)
(guix-data-service database) (guix-data-service database)
(guix-data-service model git-repository) (guix-data-service model git-repository)
(guix-data-service branch-updated-emails)) (guix-data-service branch-updated-emails))
@ -52,23 +53,21 @@ a x_git_repo_header value\n"
(for-each (for-each
(lambda (email-bytevector) (lambda (email-bytevector)
(display "." (current-error-port)) (display "." (current-error-port))
(catch (with-exception-handler
#t (lambda (exn)
#f)
(lambda () (lambda ()
(with-throw-handler #t (with-exception-handler
(lambda (exn)
(display "\nerror: while parsing email\n"
(current-error-port))
(print-backtrace-and-exception/knots exn)
(raise-exception exn))
(lambda () (lambda ()
(enqueue-job-for-email (enqueue-job-for-email
conn conn
(parse-email email-bytevector))) (parse-email email-bytevector)))))
(lambda (key . args) #:unwind? #t))
(display "\nerror: while parsing email\n"
(current-error-port))
(simple-format (current-error-port)
"~A: ~A\n\n"
key
args)
(display-backtrace (make-stack #t) (current-error-port)))))
(lambda (key . args) #f)))
(call-with-input-file file (call-with-input-file file
mbox->emails)) mbox->emails))

14
scripts/guix-data-service-process-jobs.in
View file

@ -25,6 +25,7 @@
(use-modules (srfi srfi-1) (use-modules (srfi srfi-1)
(srfi srfi-37) (srfi srfi-37)
(ice-9 match) (ice-9 match)
(knots)
(guix-data-service database) (guix-data-service database)
(guix-data-service jobs)) (guix-data-service jobs))
@ -110,13 +111,12 @@
(simple-format #t "Ready to process jobs...\n") (simple-format #t "Ready to process jobs...\n")
(with-exception-handler (with-exception-handler
(lambda (exn) (lambda (exn)
(simple-format
(current-error-port)
"exception: ~A\n"
exn)
(exit 1)) (exit 1))
(lambda () (lambda ()
(with-throw-handler #t (with-exception-handler
(lambda (exn)
(print-backtrace-and-exception/knots exn)
(raise-exception exn))
(lambda () (lambda ()
(process-jobs (process-jobs
conn conn
@ -140,7 +140,5 @@
#:free-space-requirement #:free-space-requirement
(assq-ref opts 'free-space-requirement) (assq-ref opts 'free-space-requirement)
#:timeout #:timeout
(assq-ref opts 'timeout))) (assq-ref opts 'timeout)))))
(lambda _
(backtrace))))
#:unwind? #t)))) #:unwind? #t))))