Made the address class model simpler and more useful (hopefully).
authorFredrik Tolf <fredrik@dolda2000.com>
Thu, 13 May 2010 01:35:32 +0000 (03:35 +0200)
committerFredrik Tolf <fredrik@dolda2000.com>
Thu, 13 May 2010 01:35:32 +0000 (03:35 +0200)
common-net.lisp
net-sb-bsd.lisp

index a0e6840..00ae20d 100644 (file)
 ;;; General declarations
 
 (defclass address () ())
 ;;; General declarations
 
 (defclass address () ())
-
 (defclass host-address (address) ())
 
 (defclass inet-address (address) ())
 (defclass host-address (address) ())
 
 (defclass inet-address (address) ())
-
 (defclass inet-host-address (inet-address host-address) ())
 
 (defgeneric format-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))
 (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)
 
       (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
 (export '(address host-address inet-address inet-host-address
          format-address
          connect-to-address bind-to-address close-socket
 (define-condition socket-condition (condition)
   ((socket :initarg :socket :type socket)))
 
 (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))))))
 
   ((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))))))
 
   ((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)))))
 
   (:report (lambda (c s)
             (format s "The socket ~S is closed." (slot-value c 'socket)))))
 
   (:report (lambda (c s)
             (format s "The socket ~S has been closed from the other side." (slot-value c 'socket)))))
 
   (: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))
 
 
 (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
 
 ;;; 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
   ((expected-mode :initarg :expected-mode))
   (:report (lambda (c s)
             (with-slots (expected-mode socket) c
 
 ;;; IPv4 addresses
 
 
 ;;; 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 "."))
   (let ((o 0)
        (start 0)
        (string (concatenate 'string string "."))
                   (progn (setf (aref buf o) (let ((n (parse-integer string :start start :end i)))
                                               (if (and n (<= 0 n 255))
                                                   n
                   (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")))
                          (setf start (1+ i))
                          (incf o))
                   (error "Too many octets in IPv4 address")))
              (t (error "Invalid character ~S in IPv4 address" ch)))))
     (if (< o 4)
        (error "Too few octets in IPv4 address")
              (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))
 
 (defmethod format-address ((address ipv4-address))
-  (with-slots (bytes) address
+  (with-slots (host-bytes) address
     (format nil "~D.~D.~D.~D"
     (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
 
 
 (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"))
 
   (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)
 (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 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) ())
 
 ;;; 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)
 
 ;;; 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)))
 
 (defmethod format-address ((address local-address))
   (namestring (slot-value address 'path)))
 (defclass local-seq-address (local-address) ())
 (defclass local-datagram-address (local-address) ())
 
 (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))
index 044f7d1..67d9c31 100644 (file)
      (let ((host (first address))
           (port (second address)))
        (make-instance (ecase (sb-bsd-sockets:socket-type sk)
      (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
 
 (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
     (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
 
 (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
     (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
     (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)))
 
 (defun sb-bsd-socket-for-address (address)
   (apply #'make-instance (sbcl-socket-type-and-args address)))
   (when (null (slot-value socket 'sb-socket))
     (error 'socket-closed :socket socket)))
 
   (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)
 (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)
        ,@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))
           (return ,@body))))
 
 (defmethod close-socket ((socket sbcl-socket))
         (replace buf readbuf :start1 start :end2 len))
        (values len (map-sbcl-to-address (slot-value socket 'sb-socket) addr-list))))))
 
         (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)
                 :sb-socket (with-sb-socket (sk (sb-bsd-socket-for-address address))
                              (handler-bind
                                  ((sb-bsd-sockets:address-in-use-error (lambda (c)
                                                                          (error 'address-busy :address address))))
                                (retry-loop ("Try binding again.")
                                  (apply #'sb-bsd-sockets:socket-bind sk (map-address-to-sbcl sk address))))
                                                                          (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)))
 
                              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)))
                 :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
                                (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)))
 
                                  (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))))
 (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))))