From 2c9b0034294888786b6f94b337ed7b2bc1ba7662 Mon Sep 17 00:00:00 2001 From: Vibhu Mohindra Date: Wed, 19 Apr 2017 22:44:37 +0100 Subject: [PATCH] handle-condition was incorrect for CLISP. As a result, there were all sorts of socket errors when a remote client closed a connection or we (the server) timed out a socket that we were also blocked reading on. I've fixed this for Mac and Linux, for CLISP 2.49 and 2.49+ (2010-07-17). So it should continue to work for future versions of CLISP. I don't have access to Windows, so I don't know if it will work there. I also don't know if it used to work there before my change. I haven't tested this on client sockets. ---- test set up ;hunchentoot is listening on localhost:8000, like this: (ql:quickload "hunchentoot") (use-package "HUNCHENTOOT") (setf *default-connection-timeout* 5) ;seconds (define-easy-handler (h1 :uri "/h1") () (setf (content-type*) "text/plain") "hallo") (defparameter *acc* (make-instance 'easy-acceptor :port 8000)) (start *acc*) test 1 nc localhost 8000 followed immediately by Ctrl-C clisp should print nothing test 2 nc localhost 8000 followed by a 5 second wait should make netcat end clisp should print nothing test 3 echo -e 'GET /h1 HTTP/1.0\r\n\r\n' | nc localhost 8000 should print "hallo" clisp should only print one line showing that the http request was handled test4 mac: echo | nc localhost 8000 linux: echo | nc -q 1 localhost 8000 clisp should print nothing ---- - = none fail blank = untested failing-tests mac linux-2.49 rpi-2.49+-2010-07-17 clisp - - - sbcl - - ccl - - sbcl my *default-connection-timeout* hunchentoot setting doesn't seem to take effect. netcat times out in 20 seconds, not 5. this is on both mac and linux --- backend/clisp.lisp | 58 ++++++++++++++++++++++++++-------------------- 1 file changed, 33 insertions(+), 25 deletions(-) diff --git a/backend/clisp.lisp b/backend/clisp.lisp index 62d3af5..5b88524 100644 --- a/backend/clisp.lisp +++ b/backend/clisp.lisp @@ -66,7 +66,11 @@ (:ESHUTDOWN . already-shutdown-error) (:ETIMEDOUT . timeout-error) (:EHOSTDOWN . host-down-error) - (:EHOSTUNREACH . host-unreachable-error)) + (:EHOSTUNREACH . host-unreachable-error) + ;; when blocked reading, and we close our socket due to a timeout. + ;; POSIX.1 says that EAGAIN and EWOULDBLOCK may have the same values. + (:EAGAIN . timeout-error) + (:EWOULDBLOCK . timeout-error)) ;linux #+win32 `((:WSAEADDRINUSE . address-in-use-error) (:WSAEADDRNOTAVAIL . address-not-available-error) @@ -89,31 +93,35 @@ (:WSAEHOSTDOWN . host-down-error) (:WSAEHOSTUNREACH . host-unreachable-error))) +(defun parse-errno (condition) + "Returns a number or keyword if it can parse what is within parens, else NIL" + (let ((s (princ-to-string condition))) + (let ((pos1 (position #\( s)) + (pos2 (position #\) s))) + ;mac: number, linux: keyword + (ignore-errors + (if (digit-char-p (char s (1+ pos1))) + (parse-integer s :start (1+ pos1) :end pos2) + (let ((*package* (find-package "KEYWORD"))) + (car (read-from-string s t nil :start pos1 :end (1+ pos2))))))))) + (defun handle-condition (condition &optional (socket nil)) - "Dispatch correct usocket condition." - (let (error-keyword error-string) - (typecase condition - (ext:os-error - (let ((errno (car (simple-condition-format-arguments condition)))) - #+ffi - (setq error-keyword (os:errno errno) - error-string (os:strerror errno)))) - (simple-error - (let ((keyword - (car (simple-condition-format-arguments condition)))) - (setq error-keyword keyword) - #+ffi - (setq error-string (os:strerror keyword)))) - (error (error 'unknown-error :real-error condition)) - (condition (signal 'unknown-condition :real-condition condition))) - (when error-keyword - (let ((usocket-error - (cdr (assoc error-keyword +clisp-error-map+ :test #'eq)))) - (if usocket-error - (if (subtypep usocket-error 'error) - (error usocket-error :socket socket) - (signal usocket-error :socket socket)) - (error "Unknown OS error: ~A (~A)" error-string error-keyword)))))) + "Dispatch a usocket condition instead of a CLISP specific one, if we can." + (let ((errno + (cond + ;clisp 2.49+ + ((typep condition (find-symbol "OS-STREAM-ERROR" "EXT")) + (parse-errno condition)) + ;clisp 2.49 + ((typep condition (find-symbol "SIMPLE-STREAM-ERROR" "SYSTEM")) + (car (simple-condition-format-arguments condition)))))) + (when errno + (let ((error-keyword (if (keywordp errno) errno #+ffi(os:errno errno)))) + (let ((usocket-error (cdr (assoc error-keyword +clisp-error-map+)))) + (when usocket-error + (if (subtypep usocket-error 'error) + (error usocket-error :socket socket) + (signal usocket-error :socket socket)))))))) (defun socket-connect (host port &key (protocol :stream) (element-type 'character) timeout deadline (nodelay t nodelay-specified)