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