/common-lisp/3rd-party/usocket/backend/mcl.lisp

  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