mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

reverse order of poll-set traversal in http-read

Browse source 
* module/web/server/http.scm (http-read): Rewrite to iterate down the
  pollset, so the vector shuffles touch less memory and the end
  condition of the loop is clearer.
This commit is contained in:
Andy Wingo 2010-12-03 16:11:37 +01:00
parent 462a1a04cf
commit 0baead3f6e
1 changed files with 50 additions and 52 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -60,66 +60,64 @@
(sigaction SIGPIPE SIG_IGN) (sigaction SIGPIPE SIG_IGN)
(let ((poll-set (make-empty-poll-set))) (let ((poll-set (make-empty-poll-set)))
(poll-set-add! poll-set socket *events*) (poll-set-add! poll-set socket *events*)
(make-http-server socket 1 poll-set))) (make-http-server socket 0 poll-set)))
;; -> (client request body | #f #f #f) ;; -> (client request body | #f #f #f)
(define (http-read server) (define (http-read server)
(let* ((poll-set (http-poll-set server))) (let* ((poll-set (http-poll-set server)))
(let lp ((idx (http-poll-idx server))) (let lp ((idx (http-poll-idx server)))
(cond (let ((revents (poll-set-revents poll-set idx)))
((not (< idx (poll-set-nfds poll-set))) (cond
(poll poll-set) ((zero? idx)
(lp 0)) ;; The server socket, and the end of our downward loop.
(else
(let ((revents (poll-set-revents poll-set idx)))
(cond (cond
((zero? revents) ((zero? revents)
;; Nothing on this port. ;; No client ready, and no error; poll and loop.
(lp (1+ idx))) (poll poll-set)
((zero? idx) (lp (1- (poll-set-nfds poll-set))))
;; The server socket. ((not (zero? (logand revents *error-events*)))
(if (not (zero? (logand revents *error-events*))) ;; An error.
;; An error. (throw 'interrupt))
(throw 'interrupt)
;; Otherwise, we have a new client. Add to set, then
;; find another client that is ready to read.
;;
;; FIXME: preserve meta-info.
(let ((client (accept (poll-set-port poll-set idx))))
;; Set line buffering while reading the request.
(setvbuf (car client) _IOLBF)
(poll-set-add! poll-set (car client) *events*)
(lp (1+ idx)))))
;; Otherwise, a client socket with some activity on
;; it. Remove it from the poll set.
(else (else
(let ((port (poll-set-remove! poll-set idx))) ;; A new client. Add to set, poll, and loop.
(cond ;;
((or (not (zero? (logand revents *error-events*))) ;; FIXME: preserve meta-info.
(eof-object? (peek-char port))) (let ((client (accept (poll-set-port poll-set idx))))
;; The socket was shut down or had an error. See ;; Set line buffering while reading the request.
;; http://www.greenend.org.uk/rjk/2001/06/poll.html (setvbuf (car client) _IOLBF)
;; for an interesting discussion. (poll-set-add! poll-set (car client) *events*)
(close-port port) (poll poll-set)
(lp idx)) (lp (1- (poll-set-nfds poll-set)))))))
(else ((zero? revents)
;; Otherwise, try to read a request from this port. ;; Nothing on this port.
;; Next time we start with this index. (lp (1- idx)))
(set-http-poll-idx! server idx) ;; Otherwise, a client socket with some activity on
(call-with-error-handling ;; it. Remove it from the poll set.
(lambda () (else
(let ((req (read-request port))) (let ((port (poll-set-remove! poll-set idx)))
;; Block buffering for reading body and writing response. (cond
(setvbuf port _IOFBF) ((eof-object? (peek-char port))
(values port ;; EOF.
req (close-port port)
(read-request-body/latin-1 req)))) (lp (1- idx)))
#:pass-keys '(quit interrupt) (else
#:on-error (if (batch-mode?) 'pass 'debug) ;; Otherwise, try to read a request from this port.
#:post-error ;; Record the next index.
(lambda (k . args) (set-http-poll-idx! server (1- idx))
(warn "Error while reading request" k args) (call-with-error-handling
(values #f #f #f)))))))))))))) (lambda ()
(let ((req (read-request port)))
;; Block buffering for reading body and writing response.
(setvbuf port _IOFBF)
(values port
req
(read-request-body/latin-1 req))))
#:pass-keys '(quit interrupt)
#:on-error (if (batch-mode?) 'pass 'debug)
#:post-error
(lambda (k . args)
(warn "Error while reading request" k args)
(values #f #f #f))))))))))))
(define (keep-alive? response) (define (keep-alive? response)
(let ((v (response-version response))) (let ((v (response-version response)))