Don't patch fibers, just use the different procedure directly

3 files changed, 38 insertions, 3 deletions

diff --git a/guix-build-coordinator/agent-messaging/http.scm b/guix-build-coordinator/agent-messaging/http.scm
index 91b686b..e93a909 100644
--- a/guix-build-coordinator/agent-messaging/http.scm
+++ b/guix-build-coordinator/agent-messaging/http.scm
@@ -85,7 +85,7 @@ if there was no request body."
 
   (call-with-error-handling
    (lambda ()
-     (run-server
+     (run-server/patched
       (lambda (request body)
         (display
          (format #f "~4a ~a\n"
diff --git a/guix-build-coordinator/client-communication.scm b/guix-build-coordinator/client-communication.scm
index d3534e3..a53ce3a 100644
--- a/guix-build-coordinator/client-communication.scm
+++ b/guix-build-coordinator/client-communication.scm
@@ -52,7 +52,7 @@
                                      substitutes-channel)
   (call-with-error-handling
    (lambda ()
-     (run-server
+     (run-server/patched
       (lambda (request body)
         (display
          (format #f "~4a ~a\n"
diff --git a/guix-build-coordinator/utils.scm b/guix-build-coordinator/utils.scm
index d2b5a6d..974316f 100644
--- a/guix-build-coordinator/utils.scm
+++ b/guix-build-coordinator/utils.scm
@@ -59,7 +59,9 @@
 
             with-timeout
 
-            call-with-sigint))
+            call-with-sigint
+
+            run-server/patched))
 
 
 (define %worker-thread-args
@@ -652,3 +654,36 @@ again."
             (sigaction SIGINT (car handler) (cdr handler))
             ;; restore original C handler.
             (sigaction SIGINT #f))))))
+
+;; This variant of run-server from the fibers library supports running
+;; multiple servers within one process.
+(define run-server/patched
+  (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))
+
+    (lambda* (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))))))