Drop the number of fibers threads

2 files changed, 75 insertions, 12 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))))))
+
diff --git a/scripts/nar-herder.in b/scripts/nar-herder.in
index c20aab7..a75347f 100644
--- a/scripts/nar-herder.in
+++ b/scripts/nar-herder.in
@@ -648,14 +648,25 @@
 
        (log-msg 'INFO "starting server, listening on "
                 (assq-ref opts 'host) ":" (assq-ref opts 'port))
-       (run-server
-        (make-request-handler database
-                              canonical-storage
-                              #:ttl (assq-ref opts 'narinfo-ttl)
-                              #:negative-ttl (assq-ref opts 'narinfo-negative-ttl)
-                              #:logger lgr
-                              #:metrics-registry metrics-registry
-                              #:maybe-trigger-creation-of-compressed-nars
-                              maybe-trigger-creation-of-compressed-nars)
-        #:host (assq-ref opts 'host)
-        #:port (assq-ref opts 'port))))))
+
+       (let ((finished? (make-condition)))
+         (call-with-sigint
+          (lambda ()
+            (run-fibers
+             (lambda ()
+               (run-server/patched
+                (make-request-handler database
+                                      canonical-storage
+                                      #:ttl (assq-ref opts 'narinfo-ttl)
+                                      #:negative-ttl (assq-ref opts 'narinfo-negative-ttl)
+                                      #:logger lgr
+                                      #:metrics-registry metrics-registry
+                                      #:maybe-trigger-creation-of-compressed-nars
+                                      maybe-trigger-creation-of-compressed-nars)
+                #:host (assq-ref opts 'host)
+                #:port (assq-ref opts 'port))
+
+               (wait finished?))
+             #:hz 5
+             #:parallelism 4))
+          finished?))))))