From 7d1cc4d3252e96ad94f7caca8497478056de8972 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Fri, 8 Mar 2024 10:31:26 +0000
Subject: Attempt to avoid issues with the guix-daemon WAL

---
 guix-data-service/database.scm                    | 19 +++++++++++++++++++
 guix-data-service/jobs/load-new-guix-revision.scm | 11 +++++++++++
 2 files changed, 30 insertions(+)

diff --git a/guix-data-service/database.scm b/guix-data-service/database.scm
index 756bfef..7270e90 100644
--- a/guix-data-service/database.scm
+++ b/guix-data-service/database.scm
@@ -38,6 +38,8 @@
 
             check-test-database!
 
+            lock-advisory-session-lock
+            unlock-advisory-session-lock
             with-advisory-session-lock
             with-advisory-session-lock/log-time
             obtain-advisory-transaction-lock
@@ -282,6 +284,23 @@
      (unless (string=? name "guix_data_service_test")
        (error "tests being run against non test database")))))
 
+(define (lock-advisory-session-lock conn lock)
+  (let ((lock-number (symbol-hash lock)))
+    (exec-query conn
+                "SELECT pg_advisory_lock($1)"
+                (list (number->string lock-number)))
+    lock-number))
+
+(define (unlock-advisory-session-lock conn lock)
+  (let ((lock-number
+         (if (number? lock)
+             lock
+             (symbol-hash lock))))
+    (exec-query conn
+                "SELECT pg_advisory_lock($1)"
+                (list (number->string lock-number))))
+  #t)
+
 (define (with-advisory-session-lock conn lock f)
   (let ((lock-number (number->string (symbol-hash lock))))
     (exec-query conn
diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm
index b0493ca..f6d4292 100644
--- a/guix-data-service/jobs/load-new-guix-revision.scm
+++ b/guix-data-service/jobs/load-new-guix-revision.scm
@@ -1445,6 +1445,16 @@
       (lambda (filename)
         (put-message channel filename))))
 
+  (define lock-num
+    ;; I'm seeing problems with the guix-dameon WAL growing excessively, which
+    ;; I think is happening when processing revivions involving lots of new
+    ;; derivations. So limit the concurrency here in the hope that this'll
+    ;; help.
+    (with-time-logging "getting 'inferior-package-derivations lock"
+      (lock-advisory-session-lock
+       conn
+       'inferior-package-derivations)))
+
   (simple-format #t "debug: extract-information-from: ~A\n" store-path)
 
   (letpar& ((inferior-lint-checkers-and-warnings-data
@@ -1524,6 +1534,7 @@
                                                   pkg-to-replacement-hash-table))))))))
 
     (destroy-resource-pool inf-and-store-pool)
+    (unlock-advisory-session-lock conn lock-num)
 
     (simple-format
      #t "debug: finished loading information from inferior\n")
-- 
cgit v1.2.3