Drop the number of fibers threads

1 files changed, 53 insertions, 1 deletions

diff --git a/nar-herder/utils.scm b/nar-herder/utils.scm
index 4468ebb..d31c677 100644
--- a/nar-herder/utils.scm
+++ b/nar-herder/utils.scm
@@ -56,7 +56,10 @@
 
             with-port-timeouts
             set-socket-timeout
-            open-socket-for-uri*))
+            open-socket-for-uri*
+
+            call-with-sigint
+            run-server/patched))
 
 (define* (retry-on-error f #:key times delay ignore)
   (let loop ((attempt 1))
@@ -630,3 +633,52 @@ If already in the worker thread, call PROC immediately."
                    #:verify-certificate? verify-certificate?)
          s)
      s)))
+
+;; 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))))))
+
+;; 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))))))
+