1 (in-package :common-net)
3 (require :gray-streams)
5 ;;; Gray stream methods
7 ;; Redefine stream-socket with Gray superclasses. I know it's ugly,
8 ;; but I just don't know of a better way to do it.
9 (defclass stream-socket (socket gray-streams:fundamental-character-input-stream gray-streams:fundamental-character-output-stream
10 gray-streams:fundamental-binary-input-stream gray-streams:fundamental-binary-output-stream)
11 ((mode :initform :byte)
12 (byte-buffer :initform (make-array '(16) :element-type '(unsigned-byte 8) :adjustable t)
13 :type (array (unsigned-byte 8)))
14 (byte-read-pos :initform 0 :type integer)
15 (byte-write-pos :initform 0 :type integer)
16 (char-buffer :initform (make-array '(16) :element-type 'character :adjustable t :fill-pointer 0)
17 :type (array character))
18 (char-read-pos :initform 0 :type integer)
21 (macrolet ((simple (name)
23 ,(intern (symbol-name name) (find-package :gray-streams)) ((socket stream-socket))
24 (,(intern (concatenate 'string "GRAY-" (symbol-name name)) (symbol-package 'stream-socket)) socket)))
27 ,(intern (symbol-name name) (find-package :gray-streams)) ((socket stream-socket))
29 (simple stream-element-type)
30 (simple open-stream-p)
31 (simple stream-read-byte)
32 (simple stream-read-char)
33 (simple stream-read-char-no-hang)
34 (simple stream-peek-char)
35 (simple stream-listen)
36 (simple-null stream-line-column)
37 (simple-null stream-finish-output)
38 (simple-null stream-force-output)
39 (simple-null stream-clear-output))
41 (defmethod gray-streams:stream-write-byte ((socket stream-socket) byte)
42 (gray-stream-write-char socket byte))
44 (defmethod gray-streams:stream-unread-char ((socket stream-socket) char)
45 (gray-stream-unread-char socket char))
47 (defmethod gray-streams:stream-write-char ((socket stream-socket) char)
48 (gray-stream-write-char socket char))
50 (defmethod gray-streams:stream-close ((socket stream-socket) &key abort)
51 (declare (ignore abort))
54 (close-socket socket)))
56 (defmethod gray-streams:stream-start-line-p ((socket stream-socket))
57 (eql (gray-streams:stream-line-column socket) 0))
59 (defmethod gray-streams:stream-fresh-line ((socket stream-socket))
60 (unless (gray-streams:stream-start-line-p socket)
61 (gray-streams:stream-terpri socket)
64 (defmethod gray-streams:stream-write-string ((socket stream-socket) string &optional (start 0) (end (length string)))
65 (gray-streams:stream-write-sequence socket string start end))
67 (defmethod gray-streams:stream-terpri ((socket stream-socket))
68 (gray-streams:stream-write-char socket #\newline))
70 (defmethod gray-streams:stream-read-sequence ((socket stream-socket) seq &optional (start 0) (end (length seq)))
71 (gray-stream-read-sequence socket seq start end))
73 (defmethod gray-streams:stream-write-sequence ((socket stream-socket) seq &optional (start 0) (end (length seq)))
74 (gray-stream-write-sequence socket seq start end))
76 ;;; Networking implementation
78 (defclass abcl-socket (socket)
79 ((java-socket :initarg :java-socket)
80 (java-channel :initarg :java-channel)))
81 (defclass abcl-listen-socket (listen-socket abcl-socket) ())
82 (defclass abcl-stream-socket (stream-socket abcl-socket) ())
83 (defclass abcl-datagram-socket (datagram-socket abcl-socket) ())
85 (defparameter *sk-jclass* (java:jclass "java.net.Socket"))
86 (defparameter *dsk-jclass* (java:jclass "java.net.ServerSocket"))
87 (defparameter *ssk-jclass* (java:jclass "java.net.DatagramSocket"))
88 (defparameter *sc-jclass* (java:jclass "java.nio.channels.SocketChannel"))
89 (defparameter *dc-jclass* (java:jclass "java.nio.channels.DatagramChannel"))
90 (defparameter *ssc-jclass* (java:jclass "java.nio.channels.ServerSocketChannel"))
91 (defparameter *selc-jclass* (java:jclass "java.nio.channels.SelectableChannel"))
92 (defparameter *wc-jclass* (java:jclass "java.nio.channels.WritableByteChannel"))
93 (defparameter *rc-jclass* (java:jclass "java.nio.channels.ReadableByteChannel"))
94 (defparameter *bbuf-jclass* (java:jclass "java.nio.ByteBuffer"))
95 (defparameter *ia-jclass* (java:jclass "java.net.InetAddress"))
96 (defparameter *i4a-jclass* (java:jclass "java.net.Inet4Address"))
97 (defparameter *i6a-jclass* (java:jclass "java.net.Inet6Address"))
98 (defparameter *sa-jclass* (java:jclass "java.net.SocketAddress"))
99 (defparameter *isa-jclass* (java:jclass "java.net.InetSocketAddress"))
100 (defparameter *int-jclass* (java:jclass "int"))
102 (defun jclose-channel (jsk)
103 (let ((meth (java:jmethod *selc-jclass* "close")))
104 (java:jcall meth jsk)))
106 (defmacro with-java-channel ((var socket) &body body)
107 (let ((success (gensym "SUCCESS")))
108 `(let ((,var ,socket)
111 (multiple-value-prog1
115 (jclose-channel ,var))))))
117 ;; These are probably horribly inefficient, but I haven't found any
118 ;; better way of doing it.
119 (defun make-jarray (seq &optional (start 0) (end (length seq)))
120 (let ((byte (java:jclass "byte")))
121 (let ((jarray (java:jnew-array byte (- end start))))
122 (dotimes (i (- end start))
123 (java:jcall (java:jmethod (java:jclass "java.lang.reflect.Array") "setByte" (java:jclass "java.lang.Object") *int-jclass* byte)
124 nil jarray i (elt seq (+ start i))))
127 (defun undo-jarray (jarray &optional (into (make-array (list (java:jarray-length jarray)))) (start 0) (end (length into)))
128 (dotimes (i (- end start))
129 (setf (elt into (+ i start)) (java:jarray-ref jarray i)))
132 (defun map-socket-address (address)
133 (check-type address inet-port-address)
134 (java:jnew (java:jconstructor *isa-jclass* *ia-jclass* *int-jclass*)
136 ((or ipv4-address ipv6-address)
137 (java:jcall (java:jmethod *ia-jclass* "getByAddress" (java:jclass "[B")) nil
138 (make-jarray (slot-value address 'host-bytes)))))
139 (slot-value address 'port)))
141 (defun unmap-inet-address (jhost)
142 (cond ((java:jclass-of jhost "java.net.Inet4Address")
143 (let ((jbytes (java:jcall (java:jmethod *ia-jclass* "getAddress") jhost)))
144 (make-instance 'ipv4-host-address :host-bytes (undo-jarray jbytes))))
145 ((java:jclass-of jhost "java.net.Inet6Address")
146 (let ((jbytes (java:jcall (java:jmethod *ia-jclass* "getAddress") jhost)))
147 (make-instance 'ipv6-host-address :host-bytes (undo-jarray jbytes))))
148 (t (error "Unknown InetAddress class."))))
150 (defun unmap-socket-address (jaddress)
151 (assert (java:jclass-of jaddress "java.net.InetSocketAddress") (jaddress))
152 (let ((port (java:jcall (java:jmethod *isa-jclass* "getPort") jaddress))
153 (jhost (java:jcall (java:jmethod *isa-jclass* "getAddress") jaddress)))
154 (values (unmap-inet-address jhost) port)))
156 (defmacro retry-loop ((format-string &rest format-args) &body body)
157 `(loop (with-simple-restart (:retry ,format-string ,@format-args)
160 (defun check-not-closed (socket)
161 (declare (type abcl-socket socket))
162 (when (null (slot-value socket 'java-channel))
163 (error 'socket-closed :socket socket)))
165 (defmethod close-socket ((socket abcl-socket))
166 (threads:with-thread-lock (socket)
167 (with-slots (java-channel) socket
168 (unless (null java-channel)
169 (jclose-channel java-channel)
170 (setf java-channel nil)))))
172 (defmethod socket-open-p ((socket abcl-socket))
173 (threads:with-thread-lock (socket)
174 (if (slot-value socket 'java-channel) t nil)))
176 (defmethod socket-local-address ((socket abcl-stream-socket))
177 (multiple-value-bind (host port)
178 (unmap-socket-address
179 (threads:with-thread-lock (socket)
180 (check-not-closed socket)
181 (java:jcall (java:jmethod *sk-jclass* "getLocalSocketAddress") (slot-value socket 'java-socket))))
183 (ipv4-address (make-instance 'tcp4-address :port port :host-address host))
184 (ipv6-address (make-instance 'tcp6-address :port port :host-address host)))))
186 (defmethod socket-remote-address ((socket abcl-stream-socket))
187 (multiple-value-bind (host port)
188 (unmap-socket-address
189 (threads:with-thread-lock (socket)
190 (check-not-closed socket)
191 (java:jcall (java:jmethod *sk-jclass* "getRemoteSocketAddress") (slot-value socket 'java-socket))))
193 (ipv4-address (make-instance 'tcp4-address :port port :host-address host))
194 (ipv6-address (make-instance 'tcp6-address :port port :host-address host)))))
196 (defmethod socket-send ((socket abcl-stream-socket) buf &key (start 0) (end (length buf)) no-hang)
197 (threads:with-thread-lock (socket)
198 (check-not-closed socket)
199 (with-slots (java-channel) socket
203 (java:jcall (java:jmethod *selc-jclass* "configureBlocking" (java:jclass "boolean")) java-channel (java:make-immediate-object nil :boolean)))
204 (retry-loop ("Retry the send operation.")
205 (java:jcall (java:jmethod *wc-jclass* "write" *bbuf-jclass*) java-channel
206 (java:jcall (java:jmethod *bbuf-jclass* "wrap" (java:jclass "[B")) nil (make-jarray buf start end)))))
207 (java:jcall (java:jmethod *selc-jclass* "configureBlocking" (java:jclass "boolean")) java-channel (java:make-immediate-object t :boolean))))))
209 (defmethod socket-recv-into ((socket abcl-stream-socket) buf &key (start 0) (end (length buf)) no-hang)
210 (threads:with-thread-lock (socket)
211 (check-not-closed socket)
212 (with-slots (java-channel) socket
216 (java:jcall (java:jmethod *selc-jclass* "configureBlocking" (java:jclass "boolean")) java-channel (java:make-immediate-object nil :boolean)))
217 (retry-loop ("Try receiving again.")
218 (let* ((jbuf (java:jnew-array (java:jclass "byte") (- end start)))
219 (ret (java:jcall (java:jmethod *rc-jclass* "read" *bbuf-jclass*) java-channel
220 (java:jcall (java:jmethod *bbuf-jclass* "wrap" (java:jclass "[B")) nil jbuf))))
224 (undo-jarray jbuf buf start end)
225 (values ret nil))))))
226 (java:jcall (java:jmethod *selc-jclass* "configureBlocking" (java:jclass "boolean")) java-channel (java:make-immediate-object t :boolean))))))
228 (defmethod connect-to-address ((address tcp-address) &key local)
230 (retry-loop ("Try connecting again.")
231 (with-java-channel (ch (java:jcall (java:jmethod *sc-jclass* "open") nil))
232 (let ((sk (java:jcall (java:jmethod *sc-jclass* "socket") ch)))
234 (java:jcall (java:jmethod *sk-jclass* "bind" *sa-jclass*) sk (map-socket-address local)))
235 (java:jcall (java:jmethod *sk-jclass* "connect" *sa-jclass*) sk (map-socket-address address)))
237 (make-instance 'abcl-stream-socket
239 :java-socket (java:jcall (java:jmethod *sc-jclass* "socket") ch))))