/common-lisp/3rd-party/usocket/backend/mcl.lisp
Lisp | 267 lines | 217 code | 39 blank | 11 comment | 4 complexity | fe401a60fbc64af1d594023bb25a8f08 MD5 | raw file
1;;;; $Id: mcl.lisp 721 2013-06-21 03:46:37Z ctian $ 2;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/tags/0.6.1/backend/mcl.lisp $ 3 4;; MCL backend for USOCKET 0.4.1 5;; Terje Norderhaug <terje@in-progress.com>, January 1, 2009 6 7(in-package :usocket) 8 9(defun handle-condition (condition &optional socket) 10 ; incomplete, needs to handle additional conditions 11 (flet ((raise-error (&optional socket-condition) 12 (if socket-condition 13 (error socket-condition :socket socket) 14 (error 'unknown-error :socket socket :real-error condition)))) 15 (typecase condition 16 (ccl:host-stopped-responding 17 (raise-error 'host-down-error)) 18 (ccl:host-not-responding 19 (raise-error 'host-unreachable-error)) 20 (ccl:connection-reset 21 (raise-error 'connection-reset-error)) 22 (ccl:connection-timed-out 23 (raise-error 'timeout-error)) 24 (ccl:opentransport-protocol-error 25 (raise-error 'protocol-not-supported-error)) 26 (otherwise 27 (raise-error))))) 28 29(defun socket-connect (host port &key (element-type 'character) timeout deadline nodelay 30 local-host local-port (protocol :stream)) 31 (when (eq nodelay :if-supported) 32 (setf nodelay t)) 33 (ecase protocol 34 (:stream 35 (with-mapped-conditions () 36 (let* ((socket 37 (make-instance 'active-socket 38 :remote-host (when host (host-to-hostname host)) 39 :remote-port port 40 :local-host (when local-host (host-to-hostname local-host)) 41 :local-port local-port 42 :deadline deadline 43 :nodelay nodelay 44 :connect-timeout (and timeout (round (* timeout 60))) 45 :element-type element-type)) 46 (stream (socket-open-stream socket))) 47 (make-stream-socket :socket socket :stream stream)))) 48 (:datagram 49 (with-mapped-conditions () 50 (make-datagram-socket 51 (ccl::open-udp-socket :local-address (and local-host (host-to-hbo local-host)) 52 :local-port local-port)))))) 53 54(defun socket-listen (host port 55 &key reuseaddress 56 (reuse-address nil reuse-address-supplied-p) 57 (backlog 5) 58 (element-type 'character)) 59 (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) 60 (socket (with-mapped-conditions () 61 (make-instance 'passive-socket 62 :local-port port 63 :local-host (host-to-hbo host) 64 :reuse-address reuseaddress 65 :backlog backlog)))) 66 (make-stream-server-socket socket :element-type element-type))) 67 68(defmethod socket-accept ((usocket stream-server-usocket) &key element-type) 69 (let* ((socket (socket usocket)) 70 (stream (with-mapped-conditions (usocket) 71 (socket-accept socket :element-type element-type)))) 72 (make-stream-socket :socket socket :stream stream))) 73 74(defmethod socket-close ((usocket usocket)) 75 (with-mapped-conditions (usocket) 76 (socket-close (socket usocket)))) 77 78(defmethod ccl::stream-close ((usocket usocket)) 79 (socket-close usocket)) 80 81(defun get-hosts-by-name (name) 82 (with-mapped-conditions () 83 (list (hbo-to-vector-quad (ccl::get-host-address 84 (host-to-hostname name)))))) 85 86(defun get-host-by-address (address) 87 (with-mapped-conditions () 88 (ccl::inet-host-name (host-to-hbo address)))) 89 90(defmethod get-local-name ((usocket usocket)) 91 (values (get-local-address usocket) 92 (get-local-port usocket))) 93 94(defmethod get-peer-name ((usocket stream-usocket)) 95 (values (get-peer-address usocket) 96 (get-peer-port usocket))) 97 98(defmethod get-local-address ((usocket usocket)) 99 (hbo-to-vector-quad (ccl::get-host-address (or (local-host (socket usocket)) "")))) 100 101(defmethod get-local-port ((usocket usocket)) 102 (local-port (socket usocket))) 103 104(defmethod get-peer-address ((usocket stream-usocket)) 105 (hbo-to-vector-quad (ccl::get-host-address (remote-host (socket usocket))))) 106 107(defmethod get-peer-port ((usocket stream-usocket)) 108 (remote-port (socket usocket))) 109 110 111(defun %setup-wait-list (wait-list) 112 (declare (ignore wait-list))) 113 114(defun %add-waiter (wait-list waiter) 115 (declare (ignore wait-list waiter))) 116 117(defun %remove-waiter (wait-list waiter) 118 (declare (ignore wait-list waiter))) 119 120 121;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 122;; BASIC MCL SOCKET IMPLEMENTATION 123 124(defclass socket () 125 ((local-port :reader local-port :initarg :local-port) 126 (local-host :reader local-host :initarg :local-host) 127 (element-type :reader element-type :initform 'ccl::base-character :initarg :element-type))) 128 129(defclass active-socket (socket) 130 ((remote-host :reader remote-host :initarg :remote-host) 131 (remote-port :reader remote-port :initarg :remote-port) 132 (deadline :initarg :deadline) 133 (nodelay :initarg :nodelay) 134 (connect-timeout :reader connect-timeout :initform NIL :initarg :connect-timeout 135 :type (or null fixnum) :documentation "ticks (60th of a second)"))) 136 137(defmethod socket-open-stream ((socket active-socket)) 138 (ccl::open-tcp-stream (or (remote-host socket)(ccl::local-interface-ip-address)) (remote-port socket) 139 :element-type (if (subtypep (element-type socket) 'character) 'ccl::base-character 'unsigned-byte) 140 :connect-timeout (connect-timeout socket))) 141 142(defmethod socket-close ((socket active-socket)) 143 NIL) 144 145(defclass passive-socket (socket) 146 ((streams :accessor socket-streams :type list :initform NIL 147 :documentation "Circular list of streams with first element the next to open") 148 (reuse-address :reader reuse-address :initarg :reuse-address) 149 (lock :reader socket-lock :initform (ccl:make-lock "Socket")))) 150 151(defmethod initialize-instance :after ((socket passive-socket) &key backlog) 152 (loop repeat backlog 153 collect (socket-open-listener socket) into streams 154 finally (setf (socket-streams socket) 155 (cdr (rplacd (last streams) streams)))) 156 (when (zerop (local-port socket)) 157 (setf (slot-value socket 'local-port) 158 (or (ccl::process-wait-with-timeout "binding port" (* 10 60) 159 #'ccl::stream-local-port (car (socket-streams socket))) 160 (error "timeout"))))) 161 162(defmethod socket-accept ((socket passive-socket) &key element-type &aux (lock (socket-lock socket))) 163 (flet ((connection-established-p (stream) 164 (ccl::with-io-buffer-locked ((ccl::stream-io-buffer stream nil)) 165 (let ((state (ccl::opentransport-stream-connection-state stream))) 166 (not (eq :unbnd state)))))) 167 (with-mapped-conditions () 168 (ccl:with-lock-grabbed (lock nil "Socket Lock") 169 (let ((connection (shiftf (car (socket-streams socket)) 170 (socket-open-listener socket element-type)))) 171 (pop (socket-streams socket)) 172 (ccl:process-wait "Accepting" #'connection-established-p connection) 173 connection))))) 174 175(defmethod socket-close ((socket passive-socket)) 176 (loop 177 with streams = (socket-streams socket) 178 for (stream tail) on streams 179 do (close stream :abort T) 180 until (eq tail streams) 181 finally (setf (socket-streams socket) NIL))) 182 183(defmethod socket-open-listener (socket &optional element-type) 184 ; see http://code.google.com/p/mcl/issues/detail?id=28 185 (let* ((ccl::*passive-interface-address* (local-host socket)) 186 (new (ccl::open-tcp-stream NIL (or (local-port socket) #$kOTAnyInetAddress) 187 :reuse-local-port-p (reuse-address socket) 188 :element-type (if (subtypep (or element-type (element-type socket)) 189 'character) 190 'ccl::base-character 191 'unsigned-byte)))) 192 (declare (special ccl::*passive-interface-address*)) 193 new)) 194 195(defmethod input-available-p ((stream ccl::opentransport-stream)) 196 (macrolet ((when-io-buffer-lock-grabbed ((lock &optional multiple-value-p) &body body) 197 "Evaluates the body if and only if the lock is successfully grabbed" 198 ;; like with-io-buffer-lock-grabbed but returns immediately instead of polling the lock 199 (let ((needs-unlocking-p (gensym)) 200 (lock-var (gensym))) 201 `(let* ((,lock-var ,lock) 202 (ccl::*grabbed-io-buffer-locks* (cons ,lock-var ccl::*grabbed-io-buffer-locks*)) 203 (,needs-unlocking-p (needs-unlocking-p ,lock-var))) 204 (declare (dynamic-extent ccl::*grabbed-io-buffer-locks*)) 205 (when ,needs-unlocking-p 206 (,(if multiple-value-p 'multiple-value-prog1 'prog1) 207 (progn ,@body) 208 (ccl::%release-io-buffer-lock ,lock-var))))))) 209 (labels ((needs-unlocking-p (lock) 210 (declare (type ccl::lock lock)) 211 ;; crucial - clears bogus lock.value as in grab-io-buffer-lock-out-of-line: 212 (ccl::%io-buffer-lock-really-grabbed-p lock) 213 (ccl:store-conditional lock nil ccl:*current-process*))) 214 "similar to stream-listen on buffered-input-stream-mixin but without waiting for lock" 215 (let ((io-buffer (ccl::stream-io-buffer stream))) 216 (or (not (eql 0 (ccl::io-buffer-incount io-buffer))) 217 (ccl::io-buffer-untyi-char io-buffer) 218 (locally (declare (optimize (speed 3) (safety 0))) 219 (when-io-buffer-lock-grabbed ((ccl::io-buffer-lock io-buffer)) 220 (funcall (ccl::io-buffer-listen-function io-buffer) stream io-buffer)))))))) 221 222(defmethod connection-established-p ((stream ccl::opentransport-stream)) 223 (ccl::with-io-buffer-locked ((ccl::stream-io-buffer stream nil)) 224 (let ((state (ccl::opentransport-stream-connection-state stream))) 225 (not (eq :unbnd state))))) 226 227(defun wait-for-input-internal (wait-list &key timeout &aux result) 228 (labels ((ready-sockets (sockets) 229 (dolist (sock sockets result) 230 (when (cond ((stream-usocket-p sock) 231 (input-available-p (socket-stream sock))) 232 ((stream-server-usocket-p sock) 233 (let ((ot-stream (first (socket-streams (socket sock))))) 234 (or (input-available-p ot-stream) 235 (connection-established-p ot-stream))))) 236 (push sock result))))) 237 (with-mapped-conditions () 238 (ccl:process-wait-with-timeout 239 "socket input" 240 (when timeout (truncate (* timeout 60))) 241 #'ready-sockets 242 (wait-list-waiters wait-list))) 243 (nreverse result))) 244 245;;; datagram socket methods 246 247(defmethod initialize-instance :after ((usocket datagram-usocket) &key) 248 (with-slots (socket send-buffer recv-buffer) usocket 249 (setq send-buffer 250 (ccl::make-TUnitData (ccl::ot-conn-endpoint socket))) 251 (setq recv-buffer 252 (ccl::make-TUnitData (ccl::ot-conn-endpoint socket))))) 253 254(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0)) 255 (with-mapped-conditions (usocket) 256 (with-slots (socket send-buffer) usocket 257 (unless (and host port) 258 (unsupported 'host 'socket-send)) 259 (ccl::send-message socket send-buffer buffer size host port offset)))) 260 261(defmethod socket-receive ((usocket datagram-usocket) buffer length &key) 262 (with-mapped-conditions (usocket) 263 (with-slots (socket recv-buffer) usocket 264 (ccl::receive-message socket recv-buffer buffer length)))) 265 266(defmethod socket-close ((socket datagram-usocket)) 267 nil) ; TODO