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, 89 insertions, 13 deletions

diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in
index 02ae22d..c7267e9 100644
--- a/scripts/guix-build-coordinator.in
+++ b/scripts/guix-build-coordinator.in
@@ -26,6 +26,8 @@
              (srfi srfi-37)
              (ice-9 match)
              (web uri)
+             (fibers)
+             (fibers conditions)
              ((guix ui) #:select (read/eval))
              (guix derivations)
              (guix-build-coordinator hooks)
@@ -180,6 +182,41 @@
       (alist-delete 'arguments result)))
    defaults))
 
+;; Patch the fibers web server to allow running multiple servers
+
+(let ((fibers-web-server-module
+       (resolve-module '(fibers web server))))
+
+  (define set-nonblocking!
+    (module-ref fibers-web-server-module 'set-nonblocking!))
+
+  (define make-default-socket
+    (module-ref fibers-web-server-module 'make-default-socket))
+
+  (define socket-loop
+    (module-ref fibers-web-server-module 'socket-loop))
+
+  (define* (run-server/patched handler #:key
+                               (host #f)
+                               (family AF_INET)
+                               (addr (if host
+                                         (inet-pton family host)
+                                         INADDR_LOOPBACK))
+                               (port 8080)
+                               (socket (make-default-socket family addr port)))
+    ;; We use a large backlog by default.  If the server is suddenly hit
+    ;; with a number of connections on a small backlog, clients won't
+    ;; receive confirmation for their SYN, leading them to retry --
+    ;; probably successfully, but with a large latency.
+    (listen socket 1024)
+    (set-nonblocking! socket)
+    (sigaction SIGPIPE SIG_IGN)
+    (spawn-fiber (lambda () (socket-loop socket handler))))
+
+  (module-set! (resolve-module '(fibers web server))
+               'run-server
+               run-server/patched))
+
 (setvbuf (current-output-port) 'line)
 (setvbuf (current-error-port) 'line)
 
@@ -374,16 +411,55 @@ processed?:      ~A
      (parameterize ((%show-error-details
                      (assoc-ref opts 'show-error-details)))
 
-       (let ((agent-communication-uri
-              (string->uri (assq-ref opts 'agent-communication))))
-         (match (uri-scheme agent-communication-uri)
-           ('http
-            (let ((host (uri-host agent-communication-uri))
-                  (port (uri-port agent-communication-uri)))
-              (simple-format #t "listening on ~A:~A\n"
-                             host port)
-              (http-agent-messaging-start-server
-               port
-               host
-               (assq-ref opts 'secret-key-base)
-               build-coordinator)))))))))
+       ;; Copied from (fibers web server)
+       (define (call-with-sigint thunk cvar)
+         (let ((handler #f))
+           (dynamic-wind
+             (lambda ()
+               (set! handler
+                 (sigaction SIGINT (lambda (sig) (signal-condition! cvar)))))
+             thunk
+             (lambda ()
+               (if handler
+                   ;; restore Scheme handler, SIG_IGN or SIG_DFL.
+                   (sigaction SIGINT (car handler) (cdr handler))
+                   ;; restore original C handler.
+                   (sigaction SIGINT #f))))))
+
+       (let* ((trigger-build-allocation
+               (make-build-allocator-thread build-coordinator))
+              (agent-communication-thunk
+               (let ((agent-communication-uri
+                      (string->uri (assq-ref opts 'agent-communication))))
+                 (match (uri-scheme agent-communication-uri)
+                   ('http
+                    (let ((host (uri-host agent-communication-uri))
+                          (port (uri-port agent-communication-uri))
+                          (chunked-request-channel
+                           ;; There are fibers issues when trying to read the
+                           ;; chunked requests
+                           (make-worker-thread-channel (const '())
+                                                       #:parallelism 8)))
+                      (lambda ()
+                        (simple-format #t "listening on ~A:~A\n"
+                                       host port)
+                        (http-agent-messaging-start-server
+                         port
+                         host
+                         (assq-ref opts 'secret-key-base)
+                         build-coordinator
+                         chunked-request-channel
+                         trigger-build-allocation))))))))
+
+         (start-hook-processing-thread build-coordinator)
+         (trigger-build-allocation build-coordinator)
+
+         (let ((finished? (make-condition)))
+           (call-with-sigint
+            (lambda ()
+              (run-fibers
+               (lambda ()
+                 (agent-communication-thunk)
+
+                 (wait finished?))))
+            finished?)))))))