Changeset 15310

Timestamp:

Apr 10, 2012, 2:58:35 AM (13 years ago)

Author:

Gary Byers

Message:

SOCKET-ERRORs from failed connection attempts report remote address.
Fixes ticket:941.

File:

• trunk/source/level-1/l1-sockets.lisp (modified) (11 diffs)

trunk/source/level-1/l1-sockets.lisp

@@ -184 +184 @@
   ((code :initarg :code :reader socket-creation-error-code)
    (identifier :initform :unknown :initarg :identifier :reader socket-creation-error-identifier)
-   (situation :initarg :situation :reader socket-creation-error-situation)))
+   (situation :initarg :situation :reader socket-creation-error-situation)
+   (remote-address :initform nil :initarg :remote-address :accessor socket-creation-error-remote-address)))
 
 (defparameter *gai-error-identifiers*
@@ -234 +235 @@
 (defun socket-call (stream where res)
   (if (< res 0)
-    (socket-error stream where res)
+    (socket-error stream where res nil)
     res))
 
@@ -244 +245 @@
       (%get-cstring p))))
 
-(defun socket-error (stream where errno &optional nameserver-p)
+(defun get-error-address-info (info)
+  (let* ((sockaddr (getf info :sockaddr)))
+    (when sockaddr
+      (if (= #$AF_INET (pref sockaddr :sockaddr_in.sin_family))
+        (list (ntohl (pref sockaddr
+                            #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr
+                            #+(or solaris-target windows-target) #>sockaddr_in.sin_addr.S_un.S_addr))
+              (ntohs (pref sockaddr :sockaddr_in.sin_port)))
+        (if (= #$AF_UNIX (pref sockaddr :sockaddr_un.sun_family))
+          (path-from-unix-address sockaddr))))))
+               
+
+        
+
+                         
+(defun socket-error (stream where errno nameserver-p &rest info)
   "Creates and signals (via error) one of two socket error 
 conditions, based on the state of the arguments."
@@ -262 +278 @@
                                               (%strerror errno)
                                               errno where)))
-    (let ((identifiers (if nameserver-p
-                         *gai-error-identifiers*
-                         *socket-error-identifiers*)))
+    (let* ((identifiers (if nameserver-p
+                          *gai-error-identifiers*
+                          *socket-error-identifiers*))
+           (connect-address (get-error-address-info info))
+           (format-control (if nameserver-p
+                             "~a (error #~d) during nameserver operation in ~a"
+                             (if connect-address
+                               "~a (error #~d) during attempt to connect to ~a"
+                               "~a (error #~d) during socket creation operation in ~a")))
+           (format-arguments (if connect-address
+                               (list
+                                #+windows-target
+                                (%windows-error-string errno)
+                                #-windows-target
+                                (if nameserver-p
+                                  (%gai-strerror errno)
+                                  (%strerror errno))
+                                errno (if (atom connect-address)
+                                        connect-address
+                                        (format nil "~a:~d" (ipaddr-to-dotted (car connect-address)) (cadr connect-address))))
+                               (list
+                                #+windows-target
+                                (%windows-error-string errno)
+                                #-windows-target
+                                (if nameserver-p
+                                  (%gai-strerror errno)
+                                  (%strerror errno))
+                                errno where))))
+                              
       (error (make-condition 'socket-creation-error
                              :code errno
                              :identifier (getf identifiers errno :unknown)
                              :situation where
-                             :format-control "~a (error #~d) during socket creation or nameserver operation in ~a"
-                             :format-arguments (list
-                                                #+windows-target
-                                                (%windows-error-string errno)
-                                                #-windows-target
-                                                (if nameserver-p
-                                                  (%gai-strerror errno)
-                                                  (%strerror errno))
-                                                errno where))))))
+                             :format-control format-control
+                             :format-arguments format-arguments
+                             :remote-address connect-address)))))
 
 ;; If true, this will try to allow other cooperative processes to run
@@ -513 +549 @@
           (let ((err (c_getpeername fd sockaddr namelen)))
             (cond ((eql err (- #+windows-target #$WSAENOTCONN #-windows-target #$ENOTCONN)) nil)
-                  ((< err 0) (socket-error socket "getpeername" err))
+                  ((< err 0) (socket-error socket "getpeername" err nil))
                   (t
                    (when (= #$AF_INET (pref sockaddr :sockaddr_in.sin_family))
@@ -530 +566 @@
           (let* ((err (c_getsockname fd addr namelen)))
             (cond ((eql err (- #$ENOTCONN)) nil)
-                  ((< err 0) (socket-error socket "getpeername" err))
+                  ((< err 0) (socket-error socket "getpeername" err nil))
                   (t (path-from-unix-address addr)))))))
 
@@ -744 +780 @@
   (let* ((err (c_connect fd addr addrlen timeout-in-milliseconds)))
     (declare (fixnum err))
-    (unless (eql err 0) (fd-close fd) (socket-error nil "connect" err))))
+    (unless (eql err 0) (fd-close fd) (socket-error nil "connect" err nil :sockaddr addr))))
     
 (defun inet-connect (fd host-n port-n &optional timeout-in-milliseconds)
@@ -913 +949 @@
                  (setq fd -1)))
               ((eql fd (- #$EAGAIN)) nil)
-              (t (socket-error socket "accept" fd))))
+              (t (socket-error socket "accept" fd nil))))
       (when (>= fd 0)
         (fd-close fd)))))
@@ -1050 +1086 @@
         (string (_getservbyname port proto))
         (symbol (_getservbyname (string-downcase (symbol-name port)) proto)))
-      (socket-error nil "getservbyname" (- #$ENOENT))))
+      (socket-error nil "getservbyname" (- #$ENOENT) nil)))
 
 (defun lookup-port (port proto)
@@ -1110 +1146 @@
                (eql 4 (pref vallen :signed)))
         (pref valptr :signed)
-        (socket-error socket "getsockopt" err)))))
+        (socket-error socket "getsockopt" err nil)))))
 
 (defun timeval-setsockopt (socket level optname timeout)
@@ -1519 +1555 @@
           
 (defmethod stream-io-error ((stream socket) errno where)
-  (socket-error stream where errno))
+  (socket-error stream where errno nil))