mcl.lisp - clic - Clic is an command line interactive client for gopher written… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
mcl.lisp (11738B) | |
--- | |
1 ;; MCL backend for USOCKET 0.4.1 | |
2 ;; Terje Norderhaug <[email protected]>, January 1, 2009 | |
3 | |
4 (in-package :usocket) | |
5 | |
6 (defun handle-condition (condition &optional socket (host-or-ip nil)) | |
7 ; incomplete, needs to handle additional conditions | |
8 (flet ((raise-error (&optional socket-condition host-or-ip) | |
9 (if socket-condition | |
10 (cond ((typep socket-condition ns-error) | |
11 (error socket-condition :socket socket :host-or-ip… | |
12 (t | |
13 (error socket-condition :socket socket))) | |
14 (error 'unknown-error :socket socket :real-error conditio… | |
15 (typecase condition | |
16 (ccl:host-stopped-responding | |
17 (raise-error 'host-down-error host-or-ip)) | |
18 (ccl:host-not-responding | |
19 (raise-error 'host-unreachable-error host-or-ip)) | |
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 condition host-or-ip))))) | |
28 | |
29 (defun socket-connect (host port &key (element-type 'character) timeout … | |
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 (nil host) | |
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-ho… | |
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 (nil (or host local-host)) | |
50 (make-datagram-socket | |
51 (ccl::open-udp-socket :local-address (and local-host (host-to-h… | |
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 reusea… | |
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-t… | |
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 socket-shutdown ((usocket usocket) direction) | |
79 (declare (ignore usocket direction)) | |
80 ;; As far as I can tell there isn't a way to shutdown a socket in mcl. | |
81 (unsupported "shutdown" 'socket-shutdown)) | |
82 | |
83 (defmethod ccl::stream-close ((usocket usocket)) | |
84 (socket-close usocket)) | |
85 | |
86 (defun get-hosts-by-name (name) | |
87 (with-mapped-conditions (nil name) | |
88 (list (hbo-to-vector-quad (ccl::get-host-address | |
89 (host-to-hostname name)))))) | |
90 | |
91 (defun get-host-by-address (address) | |
92 (with-mapped-conditions (nil address) | |
93 (ccl::inet-host-name (host-to-hbo address)))) | |
94 | |
95 (defmethod get-local-name ((usocket usocket)) | |
96 (values (get-local-address usocket) | |
97 (get-local-port usocket))) | |
98 | |
99 (defmethod get-peer-name ((usocket stream-usocket)) | |
100 (values (get-peer-address usocket) | |
101 (get-peer-port usocket))) | |
102 | |
103 (defmethod get-local-address ((usocket usocket)) | |
104 (hbo-to-vector-quad (ccl::get-host-address (or (local-host (socket uso… | |
105 | |
106 (defmethod get-local-port ((usocket usocket)) | |
107 (local-port (socket usocket))) | |
108 | |
109 (defmethod get-peer-address ((usocket stream-usocket)) | |
110 (hbo-to-vector-quad (ccl::get-host-address (remote-host (socket usocke… | |
111 | |
112 (defmethod get-peer-port ((usocket stream-usocket)) | |
113 (remote-port (socket usocket))) | |
114 | |
115 (defun %setup-wait-list (wait-list) | |
116 (declare (ignore wait-list))) | |
117 | |
118 (defun %add-waiter (wait-list waiter) | |
119 (declare (ignore wait-list waiter))) | |
120 | |
121 (defun %remove-waiter (wait-list waiter) | |
122 (declare (ignore wait-list waiter))) | |
123 | |
124 | |
125 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;… | |
126 ;; BASIC MCL SOCKET IMPLEMENTATION | |
127 | |
128 (defclass socket () | |
129 ((local-port :reader local-port :initarg :local-port) | |
130 (local-host :reader local-host :initarg :local-host) | |
131 (element-type :reader element-type :initform 'ccl::base-character :in… | |
132 | |
133 (defclass active-socket (socket) | |
134 ((remote-host :reader remote-host :initarg :remote-host) | |
135 (remote-port :reader remote-port :initarg :remote-port) | |
136 (deadline :initarg :deadline) | |
137 (nodelay :initarg :nodelay) | |
138 (connect-timeout :reader connect-timeout :initform NIL :initarg :conn… | |
139 :type (or null fixnum) :documentation "ticks (60th o… | |
140 | |
141 (defmethod socket-open-stream ((socket active-socket)) | |
142 (ccl::open-tcp-stream (or (remote-host socket)(ccl::local-interface-ip… | |
143 :element-type (if (subtypep (element-type socket) 'character) 'ccl::b… | |
144 :connect-timeout (connect-timeout socket))) | |
145 | |
146 (defmethod socket-close ((socket active-socket)) | |
147 NIL) | |
148 | |
149 (defclass passive-socket (socket) | |
150 ((streams :accessor socket-streams :type list :initform NIL | |
151 :documentation "Circular list of streams with first element … | |
152 (reuse-address :reader reuse-address :initarg :reuse-address) | |
153 (lock :reader socket-lock :initform (ccl:make-lock "Socket")))) | |
154 | |
155 (defmethod initialize-instance :after ((socket passive-socket) &key back… | |
156 (loop repeat backlog | |
157 collect (socket-open-listener socket) into streams | |
158 finally (setf (socket-streams socket) | |
159 (cdr (rplacd (last streams) streams)))) | |
160 (when (zerop (local-port socket)) | |
161 (setf (slot-value socket 'local-port) | |
162 (or (ccl::process-wait-with-timeout "binding port" (* 10 60) | |
163 #'ccl::stream-local-port (car (socket-streams socket))) | |
164 (error "timeout"))))) | |
165 | |
166 (defmethod socket-accept ((socket passive-socket) &key element-type &aux… | |
167 (flet ((connection-established-p (stream) | |
168 (ccl::with-io-buffer-locked ((ccl::stream-io-buffer stream ni… | |
169 (let ((state (ccl::opentransport-stream-connection-state st… | |
170 (not (eq :unbnd state)))))) | |
171 (with-mapped-conditions () | |
172 (ccl:with-lock-grabbed (lock nil "Socket Lock") | |
173 (let ((connection (shiftf (car (socket-streams socket)) | |
174 (socket-open-listener socket element-t… | |
175 (pop (socket-streams socket)) | |
176 (ccl:process-wait "Accepting" #'connection-established-p conne… | |
177 connection))))) | |
178 | |
179 (defmethod socket-close ((socket passive-socket)) | |
180 (loop | |
181 with streams = (socket-streams socket) | |
182 for (stream tail) on streams | |
183 do (close stream :abort T) | |
184 until (eq tail streams) | |
185 finally (setf (socket-streams socket) NIL))) | |
186 | |
187 (defmethod socket-open-listener (socket &optional element-type) | |
188 ; see http://code.google.com/p/mcl/issues/detail?id=28 | |
189 (let* ((ccl::*passive-interface-address* (local-host socket)) | |
190 (new (ccl::open-tcp-stream NIL (or (local-port socket) #$kOTAny… | |
191 :reuse-local-port-p (reuse-address s… | |
192 :element-type (if (subtypep (or elem… | |
193 'charact… | |
194 'ccl::base-character | |
195 'unsigned-byte)))) | |
196 (declare (special ccl::*passive-interface-address*)) | |
197 new)) | |
198 | |
199 (defmethod input-available-p ((stream ccl::opentransport-stream)) | |
200 (macrolet ((when-io-buffer-lock-grabbed ((lock &optional multiple-valu… | |
201 "Evaluates the body if and only if the lock is successful… | |
202 ;; like with-io-buffer-lock-grabbed but returns immediate… | |
203 (let ((needs-unlocking-p (gensym)) | |
204 (lock-var (gensym))) | |
205 `(let* ((,lock-var ,lock) | |
206 (ccl::*grabbed-io-buffer-locks* (cons ,lock-var… | |
207 (,needs-unlocking-p (needs-unlocking-p ,lock-va… | |
208 (declare (dynamic-extent ccl::*grabbed-io-buffer-loc… | |
209 (when ,needs-unlocking-p | |
210 (,(if multiple-value-p 'multiple-value-prog1 'prog… | |
211 (progn ,@body) | |
212 (ccl::%release-io-buffer-lock ,lock-var))))))) | |
213 (labels ((needs-unlocking-p (lock) | |
214 (declare (type ccl::lock lock)) | |
215 ;; crucial - clears bogus lock.value as in grab-io-buffer… | |
216 (ccl::%io-buffer-lock-really-grabbed-p lock) | |
217 (ccl:store-conditional lock nil ccl:*current-process*))) | |
218 "similar to stream-listen on buffered-input-stream-mixin but witho… | |
219 (let ((io-buffer (ccl::stream-io-buffer stream))) | |
220 (or (not (eql 0 (ccl::io-buffer-incount io-buffer))) | |
221 (ccl::io-buffer-untyi-char io-buffer) | |
222 (locally (declare (optimize (speed 3) (safety 0))) | |
223 (when-io-buffer-lock-grabbed ((ccl::io-buffer-lock io-buff… | |
224 (funcall (ccl::io-buffer-listen-function io-buffe… | |
225 | |
226 (defmethod connection-established-p ((stream ccl::opentransport-stream)) | |
227 (ccl::with-io-buffer-locked ((ccl::stream-io-buffer stream nil)) | |
228 (let ((state (ccl::opentransport-stream-connection-state stream))) | |
229 (not (eq :unbnd state))))) | |
230 | |
231 (defun wait-for-input-internal (wait-list &key timeout &aux result) | |
232 (labels ((ready-sockets (sockets) | |
233 (dolist (sock sockets result) | |
234 (when (cond ((stream-usocket-p sock) | |
235 (input-available-p (socket-stream sock))) | |
236 ((stream-server-usocket-p sock) | |
237 (let ((ot-stream (first (socket-streams (soc… | |
238 (or (input-available-p ot-stream) | |
239 (connection-established-p ot-stream)))… | |
240 (push sock result))))) | |
241 (with-mapped-conditions () | |
242 (ccl:process-wait-with-timeout | |
243 "socket input" | |
244 (when timeout (truncate (* timeout 60))) | |
245 #'ready-sockets | |
246 (wait-list-waiters wait-list))) | |
247 (nreverse result))) | |
248 | |
249 ;;; datagram socket methods | |
250 | |
251 (defmethod initialize-instance :after ((usocket datagram-usocket) &key) | |
252 (with-slots (socket send-buffer recv-buffer) usocket | |
253 (setq send-buffer | |
254 (ccl::make-TUnitData (ccl::ot-conn-endpoint socket))) | |
255 (setq recv-buffer | |
256 (ccl::make-TUnitData (ccl::ot-conn-endpoint socket))))) | |
257 | |
258 (defmethod socket-send ((usocket datagram-usocket) buffer size &key host… | |
259 (with-mapped-conditions (usocket host) | |
260 (with-slots (socket send-buffer) usocket | |
261 (unless (and host port) | |
262 (unsupported 'host 'socket-send)) | |
263 (ccl::send-message socket send-buffer buffer size host port offset… | |
264 | |
265 (defmethod socket-receive ((usocket datagram-usocket) buffer length &key) | |
266 (with-mapped-conditions (usocket) | |
267 (with-slots (socket recv-buffer) usocket | |
268 (ccl::receive-message socket recv-buffer buffer length)))) | |
269 | |
270 (defmethod socket-close ((socket datagram-usocket)) | |
271 nil) ; TODO |