Retry updating cached checkouts

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"

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))))))))