Commit | Line | Data |
---|---|---|
dfa6197c FT |
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) ()) | |
145f3cee FT |
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) ()) | |
dfa6197c FT |
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) | |
b5018cad FT |
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))))) | |
dfa6197c FT |
40 | |
41 | (defun map-address-to-sbcl (sk address) | |
42 | (etypecase sk | |
43 | (sb-bsd-sockets:inet-socket | |
44 | (etypecase address | |
b5018cad FT |
45 | ((and ipv4-address inet-port-address) |
46 | (with-slots (host-bytes port) address | |
47 | (list host-bytes port))))) | |
dfa6197c FT |
48 | (sb-bsd-sockets:local-socket |
49 | (etypecase address | |
50 | (local-address | |
b5018cad | 51 | (list (namestring (slot-value address 'path)))))))) |
dfa6197c FT |
52 | |
53 | (defun sbcl-socket-type-and-args (address) | |
54 | (etypecase address | |
b5018cad FT |
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 | |
d1cf3c66 | 60 | (simple-network-error "SBCL does not support IPv6.")) |
dfa6197c | 61 | (inet-host-address |
d1cf3c66 | 62 | (simple-network-error "SBCL does not support raw sockets.")) |
dfa6197c | 63 | (local-stream-address |
b5018cad | 64 | '(sb-bsd-sockets:local-socket :type :stream)) |
dfa6197c | 65 | (local-seq-address |
d1cf3c66 | 66 | (simple-network-error "SBCL does not support Unix seqpacket sockets.")) |
dfa6197c | 67 | (local-datagram-address |
b5018cad | 68 | '(sb-bsd-sockets:local-socket :type :datagram)))) |
dfa6197c FT |
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 | ||
b5018cad | 78 | (defgeneric socket-class-for-address (address mode)) |
145f3cee | 79 | (defmethod socket-class-for-address ((address tcp-address) mode) 'sbcl-stream-socket) |
b5018cad FT |
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) | |
145f3cee FT |
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) | |
b5018cad | 88 | |
dfa6197c FT |
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) | |
b5018cad | 107 | `(loop (with-simple-restart (:retry ,format-string ,@format-args) |
dfa6197c FT |
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 | |
145f3cee | 147 | (simple-network-error "SB-BSD-SOCKETS does not support specifying the source address of individual packets.")) |
dfa6197c FT |
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 | ||
b5018cad FT |
186 | (defmethod bind-to-address ((address address)) |
187 | (make-instance (socket-class-for-address address :bind) | |
dfa6197c FT |
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)))) | |
b5018cad FT |
195 | (when (connected-address-p address) |
196 | (sb-bsd-sockets:socket-listen sk 64)) | |
dfa6197c FT |
197 | sk))) |
198 | ||
b5018cad FT |
199 | (defmethod connect-to-address ((remote address) &key local) |
200 | (make-instance (socket-class-for-address remote :connect) | |
dfa6197c | 201 | :sb-socket (with-sb-socket (sk (sb-bsd-socket-for-address (if local local remote))) |
b5018cad | 202 | (when local |
dfa6197c | 203 | (handler-bind |
b5018cad FT |
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.") | |
dfa6197c FT |
214 | (apply #'sb-bsd-sockets:socket-connect sk (map-address-to-sbcl sk remote)))) |
215 | sk))) | |
216 | ||
145f3cee FT |
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 | ||
dfa6197c FT |
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) | |
145f3cee FT |
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) | |
dfa6197c | 240 | (map-sbcl-to-address sk addr-list))))) |
145f3cee FT |
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)))) |