Commit | Line | Data |
---|---|---|
a95b7451 FT |
1 | (in-package :common-net) |
2 | ||
3 | (require :gray-streams) | |
4 | ||
5 | ;;; Gray stream methods | |
6 | ||
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) | |
19 | encoder decoder)) | |
20 | ||
21 | (macrolet ((simple (name) | |
22 | `(defmethod | |
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))) | |
25 | (simple-null (name) | |
26 | `(defmethod | |
27 | ,(intern (symbol-name name) (find-package :gray-streams)) ((socket stream-socket)) | |
28 | nil))) | |
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)) | |
40 | ||
41 | (defmethod gray-streams:stream-write-byte ((socket stream-socket) byte) | |
42 | (gray-stream-write-char socket byte)) | |
43 | ||
44 | (defmethod gray-streams:stream-unread-char ((socket stream-socket) char) | |
45 | (gray-stream-unread-char socket char)) | |
46 | ||
47 | (defmethod gray-streams:stream-write-char ((socket stream-socket) char) | |
48 | (gray-stream-write-char socket char)) | |
49 | ||
50 | (defmethod gray-streams:stream-close ((socket stream-socket) &key abort) | |
51 | (declare (ignore abort)) | |
52 | (prog1 | |
53 | (call-next-method) | |
54 | (close-socket socket))) | |
55 | ||
56 | (defmethod gray-streams:stream-start-line-p ((socket stream-socket)) | |
57 | (eql (gray-streams:stream-line-column socket) 0)) | |
58 | ||
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) | |
62 | t)) | |
63 | ||
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)) | |
66 | ||
67 | (defmethod gray-streams:stream-terpri ((socket stream-socket)) | |
68 | (gray-streams:stream-write-char socket #\newline)) | |
69 | ||
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)) | |
72 | ||
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)) | |
75 | ||
76 | ;;; Networking implementation | |
77 | ||
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) ()) | |
84 | ||
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")) | |
101 | ||
102 | (defun jclose-channel (jsk) | |
103 | (let ((meth (java:jmethod *selc-jclass* "close"))) | |
104 | (java:jcall meth jsk))) | |
105 | ||
106 | (defmacro with-java-channel ((var socket) &body body) | |
107 | (let ((success (gensym "SUCCESS"))) | |
108 | `(let ((,var ,socket) | |
109 | (,success nil)) | |
110 | (unwind-protect | |
111 | (multiple-value-prog1 | |
112 | (progn ,@body) | |
113 | (setf ,success t)) | |
114 | (unless ,success | |
115 | (jclose-channel ,var)))))) | |
116 | ||
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)))) | |
125 | jarray))) | |
126 | ||
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))) | |
130 | into) | |
131 | ||
132 | (defun map-socket-address (address) | |
133 | (check-type address inet-port-address) | |
134 | (java:jnew (java:jconstructor *isa-jclass* *ia-jclass* *int-jclass*) | |
135 | (etypecase address | |
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))) | |
140 | ||
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.")))) | |
149 | ||
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))) | |
155 | ||
156 | (defmacro retry-loop ((format-string &rest format-args) &body body) | |
157 | `(loop (with-simple-restart (:retry ,format-string ,@format-args) | |
158 | (return ,@body)))) | |
159 | ||
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))) | |
164 | ||
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))))) | |
171 | ||
172 | (defmethod socket-open-p ((socket abcl-socket)) | |
173 | (threads:with-thread-lock (socket) | |
174 | (if (slot-value socket 'java-channel) t nil))) | |
175 | ||
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)))) | |
182 | (etypecase host | |
183 | (ipv4-address (make-instance 'tcp4-address :port port :host-address host)) | |
184 | (ipv6-address (make-instance 'tcp6-address :port port :host-address host))))) | |
185 | ||
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)))) | |
192 | (etypecase host | |
193 | (ipv4-address (make-instance 'tcp4-address :port port :host-address host)) | |
194 | (ipv6-address (make-instance 'tcp6-address :port port :host-address host))))) | |
195 | ||
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 | |
200 | (unwind-protect | |
201 | (progn | |
202 | (when no-hang | |
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)))))) | |
208 | ||
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 | |
213 | (unwind-protect | |
214 | (progn | |
215 | (when no-hang | |
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)))) | |
221 | (if (< ret 0) | |
222 | (values nil nil) | |
223 | (progn | |
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)))))) | |
227 | ||
228 | (defmethod connect-to-address ((address tcp-address) &key local) | |
229 | (let ((ch | |
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))) | |
233 | (when local | |
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))) | |
236 | ch)))) | |
237 | (make-instance 'abcl-stream-socket | |
238 | :java-channel ch | |
239 | :java-socket (java:jcall (java:jmethod *sc-jclass* "socket") ch)))) |