[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) ())
(defclass sbcl-unix-socket (sbcl-socket)
  ((unlink-name :type (or pathname nil) :initform nil)))
(defclass sbcl-unix-listen-socket (sbcl-listen-socket sbcl-unix-socket) ())
(defclass sbcl-unix-stream-socket (sbcl-stream-socket sbcl-unix-socket) ())
(defclass sbcl-unix-datagram-socket (sbcl-datagramx-socket sbcl-unix-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) '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-unix-stream-socket)
(defmethod socket-class-for-address ((address local-stream-address) (mode (eql :bind))) 'sbcl-unix-listen-socket)
(defmethod socket-class-for-address ((address local-seq-address) mode) 'sbcl-unix-datagram-socket)
(defmethod socket-class-for-address ((address local-seq-address) (mode (eql :bind))) 'sbcl-unix-listen-socket)
(defmethod socket-class-for-address ((address local-datagram-address) mode) 'sbcl-unix-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-SOCKETS 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 bind-to-address :around ((address local-address))
  (let ((ret (call-next-method)))
    (when (typep ret 'sbcl-unix-socket)
      (setf (slot-value ret 'unlink-name) (slot-value address 'path)))
    ret))

(defmethod connect-to-address :around ((remote local-address) &key local)
  (let ((ret (call-next-method)))
    (when (and (typep ret 'sbcl-unix-socket) (typep local 'local-address))
      (setf (slot-value ret 'unlink-name) (slot-value local 'path)))
    ret))

(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
			     ;; XXX: Should be
			     ;; (socket-class-for-address (map-sbcl-to-address sk (multiple-value-list (sb-bsd-sockets:socket-name sk))) :accept)
			     ;; but ECL does not support socket-name for Unix sockets.
			     :sb-socket sk)
	      (map-sbcl-to-address sk addr-list)))))

(defmethod close-socket :after ((socket sbcl-unix-socket))
  (with-slots (unlink-name) socket
    (when unlink-name
      (delete-file unlink-name)
      (setf unlink-name nil))))
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))
b5018cad FT	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)
b5018cad FT	196	(sb-bsd-sockets:socket-listen sk 64))
dfa6197c FT	197	sk)))
dfa6197c FT	198
b5018cad FT	199	(defmethod connect-to-address ((remote address) &key local)
b5018cad FT	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))))