Open up more fibers possibilities in the coordinator

I'm looking to listen for client instructions ("build this", ...) maybe on a
UNIX socket, which looks to be possible with fibers, but doing this at the
same time as using a network socket for agent messaging requires more access
than run-server from the fibers web server module currently allows.

To get around this, patch the fibers web server run-server procedure to do
less, and do that instead in the guix-build-coordinator. This is somewhat
similar to what I think Cuirass does to allow it to do more with fibers.

This required messing with the current-fiber parameter in a couple more places
around threads, I'm not really sure why that problem has occurred now. This
current-fiber parameter issue should be resolved in the next fibers release.

One good thing with these changes is some behaviours not related to agent
communication, like triggering build allocation on startup have been moved out
of the agent communication code.

1 files changed, 66 insertions, 64 deletions

diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index b22feb6..5b57823 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -157,45 +157,46 @@
     (atomic-box-set! allocation-needed #t)
     (signal-condition-variable v))
 
-  (call-with-new-thread
-   (lambda ()
-     (while #t
-       (with-mutex mtx
-         (let ((previous-allocation-needed-value
-                (atomic-box-swap! allocation-needed #f)))
-           (when (eq? #f previous-allocation-needed-value)
-             (wait-condition-variable v mtx)
-             (atomic-box-set! allocation-needed #f)))
-         (call-with-duration-metric
-          (build-coordinator-metrics-registry build-coordinator)
-          "guixbuildcoordinator_allocate_builds_duration_seconds"
-          (lambda ()
-            (with-exception-handler
-                (lambda (exn)
-                  (simple-format
-                   (current-error-port)
-                   "build-allocator-thread: exception: ~A\n"
-                   exn)
-                  (atomic-box-set! allocation-needed #t))
-              (lambda ()
-                (with-exception-handler
-                    (lambda (exn)
-                      (with-exception-handler
-                          (lambda (exn)
-                            (simple-format
-                             (current-error-port)
-                             "exception when printing backtrace: ~A\n"
-                             exn)
+  (parameterize (((@@ (fibers internal) current-fiber) #f))
+    (call-with-new-thread
+     (lambda ()
+       (while #t
+         (with-mutex mtx
+           (let ((previous-allocation-needed-value
+                  (atomic-box-swap! allocation-needed #f)))
+             (when (eq? #f previous-allocation-needed-value)
+               (wait-condition-variable v mtx)
+               (atomic-box-set! allocation-needed #f)))
+           (call-with-duration-metric
+            (build-coordinator-metrics-registry build-coordinator)
+            "guixbuildcoordinator_allocate_builds_duration_seconds"
+            (lambda ()
+              (with-exception-handler
+                  (lambda (exn)
+                    (simple-format
+                     (current-error-port)
+                     "build-allocator-thread: exception: ~A\n"
+                     exn)
+                    (atomic-box-set! allocation-needed #t))
+                (lambda ()
+                  (with-exception-handler
+                      (lambda (exn)
+                        (with-exception-handler
+                            (lambda (exn)
+                              (simple-format
+                               (current-error-port)
+                               "exception when printing backtrace: ~A\n"
+                               exn)
+                              (backtrace)
+                              (raise-exception exn))
+                          (lambda ()
                             (backtrace)
-                            (raise-exception exn))
-                        (lambda ()
-                          (backtrace)
-                          (simple-format #t "\nfinished printing backtrace\n")
-                          (force-output)))
-                      (raise-exception exn))
-                  (lambda ()
-                    (allocate-builds build-coordinator))))
-              #:unwind? #t)))))))
+                            (simple-format #t "\nfinished printing backtrace\n")
+                            (force-output)))
+                        (raise-exception exn))
+                    (lambda ()
+                      (allocate-builds build-coordinator))))
+                #:unwind? #t))))))))
 
   trigger-build-allocation)
 
@@ -203,32 +204,33 @@
   (define datastore
     (build-coordinator-datastore build-coordinator))
 
-  (call-with-new-thread
-   (lambda ()
-     (while #t
-       (match (datastore-list-unprocessed-hook-events datastore 1)
-         (() (sleep 1))
-         (((id event arguments))
-          (catch
-            #t
-            (lambda ()
-              (apply (assq-ref (build-coordinator-hooks build-coordinator)
-                               event)
-                     build-coordinator arguments)
-              (datastore-delete-unprocessed-hook-event datastore id)
-
-              ;; If this is the hook for a successful build, once the hook
-              ;; completed successfully, delete the nar files for this build.
-              (when (eq? 'build-success event)
-                (match arguments
-                  ((build-id)
-                   (let ((data-location (build-data-location build-id)))
-                     (when (file-exists? data-location)
-                       (delete-file-recursively data-location)))))))
-            (lambda (key . args)
-              (simple-format #t "error: running ~A hook: ~A ~A\n"
-                             event key args)
-              #f)))))))
+  (parameterize (((@@ (fibers internal) current-fiber) #f))
+    (call-with-new-thread
+     (lambda ()
+       (while #t
+         (match (datastore-list-unprocessed-hook-events datastore 1)
+           (() (sleep 1))
+           (((id event arguments))
+            (catch
+              #t
+              (lambda ()
+                (apply (assq-ref (build-coordinator-hooks build-coordinator)
+                                 event)
+                       build-coordinator arguments)
+                (datastore-delete-unprocessed-hook-event datastore id)
+
+                ;; If this is the hook for a successful build, once the hook
+                ;; completed successfully, delete the nar files for this build.
+                (when (eq? 'build-success event)
+                  (match arguments
+                    ((build-id)
+                     (let ((data-location (build-data-location build-id)))
+                       (when (file-exists? data-location)
+                         (delete-file-recursively data-location)))))))
+              (lambda (key . args)
+                (simple-format #t "error: running ~A hook: ~A ~A\n"
+                               event key args)
+                #f))))))))
   #t)
 
 (define (fetch-builds build-coordinator agent)