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'.
This commit is contained in:
parent
ef3801b3cc
commit
c47dfdf82b
|
@ -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)))))
|
||||
|
|
Loading…
Reference in New Issue