X-Git-Url: http://dolda2000.com/gitweb/?p=lisp-utils.git;a=blobdiff_plain;f=net-sb-bsd.lisp;h=3d2affd78244d7592143bc28262352e092495b02;hp=044f7d174b15917908bcf9c42861ab941564f810;hb=HEAD;hpb=dfa6197cf07772bba6cc056c35672b7f8c4d0f3b diff --git a/net-sb-bsd.lisp b/net-sb-bsd.lisp index 044f7d1..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"))) @@ -23,54 +28,44 @@ (let ((host (first address)) (port (second address))) (make-instance (ecase (sb-bsd-sockets:socket-type sk) - ((:stream) 'tcp-address) - ((:datagram) 'udp-address)) - :host (if (every #'zerop host) - nil - (make-instance 'ipv4-address :bytes host)) - :port port))))) + ((:stream) 'tcp4-address) + ((:datagram) 'udp4-address)) + :host-bytes host + :port port))) + (sb-bsd-sockets:local-socket + (make-instance (ecase (sb-bsd-sockets:socket-type sk) + ((:stream) 'local-stream-address) + ((:datagram 'local-datagram-address))) + :path (first address))))) (defun map-address-to-sbcl (sk address) (etypecase sk (sb-bsd-sockets:inet-socket (etypecase address - (inet-port-address - (with-slots (host port) address - (list (etypecase host - (null #(0 0 0 0)) - (ipv4-address (slot-value host 'bytes))) - port))))) + ((and ipv4-address inet-port-address) + (with-slots (host-bytes port) address + (list host-bytes port))))) (sb-bsd-sockets:local-socket (etypecase address (local-address - (namestring (slot-value address 'path))))))) + (list (namestring (slot-value address 'path)))))))) (defun sbcl-socket-type-and-args (address) (etypecase address - (inet-port-address - (let ((type (etypecase address - (tcp-address :stream) - (udp-address :datagram)))) - (with-slots (host port) address - (etypecase host - (null - ;; This should probably be changed to use IPv6 when SBCL - ;; supports it. At least on Linux, since it supports - ;; v4-mapping, but it is less clear what to do on the - ;; BSDs. - (list 'sb-bsd-sockets:inet-socket :type type)) - (ipv4-address - (list 'sb-bsd-sockets:inet-socket :type type)) - (ipv6-address - (error "SBCL does not support IPv6.")))))) + (tcp4-address + '(sb-bsd-sockets:inet-socket :type :stream)) + (udp4-address + '(sb-bsd-sockets:inet-socket :type :datagram)) + (ipv6-address + (simple-network-error "SBCL does not support IPv6.")) (inet-host-address - (error "SBCL does not support raw sockets.")) + (simple-network-error "SBCL does not support raw sockets.")) (local-stream-address - (list 'sb-bsd-sockets:local-socket :type :stream)) + '(sb-bsd-sockets:local-socket :type :stream)) (local-seq-address - (error "SBCL does not support Unix seqpacket sockets.")) + (simple-network-error "SBCL does not support Unix seqpacket sockets.")) (local-datagram-address - (list 'sb-bsd-sockets:local-socket :type :datagram)))) + '(sb-bsd-sockets:local-socket :type :datagram)))) (defun sb-bsd-socket-for-address (address) (apply #'make-instance (sbcl-socket-type-and-args address))) @@ -80,6 +75,17 @@ (when (null (slot-value socket 'sb-socket)) (error 'socket-closed :socket socket))) +(defgeneric socket-class-for-address (address mode)) +(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-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)) (:report (lambda (c s) @@ -98,7 +104,7 @@ ,@body))) (defmacro retry-loop ((format-string &rest format-args) &body body) - `(loop (with-simple-restart (retry ,format-string ,@format-args) + `(loop (with-simple-restart (:retry ,format-string ,@format-args) (return ,@body)))) (defmethod close-socket ((socket sbcl-socket)) @@ -138,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 - (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) @@ -177,8 +183,8 @@ (replace buf readbuf :start1 start :end2 len)) (values len (map-sbcl-to-address (slot-value socket 'sb-socket) addr-list)))))) -(defmethod bind-to-address ((address tcp-address)) - (make-instance 'sbcl-listen-socket +(defmethod bind-to-address ((address address)) + (make-instance (socket-class-for-address address :bind) :sb-socket (with-sb-socket (sk (sb-bsd-socket-for-address address)) (handler-bind ((sb-bsd-sockets:address-in-use-error (lambda (c) @@ -186,48 +192,39 @@ (error 'address-busy :address address)))) (retry-loop ("Try binding again.") (apply #'sb-bsd-sockets:socket-bind sk (map-address-to-sbcl sk address)))) - (sb-bsd-sockets:socket-listen sk 64) + (when (connected-address-p address) + (sb-bsd-sockets:socket-listen sk 64)) sk))) -(defmethod connect-to-address ((remote tcp-address) &key local) - (typecase local - (string (setf local (resolve-address local)))) - (make-instance 'sbcl-stream-socket +(defmethod connect-to-address ((remote address) &key local) + (make-instance (socket-class-for-address remote :connect) :sb-socket (with-sb-socket (sk (sb-bsd-socket-for-address (if local local remote))) - (if local - (handler-case - (apply #'sb-bsd-sockets:socket-bind sk (map-address-to-sbcl sk local)) - (sb-bsd-sockets:address-in-use-error () - (error 'address-busy :address local)))) - (retry-loop ("Retry connection.") + (when local (handler-bind - ((sb-bsd-sockets:connection-refused-error (lambda (c) - (declare (ignore c)) - (error 'connection-refused :address remote)))) + ((sb-bsd-sockets:address-in-use-error (lambda (c) + (declare (ignore c)) + (error 'address-busy :address local)))) + (retry-loop ("Try binding again.") + (apply #'sb-bsd-sockets:socket-bind sk (map-address-to-sbcl sk local))))) + (handler-bind + ((sb-bsd-sockets:connection-refused-error (lambda (c) + (declare (ignore c)) + (error 'connection-refused :address remote)))) + (retry-loop ("Retry connection.") (apply #'sb-bsd-sockets:socket-connect sk (map-address-to-sbcl sk remote)))) sk))) -(defmethod bind-to-address ((address udp-address)) - (make-instance 'sbcl-datagram-socket - :sb-socket (with-sb-socket (sk (sb-bsd-socket-for-address address)) - (handler-case - (apply #'sb-bsd-sockets:socket-bind sk (map-address-to-sbcl sk address)) - (sb-bsd-sockets:address-in-use-error () - (error 'address-busy :address address))) - 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 ((remote udp-address) &key local) - (typecase local - (string (setf local (resolve-address local)))) - (make-instance 'sbcl-datagram-socket - :sb-socket (with-sb-socket (sk (sb-bsd-socket-for-address (if local local remote))) - (if local - (handler-case - (apply #'sb-bsd-sockets:socket-bind sk (map-address-to-sbcl sk local)) - (sb-bsd-sockets:address-in-use-error () - (error 'address-busy :address local)))) - (apply #'sb-bsd-sockets:socket-connect sk (map-address-to-sbcl sk remote)) - sk))) +(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) @@ -235,5 +232,15 @@ (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))))