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