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

Retry updating cached checkouts

Browse source
This commit is contained in:
Christopher Baines 2025-05-25 16:35:18 +01:00
parent 0e09e5af2e
commit d183573f58
2 changed files with 103 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -28,6 +28,7 @@
#:use-module (git settings)
#:use-module (guix git)
#:use-module (guix channels)
#:use-module (guix-data-service utils)
#:use-module (guix-data-service database)
#:use-module (guix-data-service model git-repository)
#:use-module (guix-data-service model git-branch)
@ -121,7 +122,12 @@
;; I just want to update the cached checkout though, so trying to
;; checkout some revision is unnecessary, hence
;; just-update-cached-checkout
(just-update-cached-checkout (assq-ref git-repository-details 'url))
(retry-on-error
(lambda ()
(just-update-cached-checkout (assq-ref git-repository-details 'url)))
#:times 3
#:delay-seconds 5)
(simple-format (current-error-port)
"finished updating cached checkout for repository ~A\n"

97
guix-data-service/utils.scm
View file

@ -52,7 +52,9 @@
spawn-port-monitoring-fiber
make-queueing-channel))
make-queueing-channel
retry-on-error))
(define (call-with-time-logging action thunk)
(simple-format #t "debug: Starting ~A\n" action)
@ -183,3 +185,96 @@
(close-port sock)))
#:timeout 20))
#:unwind? #t)))))
(define* (retry-on-error f #:key times delay (delay-seconds 0)
ignore no-retry error-hook
(sleep-impl sleep))
;; TODO Remove delay
(define real-delay-seconds
(or delay-seconds
delay))
(let loop ((attempt 1))
(match (with-exception-handler
(lambda (exn)
(if (cond
((list? ignore)
(any (lambda (test)
(test exn))
ignore))
((procedure? ignore)
(ignore exn))
(else #f))
`(#t . (,exn))
(begin
(when (cond
((list? no-retry)
(any (lambda (test)
(test exn))
no-retry))
((procedure? no-retry)
(no-retry exn))
(else #f))
(raise-exception exn))
(cons #f exn))))
(lambda ()
(call-with-values f
(lambda vals
(cons #t vals))))
#:unwind? #t)
((#t . return-values)
(when (> attempt 1)
(simple-format
(current-error-port)
"retry success: ~A\n on attempt ~A of ~A\n"
f
attempt
times))
(apply values return-values))
((#f . exn)
(if (>= attempt
(- times 1))
(begin
(simple-format
(current-error-port)
"error: ~A:\n ~A,\n attempt ~A of ~A, last retry in ~A\n"
f
(call-with-output-string
(lambda (port)
(print-exception
port
#f
'%exception
(list exn))))
attempt
times
real-delay-seconds)
(when error-hook
(error-hook attempt exn))
(sleep-impl real-delay-seconds)
(simple-format
(current-error-port)
"running last retry of ~A after ~A failed attempts\n"
f
attempt)
(f))
(begin
(simple-format
(current-error-port)
"error: ~A:\n ~A,\n attempt ~A of ~A, retrying in ~A\n"
f
(call-with-output-string
(lambda (port)
(print-exception
port
#f
'%exception
(list exn))))
attempt
times
real-delay-seconds)
(when error-hook
(error-hook attempt exn))
(sleep-impl real-delay-seconds)
(loop (+ 1 attempt))))))))