From 1524c4d64d1e321c3cb6a5a4e3f4f77e722929ba Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Fri, 15 Mar 2024 16:58:26 +0000
Subject: Spawn cached compression fibers on the maintenance scheduler

So they don't interact with the main scheduler.
---
 nar-herder/cached-compression.scm | 24 ++++++++++++++----------
 nar-herder/server.scm             | 14 ++++++++------
 2 files changed, 22 insertions(+), 16 deletions(-)

(limited to 'nar-herder')

diff --git a/nar-herder/cached-compression.scm b/nar-herder/cached-compression.scm
index ef10e40..6148c7e 100644
--- a/nar-herder/cached-compression.scm
+++ b/nar-herder/cached-compression.scm
@@ -264,7 +264,7 @@
           nar-source
           enabled-cached-compressions
           cached-compression-min-uses
-          #:key (cached-compression-workers 2))
+          #:key (cached-compression-workers 2) scheduler)
 
   (define nar-cache-bytes-metric
     (make-gauge-metric metrics-registry
@@ -420,15 +420,19 @@
                               #:name "cached compression")))
 
       (lambda (narinfo-id)
-        (call-with-worker-thread
-         consider-nar-request-channel
-         (lambda (cached-bytes-by-compression-box)
-           (let ((in-progress-narinfo-ids
-                  (map car (list-jobs))))
-
-             (unless (member narinfo-id in-progress-narinfo-ids)
-               (process-job narinfo-id cached-bytes-by-compression-box)))
-           #t))))))
+        (spawn-fiber
+         (lambda ()
+           (call-with-worker-thread
+            consider-nar-request-channel
+            (lambda (cached-bytes-by-compression-box)
+              (let ((in-progress-narinfo-ids
+                     (map car (list-jobs))))
+
+                (unless (member narinfo-id in-progress-narinfo-ids)
+                  (process-job narinfo-id cached-bytes-by-compression-box)))
+              #t)))
+         scheduler
+         #:parallel? #t)))))
 
 (define* (make-compressed-nar database
                               nar-source
diff --git a/nar-herder/server.scm b/nar-herder/server.scm
index d84424d..b4c0ad2 100644
--- a/nar-herder/server.scm
+++ b/nar-herder/server.scm
@@ -366,11 +366,8 @@
 
                (when (and (not loop?)
                           maybe-trigger-creation-of-compressed-nars)
-                 (spawn-fiber
-                  (lambda ()
-                    (maybe-trigger-creation-of-compressed-nars
-                     (assq-ref narinfo 'id)))
-                  #:parallel? #t))
+                 (maybe-trigger-creation-of-compressed-nars
+                  (assq-ref narinfo 'id)))
 
                (when loop?
                  (log-msg logger 'WARN
@@ -619,6 +616,9 @@
          (make-gauge-metric metrics-registry "recent_changes_limit")))
     (metric-set recent-changes-metric (assq-ref opts 'recent-changes-limit)))
 
+  (define maintenance-scheduler
+    (make-scheduler #:parallelism 1))
+
   (let* ((database (setup-database (assq-ref opts 'database)
                                    metrics-registry))
          (canonical-storage (and=> (assq-ref opts 'storage)
@@ -669,7 +669,8 @@
                enabled-cached-compressions
                cached-compression-min-uses
                #:cached-compression-workers
-               (assq-ref opts 'cached-compression-workers)))))
+               (assq-ref opts 'cached-compression-workers)
+               #:scheduler scheduler))))
 
     (if (string=? (assq-ref opts 'database-dump)
                   "disabled")
@@ -771,6 +772,7 @@
 
             (log-msg 'DEBUG "finished maintenance setup")
             (wait finished?))
+          #:scheduler maintenance-scheduler
           #:hz 0
           #:parallelism 1)))
 
-- 
cgit v1.2.3