From: Fredrik Tolf Date: Thu, 13 May 2010 14:06:49 +0000 (+0200) Subject: COMMON-NET: Added TCP implementation for ABCL. X-Git-Url: http://dolda2000.com/gitweb/?p=lisp-utils.git;a=commitdiff_plain;h=a95b7451611a6c54642c362d1b18ec450dc82d7a;hp=cc4296f0b9606708699cda908c0c766a703a2136 COMMON-NET: Added TCP implementation for ABCL. --- diff --git a/common-net.asd b/common-net.asd index 5546fc8..dbb69e9 100644 --- a/common-net.asd +++ b/common-net.asd @@ -5,4 +5,5 @@ #+sbcl (:file "net-sbcl") #+ecl (:file "net-ecl") #+(or sbcl ecl) (:file "net-sb-bsd") ; ECL uses SB-BSD-SOCKETS + #+abcl (:file "net-abcl") #+clisp (:file "net-clisp"))) diff --git a/net-abcl.lisp b/net-abcl.lisp new file mode 100644 index 0000000..15e7e53 --- /dev/null +++ b/net-abcl.lisp @@ -0,0 +1,239 @@ +(in-package :common-net) + +(require :gray-streams) + +;;; Gray stream methods + +;; Redefine stream-socket with Gray superclasses. I know it's ugly, +;; but I just don't know of a better way to do it. +(defclass stream-socket (socket gray-streams:fundamental-character-input-stream gray-streams:fundamental-character-output-stream + gray-streams:fundamental-binary-input-stream gray-streams:fundamental-binary-output-stream) + ((mode :initform :byte) + (byte-buffer :initform (make-array '(16) :element-type '(unsigned-byte 8) :adjustable t) + :type (array (unsigned-byte 8))) + (byte-read-pos :initform 0 :type integer) + (byte-write-pos :initform 0 :type integer) + (char-buffer :initform (make-array '(16) :element-type 'character :adjustable t :fill-pointer 0) + :type (array character)) + (char-read-pos :initform 0 :type integer) + encoder decoder)) + +(macrolet ((simple (name) + `(defmethod + ,(intern (symbol-name name) (find-package :gray-streams)) ((socket stream-socket)) + (,(intern (concatenate 'string "GRAY-" (symbol-name name)) (symbol-package 'stream-socket)) socket))) + (simple-null (name) + `(defmethod + ,(intern (symbol-name name) (find-package :gray-streams)) ((socket stream-socket)) + nil))) + (simple stream-element-type) + (simple open-stream-p) + (simple stream-read-byte) + (simple stream-read-char) + (simple stream-read-char-no-hang) + (simple stream-peek-char) + (simple stream-listen) + (simple-null stream-line-column) + (simple-null stream-finish-output) + (simple-null stream-force-output) + (simple-null stream-clear-output)) + +(defmethod gray-streams:stream-write-byte ((socket stream-socket) byte) + (gray-stream-write-char socket byte)) + +(defmethod gray-streams:stream-unread-char ((socket stream-socket) char) + (gray-stream-unread-char socket char)) + +(defmethod gray-streams:stream-write-char ((socket stream-socket) char) + (gray-stream-write-char socket char)) + +(defmethod gray-streams:stream-close ((socket stream-socket) &key abort) + (declare (ignore abort)) + (prog1 + (call-next-method) + (close-socket socket))) + +(defmethod gray-streams:stream-start-line-p ((socket stream-socket)) + (eql (gray-streams:stream-line-column socket) 0)) + +(defmethod gray-streams:stream-fresh-line ((socket stream-socket)) + (unless (gray-streams:stream-start-line-p socket) + (gray-streams:stream-terpri socket) + t)) + +(defmethod gray-streams:stream-write-string ((socket stream-socket) string &optional (start 0) (end (length string))) + (gray-streams:stream-write-sequence socket string start end)) + +(defmethod gray-streams:stream-terpri ((socket stream-socket)) + (gray-streams:stream-write-char socket #\newline)) + +(defmethod gray-streams:stream-read-sequence ((socket stream-socket) seq &optional (start 0) (end (length seq))) + (gray-stream-read-sequence socket seq start end)) + +(defmethod gray-streams:stream-write-sequence ((socket stream-socket) seq &optional (start 0) (end (length seq))) + (gray-stream-write-sequence socket seq start end)) + +;;; Networking implementation + +(defclass abcl-socket (socket) + ((java-socket :initarg :java-socket) + (java-channel :initarg :java-channel))) +(defclass abcl-listen-socket (listen-socket abcl-socket) ()) +(defclass abcl-stream-socket (stream-socket abcl-socket) ()) +(defclass abcl-datagram-socket (datagram-socket abcl-socket) ()) + +(defparameter *sk-jclass* (java:jclass "java.net.Socket")) +(defparameter *dsk-jclass* (java:jclass "java.net.ServerSocket")) +(defparameter *ssk-jclass* (java:jclass "java.net.DatagramSocket")) +(defparameter *sc-jclass* (java:jclass "java.nio.channels.SocketChannel")) +(defparameter *dc-jclass* (java:jclass "java.nio.channels.DatagramChannel")) +(defparameter *ssc-jclass* (java:jclass "java.nio.channels.ServerSocketChannel")) +(defparameter *selc-jclass* (java:jclass "java.nio.channels.SelectableChannel")) +(defparameter *wc-jclass* (java:jclass "java.nio.channels.WritableByteChannel")) +(defparameter *rc-jclass* (java:jclass "java.nio.channels.ReadableByteChannel")) +(defparameter *bbuf-jclass* (java:jclass "java.nio.ByteBuffer")) +(defparameter *ia-jclass* (java:jclass "java.net.InetAddress")) +(defparameter *i4a-jclass* (java:jclass "java.net.Inet4Address")) +(defparameter *i6a-jclass* (java:jclass "java.net.Inet6Address")) +(defparameter *sa-jclass* (java:jclass "java.net.SocketAddress")) +(defparameter *isa-jclass* (java:jclass "java.net.InetSocketAddress")) +(defparameter *int-jclass* (java:jclass "int")) + +(defun jclose-channel (jsk) + (let ((meth (java:jmethod *selc-jclass* "close"))) + (java:jcall meth jsk))) + +(defmacro with-java-channel ((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 + (jclose-channel ,var)))))) + +;; These are probably horribly inefficient, but I haven't found any +;; better way of doing it. +(defun make-jarray (seq &optional (start 0) (end (length seq))) + (let ((byte (java:jclass "byte"))) + (let ((jarray (java:jnew-array byte (- end start)))) + (dotimes (i (- end start)) + (java:jcall (java:jmethod (java:jclass "java.lang.reflect.Array") "setByte" (java:jclass "java.lang.Object") *int-jclass* byte) + nil jarray i (elt seq (+ start i)))) + jarray))) + +(defun undo-jarray (jarray &optional (into (make-array (list (java:jarray-length jarray)))) (start 0) (end (length into))) + (dotimes (i (- end start)) + (setf (elt into (+ i start)) (java:jarray-ref jarray i))) + into) + +(defun map-socket-address (address) + (check-type address inet-port-address) + (java:jnew (java:jconstructor *isa-jclass* *ia-jclass* *int-jclass*) + (etypecase address + ((or ipv4-address ipv6-address) + (java:jcall (java:jmethod *ia-jclass* "getByAddress" (java:jclass "[B")) nil + (make-jarray (slot-value address 'host-bytes))))) + (slot-value address 'port))) + +(defun unmap-inet-address (jhost) + (cond ((java:jclass-of jhost "java.net.Inet4Address") + (let ((jbytes (java:jcall (java:jmethod *ia-jclass* "getAddress") jhost))) + (make-instance 'ipv4-host-address :host-bytes (undo-jarray jbytes)))) + ((java:jclass-of jhost "java.net.Inet6Address") + (let ((jbytes (java:jcall (java:jmethod *ia-jclass* "getAddress") jhost))) + (make-instance 'ipv6-host-address :host-bytes (undo-jarray jbytes)))) + (t (error "Unknown InetAddress class.")))) + +(defun unmap-socket-address (jaddress) + (assert (java:jclass-of jaddress "java.net.InetSocketAddress") (jaddress)) + (let ((port (java:jcall (java:jmethod *isa-jclass* "getPort") jaddress)) + (jhost (java:jcall (java:jmethod *isa-jclass* "getAddress") jaddress))) + (values (unmap-inet-address jhost) port))) + +(defmacro retry-loop ((format-string &rest format-args) &body body) + `(loop (with-simple-restart (:retry ,format-string ,@format-args) + (return ,@body)))) + +(defun check-not-closed (socket) + (declare (type abcl-socket socket)) + (when (null (slot-value socket 'java-channel)) + (error 'socket-closed :socket socket))) + +(defmethod close-socket ((socket abcl-socket)) + (threads:with-thread-lock (socket) + (with-slots (java-channel) socket + (unless (null java-channel) + (jclose-channel java-channel) + (setf java-channel nil))))) + +(defmethod socket-open-p ((socket abcl-socket)) + (threads:with-thread-lock (socket) + (if (slot-value socket 'java-channel) t nil))) + +(defmethod socket-local-address ((socket abcl-stream-socket)) + (multiple-value-bind (host port) + (unmap-socket-address + (threads:with-thread-lock (socket) + (check-not-closed socket) + (java:jcall (java:jmethod *sk-jclass* "getLocalSocketAddress") (slot-value socket 'java-socket)))) + (etypecase host + (ipv4-address (make-instance 'tcp4-address :port port :host-address host)) + (ipv6-address (make-instance 'tcp6-address :port port :host-address host))))) + +(defmethod socket-remote-address ((socket abcl-stream-socket)) + (multiple-value-bind (host port) + (unmap-socket-address + (threads:with-thread-lock (socket) + (check-not-closed socket) + (java:jcall (java:jmethod *sk-jclass* "getRemoteSocketAddress") (slot-value socket 'java-socket)))) + (etypecase host + (ipv4-address (make-instance 'tcp4-address :port port :host-address host)) + (ipv6-address (make-instance 'tcp6-address :port port :host-address host))))) + +(defmethod socket-send ((socket abcl-stream-socket) buf &key (start 0) (end (length buf)) no-hang) + (threads:with-thread-lock (socket) + (check-not-closed socket) + (with-slots (java-channel) socket + (unwind-protect + (progn + (when no-hang + (java:jcall (java:jmethod *selc-jclass* "configureBlocking" (java:jclass "boolean")) java-channel (java:make-immediate-object nil :boolean))) + (retry-loop ("Retry the send operation.") + (java:jcall (java:jmethod *wc-jclass* "write" *bbuf-jclass*) java-channel + (java:jcall (java:jmethod *bbuf-jclass* "wrap" (java:jclass "[B")) nil (make-jarray buf start end))))) + (java:jcall (java:jmethod *selc-jclass* "configureBlocking" (java:jclass "boolean")) java-channel (java:make-immediate-object t :boolean)))))) + +(defmethod socket-recv-into ((socket abcl-stream-socket) buf &key (start 0) (end (length buf)) no-hang) + (threads:with-thread-lock (socket) + (check-not-closed socket) + (with-slots (java-channel) socket + (unwind-protect + (progn + (when no-hang + (java:jcall (java:jmethod *selc-jclass* "configureBlocking" (java:jclass "boolean")) java-channel (java:make-immediate-object nil :boolean))) + (retry-loop ("Try receiving again.") + (let* ((jbuf (java:jnew-array (java:jclass "byte") (- end start))) + (ret (java:jcall (java:jmethod *rc-jclass* "read" *bbuf-jclass*) java-channel + (java:jcall (java:jmethod *bbuf-jclass* "wrap" (java:jclass "[B")) nil jbuf)))) + (if (< ret 0) + (values nil nil) + (progn + (undo-jarray jbuf buf start end) + (values ret nil)))))) + (java:jcall (java:jmethod *selc-jclass* "configureBlocking" (java:jclass "boolean")) java-channel (java:make-immediate-object t :boolean)))))) + +(defmethod connect-to-address ((address tcp-address) &key local) + (let ((ch + (retry-loop ("Try connecting again.") + (with-java-channel (ch (java:jcall (java:jmethod *sc-jclass* "open") nil)) + (let ((sk (java:jcall (java:jmethod *sc-jclass* "socket") ch))) + (when local + (java:jcall (java:jmethod *sk-jclass* "bind" *sa-jclass*) sk (map-socket-address local))) + (java:jcall (java:jmethod *sk-jclass* "connect" *sa-jclass*) sk (map-socket-address address))) + ch)))) + (make-instance 'abcl-stream-socket + :java-channel ch + :java-socket (java:jcall (java:jmethod *sc-jclass* "socket") ch))))