From sthalik at test123.ltd.pl  Thu Aug 27 04:07:12 2009
From: sthalik at test123.ltd.pl (Stanislaw Halik)
Date: Thu, 27 Aug 2009 04:07:12 +0000 (UTC)
Subject: [drakma-devel] [patch] timeouts, take two
Message-ID: <h750pf$pfn$1@ger.gmane.org>

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))
+