1 (in-package :common-net)
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) ())
9 (defmacro with-sb-socket ((var socket) &body body)
10 (let ((success (gensym "SUCCESS")))
18 (sb-bsd-sockets:socket-close ,var))))))
20 (defun map-sbcl-to-address (sk address)
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)
30 (make-instance 'ipv4-address :bytes host))
33 (defun map-address-to-sbcl (sk address)
35 (sb-bsd-sockets:inet-socket
38 (with-slots (host port) address
41 (ipv4-address (slot-value host 'bytes)))
43 (sb-bsd-sockets:local-socket
46 (namestring (slot-value address 'path)))))))
48 (defun sbcl-socket-type-and-args (address)
51 (let ((type (etypecase address
53 (udp-address :datagram))))
54 (with-slots (host port) address
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
61 (list 'sb-bsd-sockets:inet-socket :type type))
63 (list 'sb-bsd-sockets:inet-socket :type type))
65 (error "SBCL does not support IPv6."))))))
67 (error "SBCL does not support raw sockets."))
69 (list 'sb-bsd-sockets:local-socket :type :stream))
71 (error "SBCL does not support Unix seqpacket sockets."))
72 (local-datagram-address
73 (list 'sb-bsd-sockets:local-socket :type :datagram))))
75 (defun sb-bsd-socket-for-address (address)
76 (apply #'make-instance (sbcl-socket-type-and-args address)))
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)))
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))))
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))))
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))))
100 (defmacro retry-loop ((format-string &rest format-args) &body body)
101 `(loop (with-simple-restart (retry ,format-string ,@format-args)
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))))
110 (defmethod socket-open-p ((socket sbcl-socket))
111 (if (slot-value socket 'sb-socket) t nil))
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)))))
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)))))
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)
130 (subseq buf start end))
133 :dontwait no-hang)))))
138 (defmethod socket-send-to ((socket sbcl-socket) buf destination &key (start 0) (end (length buf)) from no-hang)
139 (check-not-closed socket)
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)
147 (subseq buf start end))
149 :address (map-address-to-sbcl socket destination)
151 :dontwait no-hang)))))
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)))))
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)
170 :element-type '(unsigned-byte 8))))))
171 (len (second ret-list))
172 (addr-list (cddr ret-list)))
174 (null (values nil nil))
177 (replace buf readbuf :start1 start :end2 len))
178 (values len (map-sbcl-to-address (slot-value socket 'sb-socket) addr-list))))))
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))
184 ((sb-bsd-sockets:address-in-use-error (lambda (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)
192 (defmethod connect-to-address ((remote tcp-address) &key 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)))
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.")
204 ((sb-bsd-sockets:connection-refused-error (lambda (c)
206 (error 'connection-refused :address remote))))
207 (apply #'sb-bsd-sockets:socket-connect sk (map-address-to-sbcl sk remote))))
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))
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)))
219 (defmethod connect-to-address ((remote udp-address) &key 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)))
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))
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)))))