[slime-cvs] CVS slime
dcrosher
dcrosher at common-lisp.net
Wed Mar 22 16:40:01 UTC 2006
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv26977
Modified Files:
ChangeLog swank-allegro.lisp swank-backend.lisp
swank-clisp.lisp swank-cmucl.lisp swank-corman.lisp
swank-ecl.lisp swank-lispworks.lisp swank-openmcl.lisp
swank-sbcl.lisp swank-scl.lisp swank.lisp
Log Message:
* Improve the robustness of connection establishment.
--- /project/slime/cvsroot/slime/ChangeLog 2006/03/22 02:48:38 1.863
+++ /project/slime/cvsroot/slime/ChangeLog 2006/03/22 16:40:01 1.864
@@ -1,3 +1,30 @@
+2006-03-23 Douglas Crosher <dcrosher at 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-22 Matthias Koeppe <mkoeppe at mail.math.uni-magdeburg.de>
* slime.el (slime-ed): Handle (FILENAME :charpos CHARPOS).
--- /project/slime/cvsroot/slime/swank-allegro.lisp 2006/03/16 18:34:17 1.84
+++ /project/slime/cvsroot/slime/swank-allegro.lisp 2006/03/22 16:40:01 1.85
@@ -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)
--- /project/slime/cvsroot/slime/swank-backend.lisp 2006/02/25 12:10:33 1.96
+++ /project/slime/cvsroot/slime/swank-backend.lisp 2006/03/22 16:40:01 1.97
@@ -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) ())
--- /project/slime/cvsroot/slime/swank-clisp.lisp 2005/11/11 23:43:43 1.57
+++ /project/slime/cvsroot/slime/swank-clisp.lisp 2006/03/22 16:40:01 1.58
@@ -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
--- /project/slime/cvsroot/slime/swank-cmucl.lisp 2005/11/22 10:32:37 1.159
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2006/03/22 16:40:01 1.160
@@ -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)
--- /project/slime/cvsroot/slime/swank-corman.lisp 2005/11/11 23:43:43 1.5
+++ /project/slime/cvsroot/slime/swank-corman.lisp 2006/03/22 16:40:01 1.6
@@ -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)))))
--- /project/slime/cvsroot/slime/swank-ecl.lisp 2005/11/11 23:43:43 1.4
+++ /project/slime/cvsroot/slime/swank-ecl.lisp 2006/03/22 16:40:01 1.5
@@ -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))
--- /project/slime/cvsroot/slime/swank-lispworks.lisp 2006/02/10 16:54:01 1.82
+++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2006/03/22 16:40:01 1.83
@@ -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))
--- /project/slime/cvsroot/slime/swank-openmcl.lisp 2006/03/07 09:51:52 1.106
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2006/03/22 16:40:01 1.107
@@ -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))
--- /project/slime/cvsroot/slime/swank-sbcl.lisp 2006/01/20 21:31:20 1.152
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2006/03/22 16:40:01 1.153
@@ -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* '()
--- /project/slime/cvsroot/slime/swank-scl.lisp 2006/02/25 17:46:13 1.5
+++ /project/slime/cvsroot/slime/swank-scl.lisp 2006/03/22 16:40:01 1.6
@@ -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
--- /project/slime/cvsroot/slime/swank.lisp 2006/03/22 06:06:18 1.367
+++ /project/slime/cvsroot/slime/swank.lisp 2006/03/22 16:40:01 1.368
@@ -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,16 +529,23 @@
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
+ "Read and process one request. The processing is done in the extent
of the toplevel restart."
(assert (null *swank-state-stack*))
(let ((*swank-state-stack* '(:handle-request)))
@@ -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
More information about the slime-cvs
mailing list