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