branch: master commit c47dfdf82b4be62501a7932eaec4c124566a1829 Author: Ludovic Courtès <l...@gnu.org> Date: Sat Feb 10 00:11:06 2018 +0100
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'. --- src/cuirass/http.scm | 31 ++++++++++++++++++++++++++----- 1 file 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)))))