Check the WAL size more frequently when using inferiors

Since getting an inferior from the pool can take some time, it's not
sufficient to just check prior to attempting to fetch an inferior from the
pool. Instead set a timeout and check periodically.

1 files changed, 71 insertions, 54 deletions

diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm
index a7da8a8..0059f85 100644
--- a/guix-data-service/jobs/load-new-guix-revision.scm
+++ b/guix-data-service/jobs/load-new-guix-revision.scm
@@ -1785,6 +1785,46 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
         (close-connection store)
         (close-inferior inferior)))))
 
+  (define (call-with-inferior proc)
+    (define (check-wal-size)
+      (let loop ((wal-bytes
+                  (catch #t
+                    (lambda ()
+                      (stat:size (stat "/var/guix/db/db.sqlite-wal")))
+                    (lambda _ 0))))
+        (when (> wal-bytes (* 512 (expt 2 20)))
+          (simple-format #t "debug: guix-daemon WAL is large (~A), waiting\n"
+                         wal-bytes)
+
+          (sleep 30)
+          (loop (catch #t
+                  (lambda ()
+                    (stat:size (stat "/var/guix/db/db.sqlite-wal")))
+                  (lambda _ 0))))))
+
+    (let loop ()
+      (check-wal-size)
+      (match
+          (with-exception-handler
+              (lambda (exn)
+                (if (resource-pool-timeout-error? exn)
+                    'retry
+                    (raise-exception exn)))
+            (lambda ()
+              (call-with-resource-from-pool inf-and-store-pool
+                (match-lambda
+                  ((inferior . inferior-store)
+                   (call-with-values
+                       (lambda ()
+                         (proc inferior inferior-store))
+                     (lambda vals
+                       (cons 'result vals)))))
+                #:timeout 20))
+            #:unwind? #t)
+        ('retry (loop))
+        (('result . vals)
+         (apply values vals)))))
+
   (define postgresql-connection-pool
     (make-resource-pool
      (lambda ()
@@ -1824,22 +1864,6 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
          (with-resource-from-pool postgresql-connection-pool conn
            (insert-packages conn packages-data))))))
 
-  (define (check-wal-size)
-    (let loop ((wal-bytes
-                (catch #t
-                  (lambda ()
-                    (stat:size (stat "/var/guix/db/db.sqlite-wal")))
-                  (lambda _ 0))))
-      (when (> wal-bytes (* 512 (expt 2 20)))
-        (simple-format #t "debug: guix-daemon WAL is large (~A), waiting\n"
-                       wal-bytes)
-
-        (sleep 30)
-        (loop (catch #t
-                (lambda ()
-                  (stat:size (stat "/var/guix/db/db.sqlite-wal")))
-                (lambda _ 0))))))
-
   (define (extract-and-store-lint-checkers-and-warnings)
     (define inferior-lint-checkers-data
       (with-resource-from-pool inf-and-store-pool res
@@ -1869,13 +1893,11 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
                                ;; currently infeasible
                                (not (eq? checker-name 'derivation)))
                           (begin
-                            (check-wal-size)
-                            (with-resource-from-pool inf-and-store-pool res
-                              (match res
-                                ((inferior . inferior-store)
-                                 (inferior-lint-warnings inferior
-                                                         inferior-store
-                                                         checker-name))))))))
+                            (call-with-inferior
+                             (lambda (inferior inferior-store)
+                               (inferior-lint-warnings inferior
+                                                       inferior-store
+                                                       checker-name)))))))
                   inferior-lint-checkers-data)))
 
         (let ((package-ids (fibers-force package-ids-promise)))
@@ -1900,12 +1922,11 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
 
   (define (extract-and-store-package-derivations)
     (define packages-count
-      (with-resource-from-pool inf-and-store-pool res
-        (match res
-          ((inferior . inferior-store)
-           (ensure-gds-inferior-packages-defined! inferior)
+      (call-with-inferior
+       (lambda (inferior inferior-store)
+         (ensure-gds-inferior-packages-defined! inferior)
 
-           (inferior-eval '(vector-length gds-inferior-packages) inferior)))))
+         (inferior-eval '(vector-length gds-inferior-packages) inferior))))
 
     (define chunk-size 3000)
 
@@ -1916,24 +1937,22 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
           (with-time-logging
               (simple-format #f "getting derivations for ~A" (cons system target))
             (let loop ((start-index 0))
-              (check-wal-size)
               (let* ((count
                       (if (>= (+ start-index chunk-size) packages-count)
                           (- packages-count start-index)
                           chunk-size))
                      (chunk
-                      (with-resource-from-pool inf-and-store-pool res
-                        (match res
-                          ((inferior . inferior-store)
-                           (ensure-gds-inferior-packages-defined! inferior)
-
-                           (inferior-package-derivations
-                            inferior-store
-                            inferior
-                            system
-                            target
-                            start-index
-                            count))))))
+                      (call-with-inferior
+                       (lambda (inferior inferior-store)
+                         (ensure-gds-inferior-packages-defined! inferior)
+
+                         (inferior-package-derivations
+                          inferior-store
+                          inferior
+                          system
+                          target
+                          start-index
+                          count)))))
                 (vector-copy! derivations-vector
                               start-index
                               chunk)
@@ -1989,10 +2008,9 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
           (retry-on-missing-store-item
            (lambda ()
              (process-system-and-target/fiberized system target)))))
-       (with-resource-from-pool inf-and-store-pool res
-         (match res
-           ((inferior . inferior-store)
-            (inferior-fetch-system-target-pairs inferior)))))))
+      (call-with-inferior
+       (lambda (inferior inferior-store)
+         (inferior-fetch-system-target-pairs inferior))))))
 
   (define (extract-and-store-system-tests)
     (if skip-system-tests?
@@ -2000,15 +2018,14 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
           (simple-format #t "debug: skipping system tests\n")
           '())
         (let ((data-with-derivation-file-names
-               (with-resource-from-pool inf-and-store-pool res
-                 (match res
-                   ((inferior . inferior-store)
-                    (with-time-logging "getting inferior system tests"
-                      (all-inferior-system-tests
-                       inferior
-                       inferior-store
-                       guix-source
-                       commit)))))))
+               (call-with-inferior
+                (lambda (inferior inferior-store)
+                  (with-time-logging "getting inferior system tests"
+                    (all-inferior-system-tests
+                     inferior
+                     inferior-store
+                     guix-source
+                     commit))))))
           (when data-with-derivation-file-names
             (let ((data-with-derivation-ids
                    (map (match-lambda