[lisp-utils.git] / net-sb-bsd.lisp

(in-package :common-net)

(defclass sbcl-socket (socket)
  ((sb-socket :initarg :sb-socket :type sb-bsd-sockets:socket)))
(defclass sbcl-listen-socket (listen-socket sbcl-socket) ())
(defclass sbcl-stream-socket (stream-socket sbcl-socket) ())
(defclass sbcl-datagram-socket (datagram-socket sbcl-socket) ())

(defmacro with-sb-socket ((var socket) &body body)
  (let ((success (gensym "SUCCESS")))
    `(let ((,var ,socket)
	   (,success nil))
       (unwind-protect
	    (multiple-value-prog1
		(progn ,@body)
	      (setf ,success t))
	 (unless ,success
	   (sb-bsd-sockets:socket-close ,var))))))

(defun map-sbcl-to-address (sk address)
  (etypecase sk
    (sb-bsd-sockets:inet-socket
     (let ((host (first address))
	   (port (second address)))
       (make-instance (ecase (sb-bsd-sockets:socket-type sk)
			((:stream) 'tcp-address)
			((:datagram) 'udp-address))
		      :host (if (every #'zerop host)
				nil
				(make-instance 'ipv4-address :bytes host))
		      :port port)))))

(defun map-address-to-sbcl (sk address)
  (etypecase sk
    (sb-bsd-sockets:inet-socket
     (etypecase address
       (inet-port-address
	(with-slots (host port) address
	  (list (etypecase host
		  (null #(0 0 0 0))
		  (ipv4-address (slot-value host 'bytes)))
		port)))))
    (sb-bsd-sockets:local-socket
     (etypecase address
       (local-address
	(namestring (slot-value address 'path)))))))

(defun sbcl-socket-type-and-args (address)
  (etypecase address
    (inet-port-address
     (let ((type (etypecase address
		   (tcp-address :stream)
		   (udp-address :datagram))))
       (with-slots (host port) address
	 (etypecase host
	   (null
	    ;; This should probably be changed to use IPv6 when SBCL
	    ;; supports it. At least on Linux, since it supports
	    ;; v4-mapping, but it is less clear what to do on the
	    ;; BSDs.
	    (list 'sb-bsd-sockets:inet-socket :type type))
	   (ipv4-address
	    (list 'sb-bsd-sockets:inet-socket :type type))
	   (ipv6-address
	    (error "SBCL does not support IPv6."))))))
    (inet-host-address
     (error "SBCL does not support raw sockets."))
    (local-stream-address
     (list 'sb-bsd-sockets:local-socket :type :stream))
    (local-seq-address
     (error "SBCL does not support Unix seqpacket sockets."))
    (local-datagram-address
     (list 'sb-bsd-sockets:local-socket :type :datagram))))

(defun sb-bsd-socket-for-address (address)
  (apply #'make-instance (sbcl-socket-type-and-args address)))

(defun check-not-closed (socket)
  (declare (type sbcl-socket socket))
  (when (null (slot-value socket 'sb-socket))
    (error 'socket-closed :socket socket)))

(define-condition wrapped-socket-error (error socket-condition)
  ((cause :initarg :cause))
  (:report (lambda (c s)
	     (princ (slot-value c 'cause) s))))

(defun map-sb-bsd-error (socket c)
  (cond ((eql (sb-bsd-sockets::socket-error-errno c) 32)  ; EPIPE
	 (error 'socket-disconnected :socket socket))
	((eql (sb-bsd-sockets::socket-error-errno c) 104) ; ECONNRESET
	 (error 'socket-disconnected :socket socket))
	(t (error 'wrapped-socket-error :socket socket :cause c))))

(defmacro map-sb-bsd-errors ((socket) &body body)
  (let ((c (gensym "C")))
    `(handler-bind ((sb-bsd-sockets:socket-error (lambda (,c) (map-sb-bsd-error ,socket ,c))))
       ,@body)))

