Hey Edi,
I made a new patch that uses TRIVIAL-TIMEOUT instead of usocket WAIT-FOR-INPUT. Results are great, it yields no slowdown at all when downloading a 10MB zero-filled file.
Patch follows. I can't attach files due to posting to Gmane through tin(1) so it's included in the message body. If it gets mangled in the transmission, it's alternatively available at http://tehran.lain.pl/stuff/20090827-drakma-timeout-gray-stream-take2.diff
diff -rN -u old-drakma/drakma.asd new-drakma/drakma.asd --- old-drakma/drakma.asd 2009-08-27 05:59:20.000000000 +0200 +++ new-drakma/drakma.asd 2009-08-27 05:59:20.000000000 +0200 @@ -53,10 +53,13 @@ (:file "util") (:file "read") (:file "cookies") + #-lispworks (:file "timeouts") (:file "request")) :depends-on (:puri :cl-base64 :chunga :flexi-streams + #-lispworks #:trivial-timeout + #-lispworks #:trivial-gray-streams #-:lispworks :usocket #-(or :lispworks :allegro) :cl+ssl)) diff -rN -u old-drakma/request.lisp new-drakma/request.lisp --- old-drakma/request.lisp 2009-08-27 05:59:20.000000000 +0200 +++ new-drakma/request.lisp 2009-08-27 05:59:20.000000000 +0200 @@ -200,9 +200,11 @@ force-binary want-stream stream - #+:lispworks (connection-timeout 20) - #+:lispworks (read-timeout 20) - #+(and :lispworks (not :lw-does-not-have-write-timeout)) + (connection-timeout 20) + (read-timeout 20) + #+(or (not :lispworks) + (and :lispworks + (not :lw-does-not-have-write-timeout))) (write-timeout 20 write-timeout-provided-p) #+openmcl deadline) @@ -385,6 +387,7 @@ time units. If the server fails to respond until that time, a COMMUNICATION-DEADLINE-EXPIRED condition is signalled. DEADLINE is only available on CCL 1.2 and later." + #-lispworks (declare (ignore write-timeout-provided-p)) (unless (member protocol '(:http/1.0 :http/1.1) :test #'eq) (parameter-error "Don't know how to handle protocol ~S." protocol)) (setq uri (cond ((uri-p uri) (copy-uri uri)) @@ -450,12 +453,16 @@ :write-timeout write-timeout :errorp t) #-:lispworks - (usocket:socket-stream - (usocket:socket-connect host port - :element-type 'octet - #+openmcl #+openmcl - :deadline deadline - :nodelay t)))) + (let ((sock (trivial-timeout:with-timeout (connection-timeout) + (usocket:socket-connect host port + :element-type 'octet + #+openmcl #+openmcl + :deadline deadline + :nodelay t)))) + (if (or read-timeout write-timeout) + (usocket-timeout:timeout-stream-for-socket + sock :read-timeout read-timeout :write-timeout write-timeout) + (usocket:socket-stream sock))))) #+openmcl (when deadline ;; it is correct to set the deadline here even though diff -rN -u old-drakma/timeouts.lisp new-drakma/timeouts.lisp --- old-drakma/timeouts.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-drakma/timeouts.lisp 2009-08-27 05:59:20.000000000 +0200 @@ -0,0 +1,62 @@ +(defpackage #:usocket-timeout + (:use #:cl #:usocket #:trivial-timeout #:trivial-gray-streams) + (:shadowing-import-from #:trivial-timeout #:timeout-error) + (:export #:timeout-stream-for-socket)) + +(in-package #:usocket-timeout) + + +(defclass timeout-mixin () + ((socket-of :initarg :socket + :reader socket-of))) + +(defclass timeout-input-stream (trivial-gray-stream-mixin + fundamental-binary-input-stream + timeout-mixin) + ((read-timeout :initform nil + :initarg :read-timeout + :reader read-timeout-of))) + +(defmethod stream-read-sequence ((stream timeout-input-stream) + sequence start end &key) + (with-timeout ((read-timeout-of stream)) + (read-sequence sequence (socket-of stream) :start start :end end))) + +(defmethod stream-read-byte ((stream timeout-input-stream)) + (with-timeout ((read-timeout-of stream)) + (read-byte (socket-of stream)))) + + +(defclass timeout-output-stream (trivial-gray-stream-mixin + fundamental-binary-output-stream + timeout-mixin) + ((write-timeout :initform nil + :initarg :write-timeout + :reader write-timeout-of))) + +(defmethod stream-finish-output ((stream timeout-output-stream)) + (finish-output (socket-of stream))) + +(defmethod stream-write-sequence ((stream timeout-output-stream) + sequence start end &key) + (with-timeout ((write-timeout-of stream)) + (write-sequence sequence (socket-of stream) + :start (or start 0) + :end end))) + +(defmethod stream-write-byte ((stream timeout-output-stream) integer) + (with-timeout ((write-timeout-of stream)) + (write-byte integer (socket-of stream)))) + + +(defclass usocket-timeout-stream (timeout-input-stream timeout-output-stream) + ()) + +(defun timeout-stream-for-socket (socket &key timeout + (read-timeout timeout) + (write-timeout timeout)) + (make-instance 'usocket-timeout-stream + :socket (socket-stream socket) + :read-timeout read-timeout + :write-timeout write-timeout)) +