net-abcl.lisp

   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))))