[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) 'tcp4-address)
			((:datagram) 'udp4-address))
		      :host-bytes host
		      :port port)))
    (sb-bsd-sockets:local-socket
     (make-instance (ecase (sb-bsd-sockets:socket-type sk)
		      ((:stream) 'local-stream-address)
		      ((:datagram 'local-datagram-address)))
		    :path (first address)))))

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

(defun sbcl-socket-type-and-args (address)
  (etypecase address
    (tcp4-address
     '(sb-bsd-sockets:inet-socket :type :stream))
    (udp4-address
     '(sb-bsd-sockets:inet-socket :type :datagram))
    (ipv6-address
     (simple-network-error "SBCL does not support IPv6."))
    (inet-host-address
     (simple-network-error "SBCL does not support raw sockets."))
    (local-stream-address
     '(sb-bsd-sockets:local-socket :type :stream))
    (local-seq-address
     (simple-network-error "SBCL does not support Unix seqpacket sockets."))
    (local-datagram-address
     '(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)))

(defgeneric socket-class-for-address (address mode))
(defmethod socket-class-for-address ((address tcp-address) (mode (eql :connect))) 'sbcl-stream-socket)
(defmethod socket-class-for-address ((address tcp-address) (mode (eql :bind))) 'sbcl-listen-socket)
(defmethod socket-class-for-address ((address udp-address) mode) 'sbcl-datagram-socket)
(defmethod socket-class-for-address ((address inet-host-address) mode) 'sbcl-datagram-socket)
(defmethod socket-class-for-address ((address local-stream-address) mode) 'sbcl-stream-socket)
(defmethod socket-class-for-address ((address local-seq-address) mode) 'sbcl-datagram-socket)
(defmethod socket-class-for-address ((address local-datagram-address) mode) 'sbcl-datagram-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
    (simple-network-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 address))
  (make-instance (socket-class-for-address address :bind)
		 :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))))
			      (when (connected-address-p address)
				(sb-bsd-sockets:socket-listen sk 64))
			      sk)))

(defmethod connect-to-address ((remote address) &key local)
  (make-instance (socket-class-for-address remote :connect)
		 :sb-socket (with-sb-socket (sk (sb-bsd-socket-for-address (if local local remote)))
			      (when local
				(handler-bind
				    ((sb-bsd-sockets:address-in-use-error (lambda (c)
									    (declare (ignore c))
									    (error 'address-busy :address local))))
				  (retry-loop ("Try binding again.")
				    (apply #'sb-bsd-sockets:socket-bind sk (map-address-to-sbcl sk local)))))
			      (handler-bind
				  ((sb-bsd-sockets:connection-refused-error (lambda (c)
									      (declare (ignore c))
									      (error 'connection-refused :address remote))))
				(retry-loop ("Retry connection.")
				  (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)
b5018cad FT	26	((:stream) 'tcp4-address)
	27	((:datagram) 'udp4-address))
	28	:host-bytes host
	29	:port port)))
	30	(sb-bsd-sockets:local-socket
	31	(make-instance (ecase (sb-bsd-sockets:socket-type sk)
	32	((:stream) 'local-stream-address)
	33	((:datagram 'local-datagram-address)))
	34	:path (first address)))))
dfa6197c FT	35
	36	(defun map-address-to-sbcl (sk address)
	37	(etypecase sk
	38	(sb-bsd-sockets:inet-socket
	39	(etypecase address
b5018cad FT	40	((and ipv4-address inet-port-address)
	41	(with-slots (host-bytes port) address
	42	(list host-bytes port)))))
dfa6197c FT	43	(sb-bsd-sockets:local-socket
	44	(etypecase address
	45	(local-address
b5018cad	46	(list (namestring (slot-value address 'path))))))))
dfa6197c FT	47
	48	(defun sbcl-socket-type-and-args (address)
	49	(etypecase address
b5018cad FT	50	(tcp4-address
	51	'(sb-bsd-sockets:inet-socket :type :stream))
	52	(udp4-address
	53	'(sb-bsd-sockets:inet-socket :type :datagram))
	54	(ipv6-address
d1cf3c66	55	(simple-network-error "SBCL does not support IPv6."))
dfa6197c	56	(inet-host-address
d1cf3c66	57	(simple-network-error "SBCL does not support raw sockets."))
dfa6197c	58	(local-stream-address
b5018cad	59	'(sb-bsd-sockets:local-socket :type :stream))
dfa6197c	60	(local-seq-address
d1cf3c66	61	(simple-network-error "SBCL does not support Unix seqpacket sockets."))
dfa6197c	62	(local-datagram-address
b5018cad	63	'(sb-bsd-sockets:local-socket :type :datagram))))
dfa6197c FT	64
	65	(defun sb-bsd-socket-for-address (address)
	66	(apply #'make-instance (sbcl-socket-type-and-args address)))
	67
	68	(defun check-not-closed (socket)
	69	(declare (type sbcl-socket socket))
	70	(when (null (slot-value socket 'sb-socket))
	71	(error 'socket-closed :socket socket)))
	72
b5018cad FT	73	(defgeneric socket-class-for-address (address mode))
	74	(defmethod socket-class-for-address ((address tcp-address) (mode (eql :connect))) 'sbcl-stream-socket)
	75	(defmethod socket-class-for-address ((address tcp-address) (mode (eql :bind))) 'sbcl-listen-socket)
	76	(defmethod socket-class-for-address ((address udp-address) mode) 'sbcl-datagram-socket)
	77	(defmethod socket-class-for-address ((address inet-host-address) mode) 'sbcl-datagram-socket)
	78	(defmethod socket-class-for-address ((address local-stream-address) mode) 'sbcl-stream-socket)
	79	(defmethod socket-class-for-address ((address local-seq-address) mode) 'sbcl-datagram-socket)
	80	(defmethod socket-class-for-address ((address local-datagram-address) mode) 'sbcl-datagram-socket)
	81
dfa6197c FT	82	(define-condition wrapped-socket-error (error socket-condition)
	83	((cause :initarg :cause))
	84	(:report (lambda (c s)
	85	(princ (slot-value c 'cause) s))))
	86
	87	(defun map-sb-bsd-error (socket c)
	88	(cond ((eql (sb-bsd-sockets::socket-error-errno c) 32) ; EPIPE
	89	(error 'socket-disconnected :socket socket))
	90	((eql (sb-bsd-sockets::socket-error-errno c) 104) ; ECONNRESET
	91	(error 'socket-disconnected :socket socket))
	92	(t (error 'wrapped-socket-error :socket socket :cause c))))
	93
	94	(defmacro map-sb-bsd-errors ((socket) &body body)
	95	(let ((c (gensym "C")))
	96	`(handler-bind ((sb-bsd-sockets:socket-error (lambda (,c) (map-sb-bsd-error ,socket ,c))))
	97	,@body)))
	98
	99	(defmacro retry-loop ((format-string &rest format-args) &body body)
b5018cad	100	`(loop (with-simple-restart (:retry ,format-string ,@format-args)
dfa6197c FT	101	(return ,@body))))
	102
	103	(defmethod close-socket ((socket sbcl-socket))
	104	(with-slots (sb-socket) socket
	105	(unless (null sb-socket)
	106	(sb-bsd-sockets:socket-close sb-socket)
	107	(setf sb-socket nil))))
	108
	109	(defmethod socket-open-p ((socket sbcl-socket))
	110	(if (slot-value socket 'sb-socket) t nil))
	111
	112	(defmethod socket-local-address ((socket sbcl-socket))
	113	(check-not-closed socket)
	114	(with-slots (sb-socket) socket
	115	(map-sbcl-to-address sb-socket (multiple-value-list (sb-bsd-sockets:socket-name sb-socket)))))
	116
	117	(defmethod socket-remote-address ((socket sbcl-socket))
	118	(check-not-closed socket)
	119	(with-slots (sb-socket) socket
	120	(map-sbcl-to-address sb-socket (multiple-value-list (sb-bsd-sockets:socket-peername sb-socket)))))
	121
	122	(defmethod socket-send ((socket sbcl-socket) buf &key (start 0) (end (length buf)) no-hang)
	123	(check-not-closed socket)
	124	(let ((result (map-sb-bsd-errors (socket)
	125	(retry-loop ("Retry the send operation.")
	126	(sb-bsd-sockets:socket-send (slot-value socket 'sb-socket)
	127	(if (= start 0)
	128	buf
	129	(subseq buf start end))
	130	(- end start)
	131	:nosignal t
	132	:dontwait no-hang)))))
	133	(etypecase result
	134	(null 0)
	135	(integer result))))
	136
	137	(defmethod socket-send-to ((socket sbcl-socket) buf destination &key (start 0) (end (length buf)) from no-hang)
	138	(check-not-closed socket)
	139	(when from
d1cf3c66	140	(simple-network-error "SB-BSD-THREADS does not support specifying the source address of individual packets."))
dfa6197c FT	141	(let ((result (map-sb-bsd-errors (socket)
	142	(retry-loop ("Retry the send operation.")
	143	(sb-bsd-sockets:socket-send (slot-value socket 'sb-socket)
	144	(if (= start 0)
	145	buf
	146	(subseq buf start end))
	147	(- end start)
	148	:address (map-address-to-sbcl socket destination)
	149	:nosignal t
	150	:dontwait no-hang)))))
	151	(etypecase result
	152	(null 0)
	153	(integer result))))
	154
	155	(defmethod socket-recv-into ((socket sbcl-socket) buf &key (start 0) (end (length buf)) no-hang)
	156	(check-not-closed socket)
	157	(check-type buf sequence)
	158	(let* ((direct (and (= start 0) (typep buf '(array (unsigned-byte 8)))))
	159	(readbuf (if direct
	160	buf
	161	(make-array (list (- end start)) :element-type '(unsigned-byte 8))))
	162	(ret-list (multiple-value-list
	163	(map-sb-bsd-errors (socket)
	164	(retry-loop ("Try receiving again.")
	165	(sb-bsd-sockets:socket-receive (slot-value socket 'sb-socket)
	166	readbuf
	167	(- end start)
	168	:dontwait no-hang
	169	:element-type '(unsigned-byte 8))))))
	170	(len (second ret-list))
	171	(addr-list (cddr ret-list)))
	172	(etypecase len
	173	(null (values nil nil))
	174	(integer
	175	(unless direct
	176	(replace buf readbuf :start1 start :end2 len))
	177	(values len (map-sbcl-to-address (slot-value socket 'sb-socket) addr-list))))))
	178
b5018cad FT	179	(defmethod bind-to-address ((address address))
b5018cad FT	180	(make-instance (socket-class-for-address address :bind)
dfa6197c FT	181	:sb-socket (with-sb-socket (sk (sb-bsd-socket-for-address address))
	182	(handler-bind
	183	((sb-bsd-sockets:address-in-use-error (lambda (c)
	184	(declare (ignore c))
	185	(error 'address-busy :address address))))
	186	(retry-loop ("Try binding again.")
	187	(apply #'sb-bsd-sockets:socket-bind sk (map-address-to-sbcl sk address))))
b5018cad FT	188	(when (connected-address-p address)
b5018cad FT	189	(sb-bsd-sockets:socket-listen sk 64))
dfa6197c FT	190	sk)))
dfa6197c FT	191
b5018cad FT	192	(defmethod connect-to-address ((remote address) &key local)
b5018cad FT	193	(make-instance (socket-class-for-address remote :connect)
dfa6197c	194	:sb-socket (with-sb-socket (sk (sb-bsd-socket-for-address (if local local remote)))
b5018cad	195	(when local
dfa6197c	196	(handler-bind
b5018cad FT	197	((sb-bsd-sockets:address-in-use-error (lambda (c)
	198	(declare (ignore c))
	199	(error 'address-busy :address local))))
	200	(retry-loop ("Try binding again.")
	201	(apply #'sb-bsd-sockets:socket-bind sk (map-address-to-sbcl sk local)))))
	202	(handler-bind
	203	((sb-bsd-sockets:connection-refused-error (lambda (c)
	204	(declare (ignore c))
	205	(error 'connection-refused :address remote))))
	206	(retry-loop ("Retry connection.")
dfa6197c FT	207	(apply #'sb-bsd-sockets:socket-connect sk (map-address-to-sbcl sk remote))))
	208	sk)))
	209
dfa6197c FT	210	(defmethod accept ((socket sbcl-listen-socket))
	211	(check-not-closed socket)
	212	(let* ((ret-list (multiple-value-list (sb-bsd-sockets:socket-accept (slot-value socket 'sb-socket))))
	213	(sk (first ret-list))
	214	(addr-list (rest ret-list)))
	215	(with-sb-socket (sk sk)
	216	(values (make-instance 'sbcl-stream-socket :sb-socket sk)
	217	(map-sbcl-to-address sk addr-list)))))