Permalink
Browse files

correct bad buffer handling that could lead to server giving up and c…

…lient seeing ECONNRESET; use (fiveam:run! 'tpd2.test::http-request-and-serve) to start the test that reproduced the condition
  • Loading branch information...
1 parent 7c35081 commit 1b12505b70d11ad0722a603b69e761193bd12488 @vii committed Apr 18, 2016
Showing with 122 additions and 103 deletions.
  1. +1 −1 src/http/dispatcher.lisp
  2. +30 −26 src/http/request.lisp
  3. +7 −6 src/io/con.lisp
  4. +16 −12 src/io/recvbuf.lisp
  5. +1 −0 src/packages.lisp
  6. +64 −55 t/http.lisp
  7. +2 −2 teepeedee2-test.asd
  8. +1 −1 teepeedee2.asd
@@ -136,4 +136,4 @@
;; TODO print a list of hostnames for each dispatcher
(loop for (path . dispatcher) in *dispatchers*
do (format t "~&~S -> ~A~&" (force-string path) dispatcher))
- (format t "~&DEFAULT -> ~A~&" *default-dispatcher*))
+ (format t "~&DEFAULT -> ~A~&" *default-dispatcher*))
View
@@ -23,9 +23,9 @@
(without-call/cc (apply-byte-vector-cat body))))
-(defvar *connection-cache* (make-hash-table :test #'equalp))
+(defvar *client-http-connection-cache* (make-hash-table :test #'equalp))
-(defprotocol http-request (con request done &key connection-cache)
+(defprotocol http-request (con request done &key connection-cache-key)
(io 'send con request)
(let ((content-length)
(chunked)
@@ -39,7 +39,6 @@
(when (not (or (< 1 version-major) (and (= 1 version-major) (< 0 version-minor))))
(setf connection-close t))
-
(io 'process-headers con
(without-call/cc (lambda(name value)
(unless (zerop (length value))
@@ -67,27 +66,30 @@
(t
(setf connection-close t)
(io 'recv-until-close con))))
-
- (cond ((or connection-close (not connection-cache))
- (hangup con))
+
+ (cond ((or connection-close (not connection-cache-key) (not *client-http-connection-cache*))
+ (hangup con))
(t
- (add-to-connection-cache con connection-cache)))))))
+ (add-to-connection-cache con connection-cache-key)))))))
(defun http-connection-cache-timeout ()
25)
-(defun add-to-connection-cache (con key)
+(defun add-to-connection-cache (con key &key (connection-cache *client-http-connection-cache*))
(con-clear-failure-callbacks con)
- (unless (con-dead? con)
- (con-when-ready-to-read con (lambda() (con-fail con)))
- (con-add-failure-callback con
- (lambda(&rest args)
- (declare (ignore args))
- (debug-assert (member con (gethash key *connection-cache*)) (con key))
- (deletef con (gethash key *connection-cache*))))
- (reset-timeout con (http-connection-cache-timeout))
- (push con (gethash key *connection-cache*))))
+ (cond
+ ((not connection-cache)
+ (hangup con))
+ ((not (con-dead? con))
+ (con-when-ready-to-read con (lambda() (con-fail con)))
+ (con-add-failure-callback con
+ (lambda(&rest args)
+ (declare (ignore args))
+ (debug-assert (member con (gethash key connection-cache)) (con key))
+ (deletef con (gethash key connection-cache))))
+ (reset-timeout con (http-connection-cache-timeout))
+ (push con (gethash key connection-cache)))))
#+tpd2-http-no-connection-cache
(defun add-to-connection-cache (con key)
@@ -96,7 +98,9 @@
(hangup con))
(defun get-http-request-con (ssl address port)
- (let ((con (pop (gethash (list ssl address port) *connection-cache*))))
+ (let ((con
+ (when *client-http-connection-cache*
+ (pop (gethash (list ssl address port) *client-http-connection-cache*)))))
(cond (con
(con-clear-failure-callbacks con)
(reset-timeout con)
@@ -113,13 +117,13 @@
con)))))
(defun launch-http-request (&key ssl (port (if ssl 443 80)) address body
- (path (force-byte-vector "/"))
- extra-header-lines
- hostname
- timeout
- failure
- done
- (method (force-byte-vector "GET")))
+ (path (force-byte-vector "/"))
+ extra-header-lines
+ hostname
+ timeout
+ failure
+ done
+ (method (force-byte-vector "GET")))
(unless address
(setf address (lookup-hostname hostname)))
(unless address
@@ -148,4 +152,4 @@
+newline+
body)
(lambda(&rest args)(setf succeeded t) (apply done args))
- :connection-cache (list ssl address port))))
+ :connection-cache-key (list ssl address port))))
View
@@ -55,9 +55,9 @@
(my-defun con run ()
(restart-case
(handler-bind ((error
- (lambda(e)
- (when (normal-connection-error e)
- (invoke-restart 'hangup e)))))
+ (lambda (e)
+ (when (normal-connection-error e)
+ (invoke-restart 'hangup e)))))
(funcall (my ready-callback)))
(hangup (&optional (err (make-condition 'socket-explicitly-hungup)))
(my fail err))))
@@ -93,13 +93,14 @@
((>= (recvbuf-available-to-eat (my recv)) amount)
(funcall done (recvbuf-eat (my recv) amount)))
(t
- (recvbuf-prepare-read (my recv) amount)
+ (recvbuf-prepare-read (my recv) amount amount)
(recvbuf-recv (my recv) me #'my-call))))
(my-defun con 'recv-some-or-nil (done)
(let ((available (recvbuf-available-to-eat (my recv))))
(cond
((zerop available)
+ (recvbuf-prepare-read (my recv))
(let ((s (recvbuf-read-some (my recv) me #'my-call)))
(case s
((nil))
@@ -128,8 +129,8 @@
(my-defun con 'recvline-shared-buf (done &optional (delimiter +newline+))
(declare (type function done) (type simple-byte-vector delimiter))
(unless (zerop (recvbuf-read-idx (my recv)))
- (recvbuf-shift-up (my recv) 0) ;shift everything so that we start with the read-idx at zero
- (assert (zerop (recvbuf-read-idx (my recv))) (me (my recv))))
+ (recvbuf-shift-up (my recv)) ;shift everything so that we start with the read-idx at zero
+ (assert (zerop (recvbuf-read-idx (my recv))) (me (my recv))))
(acond
((recvbuf-find (my recv) delimiter)
(setf (recvbuf-read-idx (my recv)) (+ it (length delimiter)))
View
@@ -3,8 +3,10 @@
(deftype recvbuf-small-integer ()
`(integer 0 #x10000000))
-(defconstant +recvbuf-default-size+ 4096)
+(defconstant +recvbuf-default-size+ 8192)
+(defconstant +recvbuf-maximum-size+ (* 64 1024))
(defconstant +recvbuf-oversize+ 10000)
+(defconstant +recvbuf-target-available-size+ 1024)
(defstruct recvbuf
(store (make-byte-vector +recvbuf-default-size+) :type simple-byte-vector)
@@ -48,29 +50,31 @@
(my-declare-fast-inline)
(the recvbuf-small-integer (- (my write-idx) (my read-idx))))
-(my-defun recvbuf shift-up (size)
+(my-defun recvbuf shift-up (&optional (desired-available 0) (maximum-size +recvbuf-maximum-size+))
(my-declare-fast-inline)
(cond
((= (my write-idx) (my read-idx))
- (when (> size (my len))
- (setf (my store) (make-byte-vector size)))
+ (when (> desired-available (my len))
+ (setf (my store) (make-byte-vector (min maximum-size desired-available))))
(setf
(my read-idx) 0
(my write-idx) 0))
(t
;; Unfortunately cannot use adjust-array as that might make non "simple" arrays
- (let ((new-store (make-byte-vector (max (my len) size))))
+ (let ((new-store (make-byte-vector
+ (min maximum-size
+ (max (my len) (+ (my available-to-eat) desired-available))))))
(replace new-store (my store) :start2 (my read-idx) :end2 (my write-idx))
(decf (my write-idx) (my read-idx))
- (setf (my read-idx) 0)
- (setf (my store) new-store))))
+ (setf (my read-idx) 0
+ (my store) new-store))))
(values))
-(my-defun recvbuf prepare-read (&optional (size 1024))
- (declare (type recvbuf-small-integer size))
- (when (> size (- (my len) (my read-idx)))
- (my shift-up size))
- (debug-assert (>= (- (my len) (my read-idx)) size) (me size))
+(my-defun recvbuf prepare-read (&optional (desired-available +recvbuf-target-available-size+) (maximum-size +recvbuf-maximum-size+))
+ (declare (type recvbuf-small-integer desired-available))
+ (when (> desired-available (- (my len) (my write-idx)))
+ (my shift-up desired-available maximum-size))
+ (debug-assert (>= (- (my len) (my write-idx)) desired-available) (me desired-available))
(values))
(my-defun recvbuf read-some (con &optional retry)
View
@@ -247,6 +247,7 @@
#:servestate-origin*
#:*servestate*
+ #:*client-http-connection-cache*
#:*default-dispatcher*
#:dispatcher-add-alias
View
@@ -3,61 +3,70 @@
(def-suite http :in :tpd2)
(in-suite http)
+(defsite *test-site* :dispatcher "*..*")
+
(test http-request-and-serve
- (let ((port 18282)
- (req-count 19)
- (address "127.0.0.1")
- (disp (find-or-make-dispatcher (force-byte-vector "*..*")))
- *default-site*)
- (with-site (:dispatcher disp)
+ (let* ((port 18283)
+ (req-count 100)
+ (req-count-to-go req-count)
+ (address "127.0.0.1")
+ (*client-http-connection-cache* (make-hash-table :test 'equalp))
+ (disp (find-or-make-dispatcher (force-byte-vector "*..*")))
+ *default-site*)
+ (with-site (*test-site*)
(labels ((build-body (n)
- (with-sendbuf ()
- (let ((v (make-byte-vector n)))
- (loop for a below (length v) do (setf (aref v a) (random #x100)))
- v)))
- (random-alphnum (n)
- (let ((v (make-byte-vector n)))
- (loop for a below (length v) do (setf (aref v a) (+ (char-code #\A) (random 26))))
- v))
- (build-headers (n)
- (let ((s (with-sendbuf ())))
- (loop for i below n do
- (with-sendbuf-continue (s)
- "X-"
- (random-alphnum (1+ (random 100)))
- ": "
- (random-alphnum (1+ (random 400)))
- +newline+
- ))
- s)))
- (defpage "/" (header body)
- (values
- (build-body (byte-vector-parse-integer body))
- (build-headers (byte-vector-parse-integer header))))
+ (with-sendbuf ()
+ (let ((v (make-byte-vector n)))
+ (loop for a below (length v) do (setf (aref v a) (random #x100)))
+ v)))
+ (random-alphnum (n)
+ (let ((v (make-byte-vector n)))
+ (loop for a below (length v) do (setf (aref v a) (+ (char-code #\A) (random 26))))
+ v))
+ (build-headers (n)
+ (let ((s (with-sendbuf ())))
+ (loop for i below n do
+ (with-sendbuf-continue (s)
+ "X-"
+ (random-alphnum (1+ (random 20)))
+ ": "
+ (random-alphnum (1+ (random 100)))
+ +newline+
+ ))
+ s)))
+ (defpage "/" (header body attempt)
+ (values
+ (build-body (byte-vector-parse-integer body))
+ (build-headers (byte-vector-parse-integer header))))
- (let ((socket (tpd2.io:make-con-listen :address address :port port)))
- (block event-loop
- (labels ((req-finished ()
- (decf req-count)
- (when (zerop req-count)
- (return-from event-loop))))
- (unwind-protect
- (progn
- (tpd2.io:launch-io 'tpd2.io:accept-forever socket 'tpd2.http::http-serve)
- (loop for i below req-count do
- (let ((b (* (random 16) (random (* 16 1024))))
- (h (* (random 16) (random 16))))
- (tpd2.http:launch-http-request
- :timeout 60
- :port port :address address
- :hostname (tpd2.http:dispatcher-canonical-name disp)
- :path (byte-vector-cat "/?BODY=" b "&HEADER=" h)
- :extra-header-lines (build-headers (random 32))
- :done (lambda(response &key response-code)
- (req-finished)
- (is (= 200 response-code)) (is (= (length response) b)))
- :failure (lambda(&rest e)
- (req-finished)
- (fail (format nil "~A" e))))))
- (event-loop))
- (tpd2.io:hangup socket)))))))))
+ (with-independent-event-loop ()
+ (let ((socket (tpd2.io:make-con-listen :address address :port port)))
+ (is-true socket)
+ (block event-loop
+ (labels ((req-finished ()
+ (when (zerop (decf req-count-to-go))
+ (return-from event-loop))))
+ (unwind-protect
+ (progn
+ (tpd2.io:launch-io 'tpd2.io:accept-forever socket 'tpd2.http::http-serve)
+ (loop for attempt below req-count do
+ (let ((b (* (random 16) (random (* 16 1024))))
+ (h (* (random 16) (random 16)))
+ (attempt attempt))
+ (tpd2.http:launch-http-request
+ :timeout 60
+ :port port :address address
+ :hostname (tpd2.http:dispatcher-canonical-name disp)
+ :path (byte-vector-cat "/?BODY=" b "&HEADER=" h "&ATTEMPT=" attempt)
+ :extra-header-lines (build-headers (min 20 attempt))
+ :done
+ (lambda (response &key response-code)
+ (is (= 200 response-code)) (is (= (length response) b))
+ (req-finished))
+ :failure
+ (lambda (&rest e)
+ (fail (format nil "attempt ~A had error ~A; headers ~A body ~A" attempt e h b))
+ (req-finished)))))
+ (event-loop))
+ (progn
+ (tpd2.io:hangup socket)))))))))))
View
@@ -1,7 +1,7 @@
(asdf:defsystem :teepeedee2-test
:name "teepeedee2 tests"
:author "John Fremlin <john@fremlin.org>"
- :version "prerelease"
+ :version "1.1"
:description "Tests for teepeedee2"
:components ((:module :t
@@ -12,4 +12,4 @@
)))
:depends-on (
:fiveam
- :teepeedee2))
+ :teepeedee2))
View
@@ -15,7 +15,7 @@
:name "teepeedee2"
:author "John Fremlin <john@fremlin.org>"
:description "Multiprotocol fast networking framework"
- :version "1.0"
+ :version "1.1"
:components (
(:module :src

0 comments on commit 1b12505

Please sign in to comment.