net-sb-bsd.lisp

   1 (in-package :common-net)
   2
   3 (defclass sbcl-socket (socket)
   4   ((sb-socket :initarg :sb-socket :type sb-bsd-sockets:socket)))
   5 (defclass sbcl-listen-socket (listen-socket sbcl-socket) ())
   6 (defclass sbcl-stream-socket (stream-socket sbcl-socket) ())
   7 (defclass sbcl-datagram-socket (datagram-socket sbcl-socket) ())
   8 (defclass sbcl-unix-socket (sbcl-socket)
   9   ((unlink-name :type (or pathname nil) :initform nil)))
  10 (defclass sbcl-unix-listen-socket (sbcl-listen-socket sbcl-unix-socket) ())
  11 (defclass sbcl-unix-stream-socket (sbcl-stream-socket sbcl-unix-socket) ())
  12 (defclass sbcl-unix-datagram-socket (sbcl-datagramx-socket sbcl-unix-socket) ())
  13
  14 (defmacro with-sb-socket ((var socket) &body body)
  15   (let ((success (gensym "SUCCESS")))
  16     `(let ((,var ,socket)
  17            (,success nil))
  18        (unwind-protect
  19             (multiple-value-prog1
  20                 (progn ,@body)
  21               (setf ,success t))
  22          (unless ,success
  23            (sb-bsd-sockets:socket-close ,var))))))
  24
  25 (defun map-sbcl-to-address (sk address)
  26   (etypecase sk
  27     (sb-bsd-sockets:inet-socket
  28      (let ((host (first address))
  29            (port (second address)))
  30        (make-instance (ecase (sb-bsd-sockets:socket-type sk)
  31                         ((:stream) 'tcp4-address)
  32                         ((:datagram) 'udp4-address))
  33                       :host-bytes host
  34                       :port port)))
  35     (sb-bsd-sockets:local-socket
  36      (make-instance (ecase (sb-bsd-sockets:socket-type sk)
  37                       ((:stream) 'local-stream-address)
  38                       ((:datagram 'local-datagram-address)))
  39                     :path (first address)))))
  40
  41 (defun map-address-to-sbcl (sk address)
  42   (etypecase sk
  43     (sb-bsd-sockets:inet-socket
  44      (etypecase address
  45        ((and ipv4-address inet-port-address)
  46         (with-slots (host-bytes port) address
  47           (list host-bytes port)))))
  48     (sb-bsd-sockets:local-socket
  49      (etypecase address
  50        (local-address
  51         (list (namestring (slot-value address 'path))))))))
  52
  53 (defun sbcl-socket-type-and-args (address)
  54   (etypecase address
  55     (tcp4-address
  56      '(sb-bsd-sockets:inet-socket :type :stream))
  57     (udp4-address
  58      '(sb-bsd-sockets:inet-socket :type :datagram))
  59     (ipv6-address
  60      (simple-network-error "SBCL does not support IPv6."))
  61     (inet-host-address
  62      (simple-network-error "SBCL does not support raw sockets."))
  63     (local-stream-address
  64      '(sb-bsd-sockets:local-socket :type :stream))
  65     (local-seq-address
  66      (simple-network-error "SBCL does not support Unix seqpacket sockets."))
  67     (local-datagram-address
  68      '(sb-bsd-sockets:local-socket :type :datagram))))
  69
  70 (defun sb-bsd-socket-for-address (address)
  71   (apply #'make-instance (sbcl-socket-type-and-args address)))
  72
  73 (defun check-not-closed (socket)
  74   (declare (type sbcl-socket socket))
  75   (when (null (slot-value socket 'sb-socket))
  76     (error 'socket-closed :socket socket)))
  77
  78 (defgeneric socket-class-for-address (address mode))
  79 (defmethod socket-class-for-address ((address tcp-address) mode) 'sbcl-stream-socket)
  80 (defmethod socket-class-for-address ((address tcp-address) (mode (eql :bind))) 'sbcl-listen-socket)
  81 (defmethod socket-class-for-address ((address udp-address) mode) 'sbcl-datagram-socket)
  82 (defmethod socket-class-for-address ((address inet-host-address) mode) 'sbcl-datagram-socket)
  83 (defmethod socket-class-for-address ((address local-stream-address) mode) 'sbcl-unix-stream-socket)
  84 (defmethod socket-class-for-address ((address local-stream-address) (mode (eql :bind))) 'sbcl-unix-listen-socket)
  85 (defmethod socket-class-for-address ((address local-seq-address) mode) 'sbcl-unix-datagram-socket)
  86 (defmethod socket-class-for-address ((address local-seq-address) (mode (eql :bind))) 'sbcl-unix-listen-socket)
  87 (defmethod socket-class-for-address ((address local-datagram-address) mode) 'sbcl-unix-datagram-socket)
  88
  89 (define-condition wrapped-socket-error (error socket-condition)
  90   ((cause :initarg :cause))
  91   (:report (lambda (c s)
  92              (princ (slot-value c 'cause) s))))
  93
  94 (defun map-sb-bsd-error (socket c)
  95   (cond ((eql (sb-bsd-sockets::socket-error-errno c) 32)  ; EPIPE
  96          (error 'socket-disconnected :socket socket))
  97         ((eql (sb-bsd-sockets::socket-error-errno c) 104) ; ECONNRESET
  98          (error 'socket-disconnected :socket socket))
  99         (t (error 'wrapped-socket-error :socket socket :cause c))))
 100
 101 (defmacro map-sb-bsd-errors ((socket) &body body)
 102   (let ((c (gensym "C")))
 103     `(handler-bind ((sb-bsd-sockets:socket-error (lambda (,c) (map-sb-bsd-error ,socket ,c))))
 104        ,@body)))
 105
 106 (defmacro retry-loop ((format-string &rest format-args) &body body)
 107   `(loop (with-simple-restart (:retry ,format-string ,@format-args)
 108            (return ,@body))))
 109
 110 (defmethod close-socket ((socket sbcl-socket))
 111   (with-slots (sb-socket) socket
 112     (unless (null sb-socket)
 113       (sb-bsd-sockets:socket-close sb-socket)
 114       (setf sb-socket nil))))
 115
 116 (defmethod socket-open-p ((socket sbcl-socket))
 117   (if (slot-value socket 'sb-socket) t nil))
 118
 119 (defmethod socket-local-address ((socket sbcl-socket))
 120   (check-not-closed socket)
 121   (with-slots (sb-socket) socket
 122     (map-sbcl-to-address sb-socket (multiple-value-list (sb-bsd-sockets:socket-name sb-socket)))))
 123
 124 (defmethod socket-remote-address ((socket sbcl-socket))
 125   (check-not-closed socket)
 126   (with-slots (sb-socket) socket
 127     (map-sbcl-to-address sb-socket (multiple-value-list (sb-bsd-sockets:socket-peername sb-socket)))))
 128
 129 (defmethod socket-send ((socket sbcl-socket) buf &key (start 0) (end (length buf)) no-hang)
 130   (check-not-closed socket)
 131   (let ((result (map-sb-bsd-errors (socket)
 132                   (retry-loop ("Retry the send operation.")
 133                     (sb-bsd-sockets:socket-send (slot-value socket 'sb-socket)
 134                                                 (if (= start 0)
 135                                                     buf
 136                                                     (subseq buf start end))
 137                                                 (- end start)
 138                                                 :nosignal t
 139                                                 :dontwait no-hang)))))
 140     (etypecase result
 141       (null 0)
 142       (integer result))))
 143
 144 (defmethod socket-send-to ((socket sbcl-socket) buf destination &key (start 0) (end (length buf)) from no-hang)
 145   (check-not-closed socket)
 146   (when from
 147     (simple-network-error "SB-BSD-SOCKETS does not support specifying the source address of individual packets."))
 148   (let ((result (map-sb-bsd-errors (socket)
 149                   (retry-loop ("Retry the send operation.")
 150                     (sb-bsd-sockets:socket-send (slot-value socket 'sb-socket)
 151                                                 (if (= start 0)
 152                                                     buf
 153                                                     (subseq buf start end))
 154                                                 (- end start)
 155                                                 :address (map-address-to-sbcl socket destination)
 156                                                 :nosignal t
 157                                                 :dontwait no-hang)))))
 158     (etypecase result
 159       (null 0)
 160       (integer result))))
 161
 162 (defmethod socket-recv-into ((socket sbcl-socket) buf &key (start 0) (end (length buf)) no-hang)
 163   (check-not-closed socket)
 164   (check-type buf sequence)
 165   (let* ((direct (and (= start 0) (typep buf '(array (unsigned-byte 8)))))
 166          (readbuf (if direct
 167                       buf
 168                       (make-array (list (- end start)) :element-type '(unsigned-byte 8))))
 169          (ret-list (multiple-value-list
 170                     (map-sb-bsd-errors (socket)
 171                       (retry-loop ("Try receiving again.")
 172                         (sb-bsd-sockets:socket-receive (slot-value socket 'sb-socket)
 173                                                                   readbuf
 174                                                                   (- end start)
 175                                                                   :dontwait no-hang
 176                                                                   :element-type '(unsigned-byte 8))))))
 177          (len (second ret-list))
 178          (addr-list (cddr ret-list)))
 179     (etypecase len
 180       (null (values nil nil))
 181       (integer
 182        (unless direct
 183          (replace buf readbuf :start1 start :end2 len))
 184        (values len (map-sbcl-to-address (slot-value socket 'sb-socket) addr-list))))))
 185
 186 (defmethod bind-to-address ((address address))
 187   (make-instance (socket-class-for-address address :bind)
 188                  :sb-socket (with-sb-socket (sk (sb-bsd-socket-for-address address))
 189                               (handler-bind
 190                                   ((sb-bsd-sockets:address-in-use-error (lambda (c)
 191                                                                           (declare (ignore c))
 192                                                                           (error 'address-busy :address address))))
 193                                 (retry-loop ("Try binding again.")
 194                                   (apply #'sb-bsd-sockets:socket-bind sk (map-address-to-sbcl sk address))))
 195                               (when (connected-address-p address)
 196                                 (sb-bsd-sockets:socket-listen sk 64))
 197                               sk)))
 198
 199 (defmethod connect-to-address ((remote address) &key local)
 200   (make-instance (socket-class-for-address remote :connect)
 201                  :sb-socket (with-sb-socket (sk (sb-bsd-socket-for-address (if local local remote)))
 202                               (when local
 203                                 (handler-bind
 204                                     ((sb-bsd-sockets:address-in-use-error (lambda (c)
 205                                                                             (declare (ignore c))
 206                                                                             (error 'address-busy :address local))))
 207                                   (retry-loop ("Try binding again.")
 208                                     (apply #'sb-bsd-sockets:socket-bind sk (map-address-to-sbcl sk local)))))
 209                               (handler-bind
 210                                   ((sb-bsd-sockets:connection-refused-error (lambda (c)
 211                                                                               (declare (ignore c))
 212                                                                               (error 'connection-refused :address remote))))
 213                                 (retry-loop ("Retry connection.")
 214                                   (apply #'sb-bsd-sockets:socket-connect sk (map-address-to-sbcl sk remote))))
 215                               sk)))
 216
 217 (defmethod bind-to-address :around ((address local-address))
 218   (let ((ret (call-next-method)))
 219     (when (typep ret 'sbcl-unix-socket)
 220       (setf (slot-value ret 'unlink-name) (slot-value address 'path)))
 221     ret))
 222
 223 (defmethod connect-to-address :around ((remote local-address) &key local)
 224   (let ((ret (call-next-method)))
 225     (when (and (typep ret 'sbcl-unix-socket) (typep local 'local-address))
 226       (setf (slot-value ret 'unlink-name) (slot-value local 'path)))
 227     ret))
 228
 229 (defmethod accept ((socket sbcl-listen-socket))
 230   (check-not-closed socket)
 231   (let* ((ret-list (multiple-value-list (sb-bsd-sockets:socket-accept (slot-value socket 'sb-socket))))
 232          (sk (first ret-list))
 233          (addr-list (rest ret-list)))
 234     (with-sb-socket (sk sk)
 235       (values (make-instance 'sbcl-stream-socket
 236                              ;; XXX: Should be
 237                              ;; (socket-class-for-address (map-sbcl-to-address sk (multiple-value-list (sb-bsd-sockets:socket-name sk))) :accept)
 238                              ;; but ECL does not support socket-name for Unix sockets.
 239                              :sb-socket sk)
 240               (map-sbcl-to-address sk addr-list)))))
 241
 242 (defmethod close-socket :after ((socket sbcl-unix-socket))
 243   (with-slots (unlink-name) socket
 244     (when unlink-name
 245       (delete-file unlink-name)
 246       (setf unlink-name nil))))