mcl.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
mcl.lisp (11738B)
---
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 (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 host-or-ip))
12 (t
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 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 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 (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-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 (nil (or host local-host))
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 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 usocket)) ""))))
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 usocket)))))
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 :initarg :element-type)))
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 :connect-timeout
139 :type (or null fixnum) :documentation "ticks (60th of a second)")))
140
141 (defmethod socket-open-stream ((socket active-socket))
142 (ccl::open-tcp-stream (or (remote-host socket)(ccl::local-interface-ip-address)) (remote-port socket)
143 :element-type (if (subtypep (element-type socket) 'character) 'ccl::base-character 'unsigned-byte)
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 the next to open")
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 backlog)
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 (lock (socket-lock socket)))
167 (flet ((connection-established-p (stream)
168 (ccl::with-io-buffer-locked ((ccl::stream-io-buffer stream nil))
169 (let ((state (ccl::opentransport-stream-connection-state stream)))
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-type))))
175 (pop (socket-streams socket))
176 (ccl:process-wait "Accepting" #'connection-established-p connection)
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) #$kOTAnyInetAddress)
191 :reuse-local-port-p (reuse-address socket)
192 :element-type (if (subtypep (or element-type (element-type socket))
193 'character)
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-value-p) &body body)
201 "Evaluates the body if and only if the lock is successfully grabbed"
202 ;; like with-io-buffer-lock-grabbed but returns immediately instead of polling the lock
203 (let ((needs-unlocking-p (gensym))
204 (lock-var (gensym)))
205 `(let* ((,lock-var ,lock)
206 (ccl::*grabbed-io-buffer-locks* (cons ,lock-var ccl::*grabbed-io-buffer-locks*))
207 (,needs-unlocking-p (needs-unlocking-p ,lock-var)))
208 (declare (dynamic-extent ccl::*grabbed-io-buffer-locks*))
209 (when ,needs-unlocking-p
210 (,(if multiple-value-p 'multiple-value-prog1 'prog1)
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-lock-out-of-line:
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 without waiting for lock"
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-buffer))
224 (funcall (ccl::io-buffer-listen-function io-buffer) stream io-buffer))))))))
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 (socket sock)))))
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 port (offset 0))
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