Removed generic address resolution until a sane scheme can be found.
[lisp-utils.git] / net-sb-bsd.lisp
CommitLineData
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) ())
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)))))