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