Index: ChangeLog
===================================================================
RCS file: /project/slime/cvsroot/slime/ChangeLog,v
retrieving revision 1.860
diff -u -r1.860 ChangeLog
--- ChangeLog	18 Mar 2006 07:45:18 -0000	1.860
+++ ChangeLog	19 Mar 2006 05:56:47 -0000
@@ -1,3 +1,30 @@
+2006-03-19  Douglas Crosher <dcrosher@common-lisp.net>
+
+	* swank-backend (accept-connection): add a 'timeout argument to
+	this function.
+
+	* swank-backend (set-stream-timeout): new implementation specific
+	function.  Used to set the timeout for stream operations, which
+	can help make the network connection establishment more robust.
+
+	* swank (setup-server): ignore errors from the function 'serve to
+	allow another connection to be made.
+
+	* swank (serve-connection): ensure the listener socket is closed
+	when 'dont-close is false, even if the connection attempt fails.
+
+	* swank (accept-authenticated-connection): ensure the new
+	connection is closed if the connection establishment fails.  Set a
+	short stream timeout to prevent denial of survice.
+
+	* swank (open-dedicated-output-stream): ensure the listener socket
+	is closed, even if unable to open the dedicated stream.  Implement
+	a timeout while waiting for a connection for the dedicate stream
+	to prevent denial of service.
+
+	* swank (create-connection): ensure the new connection is closed
+	if not successful.
+
 2006-03-18  Matthias Koeppe  <mkoeppe@mail.math.uni-magdeburg.de>
 
 	* slime.el (slime-goto-location-buffer): Avoid calling the
Index: swank-allegro.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-allegro.lisp,v
retrieving revision 1.84
diff -u -r1.84 swank-allegro.lisp
--- swank-allegro.lisp	16 Mar 2006 18:34:17 -0000	1.84
+++ swank-allegro.lisp	19 Mar 2006 05:56:47 -0000
@@ -41,8 +41,9 @@
 (defimplementation close-socket (socket)
   (close socket))
 
