From 3530d332bd1a34f508cb25ba684622219cdc388f Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Wed, 16 Sep 2020 20:32:23 +0100
Subject: Don't patch fibers, just use the different procedure directly

---
 guix-build-coordinator/agent-messaging/http.scm |  2 +-
 guix-build-coordinator/client-communication.scm |  2 +-
 guix-build-coordinator/utils.scm                | 37 ++++++++++++++++++++++++-
 scripts/guix-build-coordinator.in               | 37 +------------------------
 4 files changed, 39 insertions(+), 39 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))))))
diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in
index 71111c0..8aed241 100644
--- a/scripts/guix-build-coordinator.in
+++ b/scripts/guix-build-coordinator.in
@@ -217,41 +217,6 @@
       (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! fibers-web-server-module
-               'run-server
-               run-server/patched))
-
 (setvbuf (current-output-port) 'line)
 (setvbuf (current-error-port) 'line)
 
@@ -513,4 +478,4 @@ processed?:      ~A
                     substitutes-channel))
 
                  (wait finished?))))
-            finished?))))))))))
+            finished?)))))))
-- 
cgit v1.2.3