Move most maintenance activity to fibers

On a single separate thread. This will allow for spawning fibers for
various maintenance actions.

3 files changed, 64 insertions, 63 deletions

diff --git a/nar-herder/mirror.scm b/nar-herder/mirror.scm
index ab46bf0..a87b898 100644
--- a/nar-herder/mirror.scm
+++ b/nar-herder/mirror.scm
@@ -30,6 +30,7 @@
   #:use-module (prometheus)
   #:use-module (logging logger)
   #:use-module (json)
+  #:use-module (fibers)
   #:use-module (guix narinfo)
   #:use-module ((guix build syscalls)
                 #:select (set-thread-name))
@@ -37,10 +38,10 @@
   #:use-module (nar-herder utils)
   #:use-module (nar-herder database)
   #:use-module (nar-herder storage)
-  #:export (start-fetch-changes-thread))
+  #:export (start-fetch-changes-fiber))
 
-(define (start-fetch-changes-thread database storage-root
-                                    mirror metrics-registry)
+(define (start-fetch-changes-fiber database storage-root
+                                   mirror metrics-registry)
   (define nar-files-metric
     (or (metrics-registry-fetch-metric metrics-registry
                                        "nar_files_total")
@@ -165,13 +166,8 @@
                              (response-code response)
                              (utf8->string body))))))))
 
-  (call-with-new-thread
+  (spawn-fiber
    (lambda ()
-     (catch 'system-error
-       (lambda ()
-         (set-thread-name "nh fetch changes"))
-       (const #t))
-
      ;; This will initialise the nar_files_total metric
      (get-nar-files database storage-root metrics-registry)
 
diff --git a/nar-herder/storage.scm b/nar-herder/storage.scm
index 2c8fde3..8c1fd78 100644
--- a/nar-herder/storage.scm
+++ b/nar-herder/storage.scm
@@ -45,8 +45,8 @@
 
             check-storage
 
-            start-nar-removal-thread
-            start-mirroring-thread))
+            start-nar-removal-fiber
+            start-mirroring-fiber))
 
 (define (store-item-in-local-storage? database storage-root hash)
   (let ((narinfo-files (database-select-narinfo-files database hash)))
@@ -376,10 +376,10 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
       (proc (open-socket-for-uri/cached uri)))
     #:unwind? #t))
 
-(define (start-nar-removal-thread database
-                                  storage-root storage-limit
-                                  metrics-registry
-                                  nar-removal-criteria)
+(define (start-nar-removal-fiber database
+                                 storage-root storage-limit
+                                 metrics-registry
+                                 nar-removal-criteria)
   (define storage-size-metric
     (make-gauge-metric metrics-registry
                        "storage_size_bytes"))
@@ -486,13 +486,8 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
   (when (null? nar-removal-criteria)
     (error "must be some removal criteria"))
 
-  (call-with-new-thread
+  (spawn-fiber
    (lambda ()
-     (catch 'system-error
-       (lambda ()
-         (set-thread-name "nh remove"))
-       (const #t))
-
      (while #t
        (with-exception-handler
            (lambda (exn)
@@ -502,8 +497,8 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
 
        (sleep 300)))))
 
-(define (start-mirroring-thread database mirror storage-limit storage-root
-                                metrics-registry)
+(define (start-mirroring-fiber database mirror storage-limit storage-root
+                               metrics-registry)
 
   (define no-storage-limit?
     (not (integer? storage-limit)))
@@ -702,13 +697,8 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
         (log-msg 'DEBUG "finished mirror pass (any change? " any-change? ")")
         any-change?)))
 
-  (call-with-new-thread
+  (spawn-fiber
    (lambda ()
-     (catch 'system-error
-       (lambda ()
-         (set-thread-name "nh mirror"))
-       (const #t))
-
      (while #t
        (unless (with-exception-handler
                    (lambda (exn)
diff --git a/scripts/nar-herder.in b/scripts/nar-herder.in
index 59df42e..ac3002b 100644
--- a/scripts/nar-herder.in
+++ b/scripts/nar-herder.in
@@ -39,6 +39,7 @@
              (ice-9 ftw)
              (ice-9 match)
              (ice-9 format)
+             (ice-9 threads)
              (ice-9 suspendable-ports)
              (web uri)
              (web client)
@@ -57,6 +58,7 @@
              (guix derivations)
              ((guix store) #:select (store-path-hash-part))
              ((guix build utils) #:select (dump-port))
+             ((guix build syscalls) #:select (set-thread-name))
              (nar-herder utils)
              (nar-herder database)
              (nar-herder recent-changes)
@@ -614,46 +616,59 @@
         (* 24 3600)                     ; 24 hours
         (assq-ref opts 'recent-changes-limit))
 
-       (and=> (assq-ref opts 'mirror)
-              (lambda (mirror)
-                (start-fetch-changes-thread database
+       (let ((finished? (make-condition)))
+         (call-with-new-thread
+          (lambda ()
+            (catch 'system-error
+              (lambda ()
+                (set-thread-name "maintenance"))
+              (const #t))
+
+            (run-fibers
+             (lambda ()
+               (and=> (assq-ref opts 'mirror)
+                      (lambda (mirror)
+                        (start-fetch-changes-fiber database
+                                                   canonical-storage
+                                                   mirror
+                                                   metrics-registry)
+
+                        (when (assq-ref opts 'storage)
+                          (start-mirroring-fiber database
+                                                 mirror
+                                                 (assq-ref opts 'storage-limit)
+                                                 canonical-storage
+                                                 metrics-registry))))
+
+
+               (let ((nar-removal-criteria
+                      (filter-map
+                       (match-lambda
+                         ((key . val)
+                          (if (eq? key 'storage-nar-removal-criteria)
+                              val
+                              #f)))
+                       opts)))
+                 (when (and (assq-ref opts 'storage)
+                            (number? (assq-ref opts 'storage-limit))
+                            (not (null? nar-removal-criteria)))
+                   (start-nar-removal-fiber database
                                             canonical-storage
-                                            mirror
-                                            metrics-registry)
-
-                (when (assq-ref opts 'storage)
-                  (start-mirroring-thread database
-                                          mirror
-                                          (assq-ref opts 'storage-limit)
-                                          canonical-storage
-                                          metrics-registry))))
-
-
-       (let ((nar-removal-criteria
-              (filter-map
-               (match-lambda
-                 ((key . val)
-                  (if (eq? key 'storage-nar-removal-criteria)
-                      val
-                      #f)))
-               opts)))
-         (when (and (assq-ref opts 'storage)
-                    (number? (assq-ref opts 'storage-limit))
-                    (not (null? nar-removal-criteria)))
-           (start-nar-removal-thread database
-                                     canonical-storage
-                                     (assq-ref opts 'storage-limit)
-                                     metrics-registry
-                                     nar-removal-criteria)))
-
-       (log-msg 'INFO "starting server, listening on "
-                (assq-ref opts 'host) ":" (assq-ref opts 'port))
+                                            (assq-ref opts 'storage-limit)
+                                            metrics-registry
+                                            nar-removal-criteria)))
+
+               (wait finished?))
+             #:hz 0
+             #:parallelism 1)))
 
-       (let ((finished? (make-condition)))
          (call-with-sigint
           (lambda ()
             (run-fibers
              (lambda ()
+               (log-msg 'INFO "starting server, listening on "
+                        (assq-ref opts 'host) ":" (assq-ref opts 'port))
+
                (run-server/patched
                 (make-request-handler database
                                       canonical-storage