From: Fredrik Tolf Date: Thu, 13 May 2010 01:35:32 +0000 (+0200) Subject: Made the address class model simpler and more useful (hopefully). X-Git-Url: http://dolda2000.com/gitweb/?p=lisp-utils.git;a=commitdiff_plain;h=b5018cad88ddc3109c7ae27b6eb249709f1bbc71 Made the address class model simpler and more useful (hopefully). --- diff --git a/common-net.lisp b/common-net.lisp index a0e6840..00ae20d 100644 --- a/common-net.lisp +++ b/common-net.lisp @@ -10,14 +10,13 @@ ;;; General declarations (defclass address () ()) - (defclass host-address (address) ()) (defclass inet-address (address) ()) - (defclass inet-host-address (inet-address host-address) ()) (defgeneric format-address (address)) +(defgeneric connected-address-p (address)) (defgeneric connect-to-address (target &key local)) (defgeneric bind-to-address (address)) (defgeneric close-socket (socket)) @@ -62,6 +61,9 @@ (princ (format-address address) stream)) address) +(defmethod connected-address-p ((address inet-host-address)) + nil) + (export '(address host-address inet-address inet-host-address format-address connect-to-address bind-to-address close-socket @@ -103,17 +105,21 @@ (define-condition socket-condition (condition) ((socket :initarg :socket :type socket))) -(define-condition address-busy (error) +(define-condition network-error (error) ()) + +(define-condition socket-error (socket-condition network-error) ()) + +(define-condition address-busy (network-error) ((address :initarg :address :type address)) (:report (lambda (c s) (format s "The address ~A is busy." (format-address (slot-value c 'address)))))) -(define-condition connection-refused (error) +(define-condition connection-refused (network-error) ((address :initarg :address :type address)) (:report (lambda (c s) (format s "Connection to ~A was refused by the remote host." (format-address (slot-value c 'address)))))) -(define-condition socket-closed (error socket-condition) () +(define-condition socket-closed (socket-error) () (:report (lambda (c s) (format s "The socket ~S is closed." (slot-value c 'socket))))) @@ -121,14 +127,18 @@ (:report (lambda (c s) (format s "The socket ~S has been closed from the other side." (slot-value c 'socket))))) -(define-condition simple-socket-error (simple-error socket-condition) ()) +(define-condition simple-socket-error (simple-error socket-error) ()) (defun simple-socket-error (socket format &rest args) (error 'simple-socket-error :socket socket :format-control format :format-arguments args)) +(export '(socket-condition network-error socket-error + address-busy connection-refused + socket-closed socket-disconnected simple-socket-error)) + ;;; Gray stream implementation for stream sockets -(define-condition stream-mode-error (socket-condition stream-error error) +(define-condition stream-mode-error (socket-error stream-error) ((expected-mode :initarg :expected-mode)) (:report (lambda (c s) (with-slots (expected-mode socket) c @@ -311,15 +321,12 @@ ;;; IPv4 addresses -(defclass ipv4-address (inet-host-address) - ((bytes :initarg :bytes :type (array (unsigned-byte 8) 4)))) +(defclass ipv4-address (inet-address) + ((host-bytes :type (array (unsigned-byte 8) 4)))) -(defun make-ipv4-address (o1 o2 o3 o4) - (make-instance 'ipv4-address :bytes (make-array '(4) - :element-type '(unsigned-byte 8) - :initial-contents (list o1 o2 o3 o4)))) +(defclass ipv4-host-address (ipv4-address inet-host-address) ()) -(defun parse-ipv4-address (string) +(defun parse-dotted-quad (string) (let ((o 0) (start 0) (string (concatenate 'string string ".")) @@ -331,7 +338,7 @@ (progn (setf (aref buf o) (let ((n (parse-integer string :start start :end i))) (if (and n (<= 0 n 255)) n - (error "IPv4 dottet-quad numbers must be octets")))) + (error "IPv4 dotted-quad numbers must be octets")))) (setf start (1+ i)) (incf o)) (error "Too many octets in IPv4 address"))) @@ -340,82 +347,97 @@ (t (error "Invalid character ~S in IPv4 address" ch))))) (if (< o 4) (error "Too few octets in IPv4 address") - (make-instance 'ipv4-address :bytes buf)))) + buf))) + +(defmethod initialize-instance :after ((instance ipv4-address) &key host-bytes host-string) + (let ((octets (or host-bytes + (when host-string (parse-dotted-quad host-string)) + '(0 0 0 0)))) + (assert (and (typep octets 'sequence) + (= (length octets) 4) + (every #'(lambda (o) (typep o '(unsigned-byte 8))) octets)) + (octets)) + (setf (slot-value instance 'host-bytes) + (make-array '(4) + :element-type '(unsigned-byte 8) + :initial-contents octets)))) + +(defun parse-ipv4-host-address (string) + (make-instance 'ipv4-host-address :host-string string)) (defmethod format-address ((address ipv4-address)) - (with-slots (bytes) address + (with-slots (host-bytes) address (format nil "~D.~D.~D.~D" - (aref bytes 0) - (aref bytes 1) - (aref bytes 2) - (aref bytes 3)))) + (aref host-bytes 0) + (aref host-bytes 1) + (aref host-bytes 2) + (aref host-bytes 3)))) (export '(ipv4-address make-ipv4-address parse-ipv4-address)) ;;; IPv6 addresses -(defclass ipv6-address (inet-host-address) - ((bytes :initarg :bytes :type (array (unsigned-byte 8) 16)))) +(defclass ipv6-address (inet-address) + ((host-bytes :initarg :bytes :type (array (unsigned-byte 8) 16)))) -(defun parse-ipv6-address (string) +(defclass ipv6-host-address (ipv6-address inet-host-address) ()) + +(defun parse-ipv6-string (string) (declare (ignore string)) (error "IPv6 parsing not implemented yet")) +(defmethod initialize-instance :after ((instance ipv6-address) &key host-bytes host-string) + (let ((octets (or host-bytes + (when host-string (parse-ipv6-string host-string)) + '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)))) + (assert (and (typep octets 'sequence) + (= (length octets) 16) + (every #'(lambda (o) (typep o '(unsigned-byte 8))) octets)) + (octets)) + (setf (slot-value instance 'host-bytes) + (make-array '(16) + :element-type '(unsigned-byte 8) + :initial-contents octets)))) + +(defun parse-ipv6-host-address (string) + (make-instance 'ipv6-host-address :host-string string)) + (export '(ipv6-address parse-ipv6-address)) ;;; TCP code (defclass inet-port-address (inet-address) - ((host :initarg :host :type (or null inet-host-address)) - (port :initarg :port :type (unsigned-byte 16)))) + ((port :initarg :port :type (unsigned-byte 16)))) + +(defmethod format-address ((address inet-port-address)) + (with-slots (port) address + (format nil "~A:~D" (call-next-method) port))) (defclass tcp-address (inet-port-address) ()) +(defclass tcp4-address (tcp-address ipv4-address) ()) +(defclass tcp6-address (tcp-address ipv6-address) ()) -(defmethod format-address ((address tcp-address)) - (with-slots (host port) address - (format nil "~A:~D" (if host (format-address host) "*") port))) - -(defun inet-resolve-colon-port (string) - (let ((colon (position #\: string))) - (if (null colon) - (error "No colon in TCP address")) - (if (find #\: string :start (1+ colon)) - (error "More than one colon in TCP address")) - (let ((port (parse-integer (subseq string (1+ colon)))) - (host (let ((host-part (subseq string 0 colon))) - (if (equal host-part "*") - nil - (resolve-address host-part))))) - (if (not (typep host '(or null inet-host-address))) - (error "Must have an internet address for TCP connections")) - (values host port)))) - -(defun resolve-tcp-colon-port (address) - (multiple-value-bind (host port) - (inet-resolve-colon-port address) - (make-instance 'tcp-address :host host :port port))) - -(export '(tcp-address resolve-tcp-colon-port)) +(defmethod connected-address-p ((address tcp-address)) t) + +(export '(tcp-address tcp4-address tcp6-address)) ;;; UDP code (defclass udp-address (inet-port-address) ()) +(defclass udp4-address (udp-address ipv4-address) ()) +(defclass udp6-address (udp-address ipv6-address) ()) -(defmethod format-address ((address udp-address)) - (with-slots (host port) address - (format nil "~A:~D" (if host (format-address host) "*") port))) - -(defun resolve-udp-colon-port (address) - (multiple-value-bind (host port) - (inet-resolve-colon-port address) - (make-instance 'udp-address :host host :port port))) +(defmethod connected-address-p ((address tcp-address)) nil) -(export '(udp-address resolve-udp-colon-port)) +(export '(udp-address udp4-address udp6-address)) ;;; Unix sockets (defclass local-address (address) - ((path :initarg :path :type pathname))) + ((path :type pathname))) + +(defmethod initialize-instance :after ((instance local-address) &key path) + (setf (slot-value instance 'path) (pathname path))) (defmethod format-address ((address local-address)) (namestring (slot-value address 'path))) @@ -424,11 +446,8 @@ (defclass local-seq-address (local-address) ()) (defclass local-datagram-address (local-address) ()) -(defun make-local-address (pathspec &optional (type :stream)) - (make-instance (ecase type - ((:stream) 'local-stream-address) - ((:seq) 'local-seq-address) - ((:datagram) 'local-datagram-address)) - :path (pathname pathspec))) +(defmethod connected-address-p ((address local-stream-address)) t) +(defmethod connected-address-p ((address local-seq-address)) t) +(defmethod connected-address-p ((address local-datagram-address)) nil) -(export '(local-address make-local-address)) +(export '(local-address local-stream-address local-seq-address local-datagram-address)) diff --git a/net-sb-bsd.lisp b/net-sb-bsd.lisp index 044f7d1..67d9c31 100644 --- a/net-sb-bsd.lisp +++ b/net-sb-bsd.lisp @@ -23,54 +23,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 + (error "SBCL does not support IPv6.")) (inet-host-address (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.")) (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 +70,15 @@ (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 (eql :connect))) '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) + (define-condition wrapped-socket-error (error socket-condition) ((cause :initarg :cause)) (:report (lambda (c s) @@ -98,7 +97,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)) @@ -177,8 +176,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,49 +185,28 @@ (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 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 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))))