[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[no subject]
From: |
Ludovic Courtès |
Date: |
Fri, 9 Feb 2018 18:12:36 -0500 (EST) |
branch: master
commit c47dfdf82b4be62501a7932eaec4c124566a1829
Author: Ludovic Courtès <address@hidden>
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)))))