From: Fredrik Tolf Date: Sun, 15 Aug 2010 07:40:47 +0000 (+0200) Subject: Fixed up Unix sockets a bit. X-Git-Url: http://git.dolda2000.com/gitweb/?a=commitdiff_plain;h=145f3ceec97386f00e6bdf33a72a4817b1cb5d20;p=lisp-utils.git Fixed up Unix sockets a bit. * Support anonymous addresses. * Clean up bound names when closing. --- diff --git a/common-net.lisp b/common-net.lisp index 10fc919..57a5b84 100644 --- a/common-net.lisp +++ b/common-net.lisp @@ -461,13 +461,14 @@ ;;; Unix sockets (defclass local-address (address) - ((path :type pathname))) + ((path :type (or pathname nil)))) (defmethod initialize-instance :after ((instance local-address) &key path) - (setf (slot-value instance 'path) (pathname path))) + (setf (slot-value instance 'path) (and path (pathname path)))) (defmethod format-address ((address local-address)) - (namestring (slot-value address 'path))) + (let ((path (slot-value address 'path))) + (and path (namestring path)))) (defclass local-stream-address (local-address) ()) (defclass local-seq-address (local-address) ()) diff --git a/net-ecl.lisp b/net-ecl.lisp index 3f80737..3388954 100644 --- a/net-ecl.lisp +++ b/net-ecl.lisp @@ -71,3 +71,8 @@ (defmethod gray:stream-write-sequence ((socket stream-socket) seq &optional (start 0) (end (length seq))) (gray-stream-write-sequence socket seq start end)) + +;;; Error cover-up + +(defmethod sb-bsd-sockets:socket-name ((sk sb-bsd-sockets:local-socket)) + (simple-network-error "ECL does not support reading the name of Unix sockets.")) diff --git a/net-sb-bsd.lisp b/net-sb-bsd.lisp index 9c757c5..3d2affd 100644 --- a/net-sb-bsd.lisp +++ b/net-sb-bsd.lisp @@ -5,6 +5,11 @@ (defclass sbcl-listen-socket (listen-socket sbcl-socket) ()) (defclass sbcl-stream-socket (stream-socket sbcl-socket) ()) (defclass sbcl-datagram-socket (datagram-socket sbcl-socket) ()) +(defclass sbcl-unix-socket (sbcl-socket) + ((unlink-name :type (or pathname nil) :initform nil))) +(defclass sbcl-unix-listen-socket (sbcl-listen-socket sbcl-unix-socket) ()) +(defclass sbcl-unix-stream-socket (sbcl-stream-socket sbcl-unix-socket) ()) +(defclass sbcl-unix-datagram-socket (sbcl-datagramx-socket sbcl-unix-socket) ()) (defmacro with-sb-socket ((var socket) &body body) (let ((success (gensym "SUCCESS"))) @@ -71,13 +76,15 @@ (error 'socket-closed :socket socket))) (defgeneric socket-class-for-address (address mode)) -(defmethod socket-class-for-address ((address tcp-address) (mode (eql :connect))) 'sbcl-stream-socket) +(defmethod socket-class-for-address ((address tcp-address) mode) 'sbcl-stream-socket) (defmethod socket-class-for-address ((address tcp-address) (mode (eql :bind))) 'sbcl-listen-socket) (defmethod socket-class-for-address ((address udp-address) mode) 'sbcl-datagram-socket) (defmethod socket-class-for-address ((address inet-host-address) mode) 'sbcl-datagram-socket) -(defmethod socket-class-for-address ((address local-stream-address) mode) 'sbcl-stream-socket) -(defmethod socket-class-for-address ((address local-seq-address) mode) 'sbcl-datagram-socket) -(defmethod socket-class-for-address ((address local-datagram-address) mode) 'sbcl-datagram-socket) +(defmethod socket-class-for-address ((address local-stream-address) mode) 'sbcl-unix-stream-socket) +(defmethod socket-class-for-address ((address local-stream-address) (mode (eql :bind))) 'sbcl-unix-listen-socket) +(defmethod socket-class-for-address ((address local-seq-address) mode) 'sbcl-unix-datagram-socket) +(defmethod socket-class-for-address ((address local-seq-address) (mode (eql :bind))) 'sbcl-unix-listen-socket) +(defmethod socket-class-for-address ((address local-datagram-address) mode) 'sbcl-unix-datagram-socket) (define-condition wrapped-socket-error (error socket-condition) ((cause :initarg :cause)) @@ -137,7 +144,7 @@ (defmethod socket-send-to ((socket sbcl-socket) buf destination &key (start 0) (end (length buf)) from no-hang) (check-not-closed socket) (when from - (simple-network-error "SB-BSD-THREADS does not support specifying the source address of individual packets.")) + (simple-network-error "SB-BSD-SOCKETS does not support specifying the source address of individual packets.")) (let ((result (map-sb-bsd-errors (socket) (retry-loop ("Retry the send operation.") (sb-bsd-sockets:socket-send (slot-value socket 'sb-socket) @@ -207,11 +214,33 @@ (apply #'sb-bsd-sockets:socket-connect sk (map-address-to-sbcl sk remote)))) sk))) +(defmethod bind-to-address :around ((address local-address)) + (let ((ret (call-next-method))) + (when (typep ret 'sbcl-unix-socket) + (setf (slot-value ret 'unlink-name) (slot-value address 'path))) + ret)) + +(defmethod connect-to-address :around ((remote local-address) &key local) + (let ((ret (call-next-method))) + (when (and (typep ret 'sbcl-unix-socket) (typep local 'local-address)) + (setf (slot-value ret 'unlink-name) (slot-value local 'path))) + ret)) + (defmethod accept ((socket sbcl-listen-socket)) (check-not-closed socket) (let* ((ret-list (multiple-value-list (sb-bsd-sockets:socket-accept (slot-value socket 'sb-socket)))) (sk (first ret-list)) (addr-list (rest ret-list))) (with-sb-socket (sk sk) - (values (make-instance 'sbcl-stream-socket :sb-socket sk) + (values (make-instance 'sbcl-stream-socket + ;; XXX: Should be + ;; (socket-class-for-address (map-sbcl-to-address sk (multiple-value-list (sb-bsd-sockets:socket-name sk))) :accept) + ;; but ECL does not support socket-name for Unix sockets. + :sb-socket sk) (map-sbcl-to-address sk addr-list))))) + +(defmethod close-socket :after ((socket sbcl-unix-socket)) + (with-slots (unlink-name) socket + (when unlink-name + (delete-file unlink-name) + (setf unlink-name nil))))