iolib.lisp - clic - Clic is an command line interactive client for gopher writt… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
iolib.lisp (11860B) | |
--- | |
1 ;;;; See LICENSE for licensing information. | |
2 | |
3 (in-package :usocket) | |
4 | |
5 (defparameter *backend* :iolib) | |
6 | |
7 (eval-when (:load-toplevel :execute) | |
8 (shadowing-import 'iolib/sockets:socket-option) | |
9 (export 'socket-option)) | |
10 | |
11 (defparameter +iolib-error-map+ | |
12 `((iolib/sockets:socket-address-in-use-error . address-in-use-er… | |
13 (iolib/sockets:socket-address-family-not-supported-error . socket-typ… | |
14 (iolib/sockets:socket-address-not-available-error . address-not-avail… | |
15 (iolib/sockets:socket-network-down-error . network-down-erro… | |
16 (iolib/sockets:socket-network-reset-error . network-reset-err… | |
17 (iolib/sockets:socket-network-unreachable-error . network-unreachab… | |
18 ;; (iolib/sockets:socket-no-network-error . ?) | |
19 (iolib/sockets:socket-connection-aborted-error . connection-aborte… | |
20 (iolib/sockets:socket-connection-reset-error . connection-reset-… | |
21 (iolib/sockets:socket-connection-refused-error . connection-refuse… | |
22 (iolib/sockets:socket-connection-timeout-error . timeout-error) | |
23 ;; (iolib/sockets:socket-connection-in-progress-error . ?) | |
24 (iolib/sockets:socket-endpoint-shutdown-error . network-down-erro… | |
25 (iolib/sockets:socket-no-buffer-space-error . no-buffers-error) | |
26 (iolib/sockets:socket-host-down-error . host-down-error) | |
27 (iolib/sockets:socket-host-unreachable-error . host-unreachable-… | |
28 ;; (iolib/sockets:socket-already-connected-error . ?) | |
29 (iolib/sockets:socket-not-connected-error . connection-refuse… | |
30 (iolib/sockets:socket-option-not-supported-error . operation-not-per… | |
31 (iolib/syscalls:eacces . operation-not-per… | |
32 (iolib/sockets:socket-operation-not-supported-error . operation-not-s… | |
33 (iolib/sockets:unknown-protocol . protocol-not-supp… | |
34 ;; (iolib/sockets:unknown-interface . ?) | |
35 (iolib/sockets:unknown-service . protocol-not-supp… | |
36 (iolib/sockets:socket-error . socket-error) | |
37 | |
38 ;; Nameservice errors (src/sockets/dns/conditions.lisp) | |
39 (iolib/sockets:resolver-error . ns-error) | |
40 (iolib/sockets:resolver-fail-error . ns-host-not-found… | |
41 (iolib/sockets:resolver-again-error . ns-try-again-cond… | |
42 (iolib/sockets:resolver-no-name-error . ns-no-recovery-er… | |
43 (iolib/sockets:resolver-unknown-error . ns-unknown-error) | |
44 )) | |
45 | |
46 ;; IOlib uses (SIMPLE-ARRAY (UNSIGNED-BYTE 16) (8)) to represent IPv6 ad… | |
47 ;; while USOCKET shared code uses (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (16)).… | |
48 ;; conversion. | |
49 (defun iolib-vector-to-vector-quad (host) | |
50 (etypecase host | |
51 ((or (vector t 4) ; IPv4 | |
52 (array (unsigned-byte 8) (4))) | |
53 host) | |
54 ((or (vector t 8) ; IPv6 | |
55 (array (unsigned-byte 16) (8))) | |
56 (loop with vector = (make-array 16 :element-type '(unsigned-byte 8… | |
57 for i below 16 by 2 | |
58 for word = (aref host (/ i 2)) | |
59 do (setf (aref vector i) (ldb (byte 8 8) word) | |
60 (aref vector (1+ i)) (ldb (byte 8 0) word)) | |
61 finally (return vector))))) | |
62 | |
63 (defun handle-condition (condition &optional (socket nil) (host-or-ip ni… | |
64 "Dispatch correct usocket condition." | |
65 (let* ((usock-error (cdr (assoc (type-of condition) +iolib-error-map+)… | |
66 (usock-error (if (functionp usock-error) | |
67 (funcall usock-error condition) | |
68 usock-error))) | |
69 (if usock-error | |
70 (if (typep usock-error 'socket-error) | |
71 (cond ((subtypep usock-error 'ns-error) | |
72 (error usock-error :socket socket :host-or-ip host-or-… | |
73 (t | |
74 (error usock-error :socket socket))) | |
75 (cond ((subtypep usock-error 'ns-condition) | |
76 (signal usock-error :socket socket :host-or-ip host-or… | |
77 (t | |
78 (signal usock-error :socket socket)))) | |
79 (error 'unknown-error | |
80 :real-error condition | |
81 :socket socket)))) | |
82 | |
83 (defun ipv6-address-p (host) | |
84 (iolib/sockets:ipv6-address-p (iolib/sockets:ensure-hostname host))) | |
85 | |
86 (defun socket-connect (host port &key (protocol :stream) (element-type '… | |
87 timeout deadline | |
88 (nodelay t) ;; nodelay == t is the ACL default | |
89 local-host local-port) | |
90 (declare (ignore element-type deadline nodelay)) | |
91 (with-mapped-conditions (nil host) | |
92 (let* ((remote (when (and host port) (iolib/sockets:ensure-hostname … | |
93 (local (when (and local-host local-port) | |
94 (iolib/sockets:ensure-hostname local-host))) | |
95 (ipv6-p (or (and remote (ipv6-address-p remote) | |
96 (and local (ipv6-address-p local))))) | |
97 (socket (apply #'iolib/sockets:make-socket | |
98 `(:type ,protocol | |
99 :address-family :internet | |
100 :ipv6 ,ipv6-p | |
101 :connect ,(cond ((eq protocol :stream) :acti… | |
102 ((and host port) :acti… | |
103 (t :pass… | |
104 ,@(when local | |
105 `(:local-host ,local :local-port ,local-… | |
106 :nodelay nodelay)))) | |
107 (when remote | |
108 (apply #'iolib/sockets:connect | |
109 `(,socket ,remote :port ,port ,@(when timeout `(:wait ,ti… | |
110 (unless (iolib/sockets:socket-connected-p socket) | |
111 (close socket) | |
112 (error 'iolib/sockets:socket-error))) | |
113 (ecase protocol | |
114 (:stream | |
115 (make-stream-socket :stream socket :socket socket)) | |
116 (:datagram | |
117 (make-datagram-socket socket :connected-p (and remote t))))))) | |
118 | |
119 (defmethod socket-close ((usocket usocket)) | |
120 (close (socket usocket))) | |
121 | |
122 (defmethod socket-shutdown ((usocket stream-usocket) direction) | |
123 (with-mapped-conditions () | |
124 (case direction | |
125 (:input | |
126 (iolib/sockets:shutdown (socket usocket) :read t)) | |
127 (:output | |
128 (iolib/sockets:shutdown (socket usocket) :write t)) | |
129 (t ; :io by default | |
130 (iolib/sockets:shutdown (socket usocket) :read t :write t))))) | |
131 | |
132 (defun socket-listen (host port | |
133 &key reuseaddress reuse-address | |
134 (backlog 5) | |
135 (element-type 'character)) | |
136 (declare (ignore element-type)) | |
137 (with-mapped-conditions (nil host) | |
138 (make-stream-server-socket | |
139 (iolib/sockets:make-socket :connect :passive | |
140 :address-family :internet | |
141 :local-host (iolib/sockets:ensure-hostn… | |
142 :local-port port | |
143 :backlog backlog | |
144 :reuse-address (or reuse-address reusea… | |
145 | |
146 (defmethod socket-accept ((usocket stream-server-usocket) &key element-t… | |
147 (declare (ignore element-type)) | |
148 (with-mapped-conditions (usocket) | |
149 (let ((socket (iolib/sockets:accept-connection (socket usocket)))) | |
150 (make-stream-socket :socket socket :stream socket)))) | |
151 | |
152 (defmethod get-local-address ((usocket usocket)) | |
153 (iolib-vector-to-vector-quad | |
154 (iolib/sockets:address-to-vector (iolib/sockets:local-host (socket us… | |
155 | |
156 (defmethod get-peer-address ((usocket stream-usocket)) | |
157 (iolib-vector-to-vector-quad | |
158 (iolib/sockets:address-to-vector (iolib/sockets:remote-host (socket u… | |
159 | |
160 (defmethod get-local-port ((usocket usocket)) | |
161 (iolib/sockets:local-port (socket usocket))) | |
162 | |
163 (defmethod get-peer-port ((usocket stream-usocket)) | |
164 (iolib/sockets:remote-port (socket usocket))) | |
165 | |
166 (defmethod get-local-name ((usocket usocket)) | |
167 (values (get-local-address usocket) | |
168 (get-local-port usocket))) | |
169 | |
170 (defmethod get-peer-name ((usocket stream-usocket)) | |
171 (values (get-peer-address usocket) | |
172 (get-peer-port usocket))) | |
173 | |
174 (defmethod socket-send ((usocket datagram-usocket) buffer size &key host… | |
175 (apply #'iolib/sockets:send-to | |
176 `(,(socket usocket) ,buffer :start ,offset :end ,(+ offset size) | |
177 ,@(when (and host port) | |
178 `(:remote-host ,(iolib/sockets:ensure-h… | |
179 :remote-port ,port))))) | |
180 | |
181 (defmethod socket-receive ((usocket datagram-usocket) buffer length &key… | |
182 (multiple-value-bind (buffer size host port) | |
183 (iolib/sockets:receive-from (socket usocket) | |
184 :buffer buffer :size length :start sta… | |
185 (values buffer size (iolib-vector-to-vector-quad host) port))) | |
186 | |
187 (defun get-hosts-by-name (name) | |
188 (with-mapped-conditions (nil name) | |
189 (multiple-value-bind (address more-addresses) | |
190 (iolib/sockets:lookup-hostname name :ipv6 iolib/sockets:*ipv6*) | |
191 (mapcar #'(lambda (x) (iolib-vector-to-vector-quad | |
192 (iolib/sockets:address-name x))) | |
193 (cons address more-addresses))))) | |
194 | |
195 (defun get-host-by-address (address) | |
196 (with-mapped-conditions (nil address) | |
197 nil)) ;; TODO | |
198 | |
199 (defvar *event-base* | |
200 (make-instance 'iolib/multiplex:event-base)) | |
201 | |
202 (defun %setup-wait-list (wait-list) | |
203 (setf (wait-list-%wait wait-list) | |
204 (or *event-base* | |
205 ;; iolib/multiplex:*default-multiplexer* is used here | |
206 (make-instance 'iolib/multiplex:event-base)))) | |
207 | |
208 (defun make-usocket-read-handler (usocket disconnector) | |
209 (lambda (fd event exception) | |
210 (declare (ignore fd event exception)) | |
211 (handler-case | |
212 (if (eq (state usocket) :write) | |
213 (setf (state usocket) :read-write) | |
214 (setf (state usocket) :read)) | |
215 (end-of-file () | |
216 (funcall disconnector :close))))) | |
217 | |
218 (defun make-usocket-write-handler (usocket disconnector) | |
219 (lambda (fd event exception) | |
220 (declare (ignore fd event exception)) | |
221 (handler-case | |
222 (if (eq (state usocket) :read) | |
223 (setf (state usocket) :read-write) | |
224 (setf (state usocket) :write)) | |
225 (end-of-file () | |
226 (funcall disconnector :close)) | |
227 (iolib/streams:hangup () | |
228 (funcall disconnector :close))))) | |
229 | |
230 (defun make-usocket-error-handler (usocket disconnector) | |
231 (lambda (fd event exception) | |
232 (declare (ignore fd event exception)) | |
233 (handler-case | |
234 (setf (state usocket) nil) | |
235 (end-of-file () | |
236 (funcall disconnector :close)) | |
237 (iolib/streams:hangup () | |
238 (funcall disconnector :close))))) | |
239 | |
240 (defun make-usocket-disconnector (event-base usocket) | |
241 (declare (ignore event-base)) | |
242 (lambda (&rest events) | |
243 (let ((socket (socket usocket))) | |
244 ;; if were asked to close the socket, we do so here | |
245 (when (member :close events) | |
246 (close socket :abort t))))) | |
247 | |
248 (defun %add-waiter (wait-list waiter) | |
249 (let ((event-base (wait-list-%wait wait-list)) | |
250 (fd (iolib/sockets:socket-os-fd (socket waiter)))) | |
251 ;; reset socket state | |
252 (setf (state waiter) nil) | |
253 ;; set read handler | |
254 (unless (iolib/multiplex::fd-monitored-p event-base fd :read) | |
255 (iolib/multiplex:set-io-handler | |
256 event-base fd :read | |
257 (make-usocket-read-handler waiter | |
258 (make-usocket-disconnector event-base… | |
259 ;; set write handler | |
260 #+ignore | |
261 (unless (iolib/multiplex::fd-monitored-p event-base fd :write) | |
262 (iolib/multiplex:set-io-handler | |
263 event-base fd :write | |
264 (make-usocket-write-handler waiter | |
265 (make-usocket-disconnector event-bas… | |
266 ;; set error handler | |
267 (unless (iolib/multiplex::fd-has-error-handler-p event-base fd) | |
268 (iolib/multiplex:set-error-handler | |
269 event-base fd | |
270 (make-usocket-error-handler waiter | |
271 (make-usocket-disconnector event-bas… | |
272 | |
273 (defun %remove-waiter (wait-list waiter) | |
274 (let ((event-base (wait-list-%wait wait-list))) | |
275 (iolib/multiplex:remove-fd-handlers event-base | |
276 (iolib/sockets:socket-os-fd (soc… | |
277 :read t | |
278 :write nil | |
279 :error t))) | |
280 | |
281 ;; NOTE: `wait-list-waiters` returns all usockets | |
282 (defun wait-for-input-internal (wait-list &key timeout) | |
283 (let ((event-base (wait-list-%wait wait-list))) | |
284 (handler-case | |
285 (iolib/multiplex:event-dispatch event-base :timeout timeout) | |
286 (iolib/streams:hangup ()) | |
287 (end-of-file ())) | |
288 ;; close the event-base after use | |
289 (unless (eq event-base *event-base*) | |
290 (close event-base)))) |