(defmacro retry-loop ((format-string &rest format-args) &body body)
  `(loop (with-simple-restart (retry ,format-string ,@format-args)
	   (return ,@body))))

(defmethod close-socket ((socket sbcl-socket))
  (with-slots (sb-socket) socket
    (unless (null sb-socket)
      (sb-bsd-sockets:socket-close sb-socket)
      (setf sb-socket nil))))

(defmethod socket-open-p ((socket sbcl-socket))
  (if (slot-value socket 'sb-socket) t nil))

(defmethod socket-local-address ((socket sbcl-socket))
  (check-not-closed socket)
  (with-slots (sb-socket) socket
    (map-sbcl-to-address sb-socket (multiple-value-list (sb-bsd-sockets:socket-name sb-socket)))))

(defmethod socket-remote-address ((socket sbcl-socket))
  (check-not-closed socket)
  (with-slots (sb-socket) socket
    (map-sbcl-to-address sb-socket (multiple-value-list (sb-bsd-sockets:socket-peername sb-socket)))))

(defmethod socket-send ((socket sbcl-socket) buf &key (start 0) (end (length buf)) no-hang)
  (check-not-closed socket)
  (let ((result (map-sb-bsd-errors (socket)
		  (retry-loop ("Retry the send operation.")
		    (sb-bsd-sockets:socket-send (slot-value socket 'sb-socket)
						(if (= start 0)
						    buf
						    (subseq buf start end))
						(- end start)
						:nosignal t
						:dontwait no-hang)))))
    (etypecase result
      (null 0)
      (integer result))))

(defmethod socket-send-to ((socket sbcl-socket) buf destination &key (start 0) (end (length buf)) from no-hang)
  (check-not-closed socket)
  (when from
    (error "SB-BSD-THREADS does not support specifying the source address of individual packets."))
  (let ((result (map-sb-bsd-errors (socket)
		  (retry-loop ("Retry the send operation.")
		    (sb-bsd-sockets:socket-send (slot-value socket 'sb-socket)
						(if (= start 0)
						    buf
						    (subseq buf start end))
						(- end start)
						:address (map-address-to-sbcl socket destination)
						:nosignal t
						:dontwait no-hang)))))
    (etypecase result
      (null 0)
      (integer result))))

(defmethod socket-recv-into ((socket sbcl-socket) buf &key (start 0) (end (length buf)) no-hang)
  (check-not-closed socket)
  (check-type buf sequence)
  (let* ((direct (and (= start 0) (typep buf '(array (unsigned-byte 8)))))
	 (readbuf (if direct
		      buf
		      (make-array (list (- end start)) :element-type '(unsigned-byte 8))))
	 (ret-list (multiple-value-list
		    (map-sb-bsd-errors (socket)
		      (retry-loop ("Try receiving again.")
			(sb-bsd-sockets:socket-receive (slot-value socket 'sb-socket)
								  readbuf
								  (- end start)
								  :dontwait no-hang
								  :element-type '(unsigned-byte 8))))))
	 (len (second ret-list))
	 (addr-list (cddr ret-list)))
    (etypecase len
      (null (values nil nil))
      (integer
       (unless direct
	 (replace buf readbuf :start1 start :end2 len))
       (values len (map-sbcl-to-address (slot-value socket 'sb-socket) addr-list))))))

(defmethod bind-to-address ((address tcp-address))
  (make-instance 'sbcl-listen-socket
		 :sb-socket (with-sb-socket (sk (sb-bsd-socket-for-address address))
			      (handler-bind
				  ((sb-bsd-sockets:address-in-use-error (lambda (c)
									  (declare (ignore c))
									  (error 'address-busy :address address))))
				(retry-loop ("Try binding again.")
				  (apply #'sb-bsd-sockets:socket-bind sk (map-address-to-sbcl sk address))))
			      (sb-bsd-sockets:socket-listen sk 64)
			      sk)))

(defmethod connect-to-address ((remote tcp-address) &key local)
  (typecase local
    (string (setf local (resolve-address local))))
  (make-instance 'sbcl-stream-socket
		 :sb-socket (with-sb-socket (sk (sb-bsd-socket-for-address (if local local remote)))
			      (if local
				  (handler-case
				      (apply #'sb-bsd-sockets:socket-bind sk (map-address-to-sbcl sk local))
				    (sb-bsd-sockets:address-in-use-error ()
				      (error 'address-busy :address local))))
			      (retry-loop ("Retry connection.")
				(handler-bind
				    ((sb-bsd-sockets:connection-refused-error (lambda (c)
										(declare (ignore c))
										(error 'connection-refused :address remote))))
				  (apply #'sb-bsd-sockets:socket-connect sk (map-address-to-sbcl sk remote))))
			      sk)))

(defmethod bind-to-address ((address udp-address))
  (make-instance 'sbcl-datagram-socket
		 :sb-socket (with-sb-socket (sk (sb-bsd-socket-for-address address))
			      (handler-case
				  (apply #'sb-bsd-sockets:socket-bind sk (map-address-to-sbcl sk address))
				(sb-bsd-sockets:address-in-use-error ()
				  (error 'address-busy :address address)))
			      sk)))

(defmethod connect-to-address ((remote udp-address) &key local)
  (typecase local
    (string (setf local (resolve-address local))))
  (make-instance 'sbcl-datagram-socket
		 :sb-socket (with-sb-socket (sk (sb-bsd-socket-for-address (if local local remote)))
			      (if local
				  (handler-case
				      (apply #'sb-bsd-sockets:socket-bind sk (map-address-to-sbcl sk local))
				    (sb-bsd-sockets:address-in-use-error ()
				      (error 'address-busy :address local))))
			      (apply #'sb-bsd-sockets:socket-connect sk (map-address-to-sbcl sk remote))
			      sk)))

(defmethod accept ((socket sbcl-listen-socket))
  (check-not-closed socket)
  (let* ((ret-list (multiple-value-list (sb-bsd-sockets:socket-accept (slot-value socket 'sb-socket))))
	 (sk (first ret-list))
	 (addr-list (rest ret-list)))
    (with-sb-socket (sk sk)
      (values (make-instance 'sbcl-stream-socket :sb-socket sk)
	      (map-sbcl-to-address sk addr-list)))))
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) ())
	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)))))