-(defimplementation accept-connection (socket &key external-format buffering)
-  (declare (ignore buffering))
+(defimplementation accept-connection (socket &key external-format buffering
+                                             timeout)
+  (declare (ignore buffering timeout))
   (let ((ef (or external-format :iso-latin-1-unix))
         (s (socket:accept-connection socket :wait t)))
     (set-external-format s ef)
Index: swank-backend.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-backend.lisp,v
retrieving revision 1.96
diff -u -r1.96 swank-backend.lisp
--- swank-backend.lisp	25 Feb 2006 12:10:33 -0000	1.96
+++ swank-backend.lisp	19 Mar 2006 05:56:47 -0000
@@ -214,7 +214,7 @@
   "Close the socket SOCKET.")
 
 (definterface accept-connection (socket &key external-format
-                                        buffering)
+                                        buffering timeout)
    "Accept a client connection on the listening socket SOCKET.  
 Return a stream for the new connection.")
 
@@ -234,6 +234,12 @@
   "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL."
   nil)
 
+(definterface set-stream-timeout (stream timeout)
+  "Set the 'stream 'timeout.  The timeout is either the real number
+  specifying the timeout in seconds or 'nil for no timeout."
+  (declare (ignore stream timeout))
+  nil)
+
 ;;; Base condition for networking errors.
 (define-condition network-error (simple-error) ())
 
Index: swank-clisp.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-clisp.lisp,v
retrieving revision 1.57
diff -u -r1.57 swank-clisp.lisp
--- swank-clisp.lisp	11 Nov 2005 23:43:43 -0000	1.57
+++ swank-clisp.lisp	19 Mar 2006 05:56:48 -0000
@@ -126,8 +126,8 @@
   
 (defimplementation accept-connection (socket
 				      &key (external-format :iso-latin-1-unix)
-				      buffering)
-  (declare (ignore buffering))
+				      buffering timeout)
+  (declare (ignore buffering timeout))
   (socket:socket-accept socket
 			:buffered nil ;; XXX should be t
 			:element-type 'character
Index: swank-cmucl.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-cmucl.lisp,v
retrieving revision 1.159
diff -u -r1.159 swank-cmucl.lisp
--- swank-cmucl.lisp	22 Nov 2005 10:32:37 -0000	1.159
+++ swank-cmucl.lisp	19 Mar 2006 05:56:48 -0000
@@ -100,7 +100,9 @@
 
 (defimplementation accept-connection (socket &key 
                                       (external-format :iso-latin-1-unix)
-                                      (buffering :full))
+                                      (buffering :full)
+                                      timeout)
+  (declare (ignore timeout))
   (unless (eq external-format ':iso-latin-1-unix)
     (remove-fd-handlers socket)
     (remove-sigio-handlers socket)
Index: swank-corman.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-corman.lisp,v
retrieving revision 1.5
diff -u -r1.5 swank-corman.lisp
--- swank-corman.lisp	11 Nov 2005 23:43:43 -0000	1.5
+++ swank-corman.lisp	19 Mar 2006 05:56:48 -0000
@@ -239,8 +239,8 @@
 
 (defimplementation accept-connection (socket
                                       &key (external-format :iso-latin-1-unix)
-				      buffering)
-  (declare (ignore buffering))
+				      buffering timeout)
+  (declare (ignore buffering timeout))
   (ecase external-format
     (:iso-latin-1-unix 
      (sockets:make-socket-stream (sockets:accept-socket socket)))))
Index: swank-ecl.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-ecl.lisp,v
retrieving revision 1.4
diff -u -r1.4 swank-ecl.lisp
--- swank-ecl.lisp	11 Nov 2005 23:43:43 -0000	1.4
+++ swank-ecl.lisp	19 Mar 2006 05:56:48 -0000
@@ -46,8 +46,8 @@
 
 (defimplementation accept-connection (socket
                                       &key (external-format :iso-latin-1-unix)
-                                      buffering)
-  (declare (ignore buffering))
+                                      buffering timeout)
+  (declare (ignore buffering timeout))
   (assert (eq external-format :iso-latin-1-unix))
   (make-socket-io-stream (accept socket) external-format))
 
Index: swank-lispworks.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-lispworks.lisp,v
retrieving revision 1.82
diff -u -r1.82 swank-lispworks.lisp
--- swank-lispworks.lisp	10 Feb 2006 16:54:01 -0000	1.82
+++ swank-lispworks.lisp	19 Mar 2006 05:56:48 -0000
@@ -67,8 +67,8 @@
 
 (defimplementation accept-connection (socket 
                                       &key (external-format :iso-latin-1-unix)
-                                      buffering)
-  (declare (ignore buffering))
+                                      buffering timeout)
+  (declare (ignore buffering timeout))
   (assert (eq external-format :iso-latin-1-unix))
   (let* ((fd (comm::get-fd-from-socket socket)))
     (assert (/= fd -1))
Index: swank-openmcl.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-openmcl.lisp,v
retrieving revision 1.106
diff -u -r1.106 swank-openmcl.lisp
--- swank-openmcl.lisp	7 Mar 2006 09:51:52 -0000	1.106
+++ swank-openmcl.lisp	19 Mar 2006 05:56:48 -0000
@@ -168,8 +168,8 @@
 
 (defimplementation accept-connection (socket 
                                       &key (external-format :iso-latin-1-unix)
-                                      buffering)
-  (declare (ignore buffering))
+                                      buffering timeout)
+  (declare (ignore buffering timeout))
   (assert (eq external-format :iso-latin-1-unix))
   (ccl:accept-connection socket :wait t))
 
Index: swank-sbcl.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-sbcl.lisp,v
retrieving revision 1.152
diff -u -r1.152 swank-sbcl.lisp
--- swank-sbcl.lisp	20 Jan 2006 21:31:20 -0000	1.152
+++ swank-sbcl.lisp	19 Mar 2006 05:56:49 -0000
@@ -60,7 +60,8 @@
 
 (defimplementation accept-connection (socket &key 
                                       (external-format :iso-latin-1-unix)
-                                      (buffering :full))
+                                      (buffering :full) timeout)
+  (declare (ignore timeout))
   (make-socket-io-stream (accept socket) external-format buffering))
 
 (defvar *sigio-handlers* '()
Index: swank-scl.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-scl.lisp,v
retrieving revision 1.5
diff -u -r1.5 swank-scl.lisp
--- swank-scl.lisp	25 Feb 2006 17:46:13 -0000	1.5
+++ swank-scl.lisp	19 Mar 2006 05:56:49 -0000
@@ -54,10 +54,23 @@
 
 (defimplementation accept-connection (socket &key 
                                       (external-format :iso-latin-1-unix)
-                                      (buffering :full))
-  (let ((external-format (or external-format :iso-latin-1-unix)))
-    (make-socket-io-stream (ext:accept-tcp-connection socket)
-                           external-format buffering)))
+                                      (buffering :full)
+                                      (timeout nil))
+  (let ((external-format (or external-format :iso-latin-1-unix))
+        (fd (socket-fd socket)))
+      (loop
+       (let ((ready (sys:wait-until-fd-usable fd :input timeout)))
+         (unless ready
+           (error "Timeout accepting connection on socket: ~S~%" socket)))
+       (let ((new-fd (ignore-errors (ext:accept-tcp-connection fd))))
+         (when new-fd
+           (return (make-socket-io-stream new-fd external-format buffering)))))))
+
+(defimplementation set-stream-timeout (stream timeout)
+  (check-type timeout (or null real))
+  (if (fboundp 'ext::stream-timeout)
+      (setf (ext::stream-timeout stream) timeout)
+      (setf (slot-value (slot-value stream 'cl::stream) 'cl::timeout) timeout)))
 
 ;;;;; Sockets
 
Index: swank.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank.lisp,v
retrieving revision 1.364
diff -u -r1.364 swank.lisp
--- swank.lisp	18 Mar 2006 07:37:22 -0000	1.364
+++ swank.lisp	19 Mar 2006 05:56:50 -0000
@@ -424,7 +424,7 @@
              (serve-connection socket style dont-close external-format)))
       (ecase style
         (:spawn
-         (spawn (lambda () (loop do (serve) while dont-close)) 
+         (spawn (lambda () (loop do (ignore-errors (serve)) while dont-close)) 
                 :name "Swank"))
         ((:fd-handler :sigio)
          (add-fd-handler socket (lambda () (serve))))
@@ -432,23 +432,34 @@
       port)))
 
 (defun serve-connection (socket style dont-close external-format)
-  (let ((client (accept-authenticated-connection
-                 socket :external-format external-format)))
-    (unless dont-close
-      (close-socket socket))
-    (let ((connection (create-connection client style external-format)))
-      (run-hook *new-connection-hook* connection)
-      (push connection *connections*)
-      (serve-requests connection))))
+  (let ((closed-socket-p nil))
+    (unwind-protect
+         (let ((client (accept-authenticated-connection
+                        socket :external-format external-format)))
+           (unless dont-close
+             (close-socket socket)
+             (setf closed-socket-p t))
+           (let ((connection (create-connection client style external-format)))
+             (run-hook *new-connection-hook* connection)
+             (push connection *connections*)
+             (serve-requests connection)))
+      (unless (or dont-close closed-socket-p)
+        (close-socket socket)))))
 
 (defun accept-authenticated-connection (&rest args)
   (let ((new (apply #'accept-connection args))
-        (secret (slime-secret)))
-    (when secret
-      (let ((first-val (decode-message new)))
-        (unless (and (stringp first-val) (string= first-val secret))
-          (close new)
-          (error "Incoming connection doesn't know the password."))))
+        (success nil))
+    (unwind-protect
+         (let ((secret (slime-secret)))
+           (when secret
+             (set-stream-timeout new 20)
+             (let ((first-val (decode-message new)))
+               (unless (and (stringp first-val) (string= first-val secret))
+                 (error "Incoming connection doesn't know the password."))))
+           (set-stream-timeout new nil)
+           (setf success t))
+      (unless success
+        (close new :abort t)))
     new))
 
 (defun slime-secret ()
@@ -518,13 +529,20 @@
 Return an output stream suitable for writing program output.
 
 This is an optimized way for Lisp to deliver output to Emacs."
-  (let* ((socket (create-socket *loopback-interface* 
-                                *dedicated-output-stream-port*))
-         (port (local-port socket)))
-    (encode-message `(:open-dedicated-output-stream ,port) socket-io)
-    (accept-authenticated-connection
-     socket :external-format external-format 
-     :buffering *dedicated-output-stream-buffering*)))
+  (let ((socket (create-socket *loopback-interface* 
+                               *dedicated-output-stream-port*)))
+    (unwind-protect
+         (let ((port (local-port socket)))
+           (encode-message `(:open-dedicated-output-stream ,port) socket-io)
+           (let ((dedicated (accept-authenticated-connection
+                             socket :external-format external-format 
+                             :buffering *dedicated-output-stream-buffering*
+                             :timeout 30)))
+             (close-socket socket)
+             (setf socket nil)
+             dedicated))
+      (when socket
+        (close-socket socket)))))
 
 (defun handle-request (connection)
   "Read and process one request.  The processing is done in the extend
@@ -828,34 +846,39 @@
     connection))
 
 (defun create-connection (socket-io style external-format)
-  (let ((c (ecase style
-             (:spawn
-              (make-connection :socket-io socket-io
-                               :read #'read-from-control-thread
-                               :send #'send-to-control-thread
-                               :serve-requests #'spawn-threads-for-connection
-                               :cleanup #'cleanup-connection-threads))
-             (:sigio
-              (make-connection :socket-io socket-io
-                               :read #'read-from-socket-io
-                               :send #'send-to-socket-io
-                               :serve-requests #'install-sigio-handler
-                               :cleanup #'deinstall-sigio-handler))
-             (:fd-handler
-              (make-connection :socket-io socket-io
-                               :read #'read-from-socket-io
-                               :send #'send-to-socket-io
-                               :serve-requests #'install-fd-handler
-                               :cleanup #'deinstall-fd-handler))
-             ((nil)
-              (make-connection :socket-io socket-io
-                               :read #'read-from-socket-io
-                               :send #'send-to-socket-io
-                               :serve-requests #'simple-serve-requests)))))
-    (setf (connection.communication-style c) style)
-    (setf (connection.external-format c) external-format)
-    (initialize-streams-for-connection c)
-    c))
+  (let ((success nil))
+    (unwind-protect
+         (let ((c (ecase style
+                    (:spawn
+                     (make-connection :socket-io socket-io
+                                      :read #'read-from-control-thread
+                                      :send #'send-to-control-thread
+                                      :serve-requests #'spawn-threads-for-connection
+                                      :cleanup #'cleanup-connection-threads))
+                    (:sigio
+                     (make-connection :socket-io socket-io
+                                      :read #'read-from-socket-io
+                                      :send #'send-to-socket-io
+                                      :serve-requests #'install-sigio-handler
+                                      :cleanup #'deinstall-sigio-handler))
+                    (:fd-handler
+                     (make-connection :socket-io socket-io
+                                      :read #'read-from-socket-io
+                                      :send #'send-to-socket-io
+                                      :serve-requests #'install-fd-handler
+                                      :cleanup #'deinstall-fd-handler))
+                    ((nil)
+                     (make-connection :socket-io socket-io
+                                      :read #'read-from-socket-io
+                                      :send #'send-to-socket-io
+                                      :serve-requests #'simple-serve-requests)))))
+           (setf (connection.communication-style c) style)
+           (setf (connection.external-format c) external-format)
+           (initialize-streams-for-connection c)
+           (setf success t)
+           c)
+      (unless success
+        (close socket-io :abort t)))))
 
 
 ;;;; IO to Emacs
