http: Process client connections really concurrently.

Before that, 'run-server' would force sequential processing of client
requests one after another.

* src/cuirass/http.scm (run-cuirass-server): Rewrite to use its own loop
instead of 'run-server'.

1 files changed, 26 insertions, 5 deletions

diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index 9528691..ef763ef 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -22,12 +22,15 @@
   #:use-module (cuirass database)
   #:use-module (cuirass utils)
   #:use-module (cuirass logging)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
   #:use-module (json)
   #:use-module (web request)
   #:use-module (web response)
-  #:use-module (web server)
+  #:use-module ((web server) #:hide (run-server))
   #:use-module (web uri)
+  #:use-module (fibers)
   #:export (run-cuirass-server))
 
 (define (build->hydra-build build)
@@ -209,7 +212,25 @@
     ;; 'fibers' backend that comes with Fibers 1.0.0 because it does its own
     ;; thread creations and calls 'run-fibers' by itself, which isn't
     ;; necessary here (and harmful).
-    (run-server url-handler
-                'fiberized
-                `(#:host ,address #:port ,port)
-                db)))
+    ;;
+    ;; In addition, we roll our own instead of using Guile's 'run-server' and
+    ;; 'serve-one-client'.  The key thing here is that we spawn a fiber to
+    ;; process each client request and then directly go back waiting for the
+    ;; next client (conversely, Guile's 'run-server' loop processes clients
+    ;; one after another, sequentially.)  We can do that because we don't
+    ;; maintain any state across connections.
+    ;;
+    ;; XXX: We don't do 'call-with-sigint' like 'run-server' does.
+    (let* ((impl (lookup-server-impl 'fiberized))
+           (server (open-server impl `(#:host ,address #:port ,port))))
+      (let loop ()
+        (let-values (((client request body)
+                      (read-client impl server)))
+          ;; Spawn a fiber to handle REQUEST and reply to CLIENT.
+          (spawn-fiber
+           (lambda ()
+             (let-values (((response body state)
+                           (handle-request (cut url-handler <> <> db)
+                                           request body '())))
+               (write-client impl server client response body)))))
+        (loop)))))