X-Git-Url: http://dolda2000.com/gitweb/?p=lisp-utils.git;a=blobdiff_plain;f=net-sb-bsd.lisp;fp=net-sb-bsd.lisp;h=044f7d174b15917908bcf9c42861ab941564f810;hp=0000000000000000000000000000000000000000;hb=dfa6197cf07772bba6cc056c35672b7f8c4d0f3b;hpb=53d1dafed1900b44f42acacfd14c3beae1c3af22 diff --git a/net-sb-bsd.lisp b/net-sb-bsd.lisp new file mode 100644 index 0000000..044f7d1 --- /dev/null +++ b/net-sb-bsd.lisp @@ -0,0 +1,239 @@ +(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)))))