From 485b85c40504dd8c53505365e0b46d7afc87b33b Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Sat, 22 Apr 2023 12:58:01 +0100
Subject: Don't use exceptions for blocked wal checkpoints

As this clutters the output.
---
 guix-build-coordinator/datastore/sqlite.scm | 100 +++++++++++++++-------------
 1 file changed, 54 insertions(+), 46 deletions(-)

diff --git a/guix-build-coordinator/datastore/sqlite.scm b/guix-build-coordinator/datastore/sqlite.scm
index eab43b7..4ad42ed 100644
--- a/guix-build-coordinator/datastore/sqlite.scm
+++ b/guix-build-coordinator/datastore/sqlite.scm
@@ -242,55 +242,56 @@
   (define wal-size-threshold
     (* 5 MiB))
 
-  (let ((checkpoint-duration-metric-name
-         "datastore_wal_checkpoint_duration_seconds"))
-
-    (when (and maybe-truncate-wal?
-               (> (wal-size) wal-size-threshold))
-      (call-with-duration-metric
-       metrics-registry
-       checkpoint-duration-metric-name
-       (lambda ()
-         (let ((statement
-                (sqlite-prepare
-                 db
-                 "PRAGMA wal_checkpoint(TRUNCATE);")))
-           (match (sqlite-step-and-finalize statement)
-             (#(blocked? modified-page-count pages-moved-to-db)
-              (if (= blocked? 1)
-                  (begin
-                    (simple-format
-                     (current-error-port)
-                     "warning: wal checkpoint blocked\n")
-                    (error "wal checkpoint blocked"))
-                  (simple-format
-                   (current-error-port)
-                   "wal checkpoint completed (~A, ~A)\n"
-                   modified-page-count
-                   pages-moved-to-db))))))))
-
-    (call-with-duration-metric
-     metrics-registry
-     "datastore_optimize_duration_seconds"
-     (lambda ()
-       (sqlite-exec db
-                    "
+  (and
+   (let ((checkpoint-duration-metric-name
+          "datastore_wal_checkpoint_duration_seconds"))
+
+     (if (and maybe-truncate-wal?
+              (> (wal-size) wal-size-threshold))
+         (call-with-duration-metric
+          metrics-registry
+          checkpoint-duration-metric-name
+          (lambda ()
+            (let ((statement
+                   (sqlite-prepare
+                    db
+                    "PRAGMA wal_checkpoint(TRUNCATE);")))
+              (match (sqlite-step-and-finalize statement)
+                (#(blocked? modified-page-count pages-moved-to-db)
+                 (if (= blocked? 1)
+                     (begin
+                       (simple-format
+                        (current-error-port)
+                        "warning: wal checkpoint blocked\n")
+                       #f)
+                     (begin
+                       (simple-format
+                        (current-error-port)
+                        "wal checkpoint completed (~A, ~A)\n"
+                        modified-page-count
+                        pages-moved-to-db)
+                       #t)))))))
+         #t))
+
+   (call-with-duration-metric
+    metrics-registry
+    "datastore_optimize_duration_seconds"
+    (lambda ()
+      (sqlite-exec db
+                   "
 PRAGMA analysis_limit=1000;
-PRAGMA optimize;")))))
+PRAGMA optimize;")
+      #t))))
 
 (define-method (datastore-optimize
                 (datastore <sqlite-datastore>))
-  (retry-on-error
-   (lambda ()
-     (call-with-worker-thread
-      (slot-ref datastore 'worker-writer-thread-channel)
-      (lambda (db)
-        (db-optimize
-         db
-         (slot-ref datastore 'database-file)
-         (slot-ref datastore 'metrics-registry)))))
-   #:times 10
-   #:delay 9))
+  (call-with-worker-thread
+   (slot-ref datastore 'worker-writer-thread-channel)
+   (lambda (db)
+     (db-optimize
+      db
+      (slot-ref datastore 'database-file)
+      (slot-ref datastore 'metrics-registry)))))
 
 (define-method (datastore-spawn-fibers
                 (datastore <sqlite-datastore>))
@@ -306,7 +307,14 @@ PRAGMA optimize;")))))
          (lambda ()
            (with-time-logging
                "performing regular database maintenance"
-             (datastore-optimize datastore)))
+             (let loop ((result (datastore-optimize datastore))
+                        (retry-count 0))
+               (if result
+                   #t
+                   (if (< retry-count 10)
+                       (loop (datastore-optimize datastore)
+                             (+ 1 retry-count))
+                       (error "unable to perform WAL checkpoint"))))))
          #:unwind? #t)))
    #:parallel? #t))
 
-- 
cgit v1.2.3