--- /dev/null
+(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))))