diff --git a/guix-data-service/poll-git-repository.scm b/guix-data-service/poll-git-repository.scm index 9554506..f25751c 100644 --- a/guix-data-service/poll-git-repository.scm +++ b/guix-data-service/poll-git-repository.scm @@ -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" diff --git a/guix-data-service/utils.scm b/guix-data-service/utils.scm index 7cd7342..84b823d 100644 --- a/guix-data-service/utils.scm +++ b/guix-data-service/utils.scm @@ -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))))))))