mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-29 14:30:34 +02:00
Code Activity

better socket buffering on http web server backend

Browse source 
* module/web/server/http.scm (http-read, http-write): Line-buffer the
  port while we're reading the request, and block-buffer it otherwise
  Use the default block size.
This commit is contained in:
Andy Wingo 2010-12-02 13:33:49 +01:00
parent e1ee45e78b
commit bb90ce2cbc
1 changed files with 17 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

21
module/web/server/http.scm
View file

@ -65,9 +65,15 @@
#f #f #f)) #f #f #f))
((memq server readable) ((memq server readable)
;; FIXME: meta to read-request ;; FIXME: meta to read-request
(let* ((client (accept server)) (let* ((client (let ((pair (accept server)))
;; line buffered for request
(setvbuf (car pair) _IOLBF)
pair))
(req (read-request (car client))) (req (read-request (car client)))
(body-str (read-request-body/latin-1 req))) (body-str (begin
;; block buffered for body and response
(setvbuf (car client) _IOFBF)
(read-request-body/latin-1 req))))
(values keep-alive (car client) req body-str))) (values keep-alive (car client) req body-str)))
((pair? readable) ((pair? readable)
;; FIXME: preserve meta for keep-alive ;; FIXME: preserve meta for keep-alive
@ -79,8 +85,12 @@
(values keep-alive #f #f #f)) (values keep-alive #f #f #f))
(call-with-error-handling (call-with-error-handling
(lambda () (lambda ()
;; http-write already left p in line-buffered state
(let* ((req (read-request p)) (let* ((req (read-request p))
(body-str (read-request-body/latin-1 req))) (body-str (begin
;; block buffered for body and response
(setvbuf p _IOFBF)
(read-request-body/latin-1 req))))
(values keep-alive p req body-str))) (values keep-alive p req body-str)))
#:pass-keys '(quit interrupt) #:pass-keys '(quit interrupt)
#:on-error (if (batch-mode?) 'pass 'debug) #:on-error (if (batch-mode?) 'pass 'debug)
@ -113,7 +123,10 @@
(error "Expected a string or bytevector for body" body))) (error "Expected a string or bytevector for body" body)))
(force-output (response-port response)) (force-output (response-port response))
(if (keep-alive? response) (if (keep-alive? response)
(response-port response) (let ((p (response-port response)))
;; back to line buffered
(setvbuf p _IOLBF)
p)
(begin (begin
(close-port (response-port response)) (close-port (response-port response))
#f)))) #f))))