iolib.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
---
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-error)
13 (iolib/sockets:socket-address-family-not-supported-error . socket-type-not-supported-error)
14 (iolib/sockets:socket-address-not-available-error . address-not-available-error)
15 (iolib/sockets:socket-network-down-error . network-down-error)
16 (iolib/sockets:socket-network-reset-error . network-reset-error)
17 (iolib/sockets:socket-network-unreachable-error . network-unreachable-error)
18 ;; (iolib/sockets:socket-no-network-error . ?)
19 (iolib/sockets:socket-connection-aborted-error . connection-aborted-error)
20 (iolib/sockets:socket-connection-reset-error . connection-reset-error)
21 (iolib/sockets:socket-connection-refused-error . connection-refused-error)
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-error)
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-error)
28 ;; (iolib/sockets:socket-already-connected-error . ?)
29 (iolib/sockets:socket-not-connected-error . connection-refused-error)
30 (iolib/sockets:socket-option-not-supported-error . operation-not-permitted-error)
31 (iolib/syscalls:eacces . operation-not-permitted-error)
32 (iolib/sockets:socket-operation-not-supported-error . operation-not-supported-error)
33 (iolib/sockets:unknown-protocol . protocol-not-supported-error)
34 ;; (iolib/sockets:unknown-interface . ?)
35 (iolib/sockets:unknown-service . protocol-not-supported-error)
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-error)
41 (iolib/sockets:resolver-again-error . ns-try-again-condition)
42 (iolib/sockets:resolver-no-name-error . ns-no-recovery-error)
43 (iolib/sockets:resolver-unknown-error . ns-unknown-error)
44 ))
45
46 ;; IOlib uses (SIMPLE-ARRAY (UNSIGNED-BYTE 16) (8)) to represent IPv6 addresses,
47 ;; while USOCKET shared code uses (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (16)). Here we do the
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 nil))
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-ip))
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-ip))
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 'character)
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 host)))
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) :active)
102 ((and host port) :active)
103 (t :passive))
104 ,@(when local
105 `(:local-host ,local :local-port ,local-port))
106 :nodelay nodelay))))
107 (when remote
108 (apply #'iolib/sockets:connect
109 `(,socket ,remote :port ,port ,@(when timeout `(:wait ,timeout))))
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-hostname host)
142 :local-port port
143 :backlog backlog
144 :reuse-address (or reuse-address reuseaddress)))))
145
146 (defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
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 usocket)))))
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 usocket)))))
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 port (offset 0))
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-hostname host)
179 :remote-port ,port)))))
180
181 (defmethod socket-receive ((usocket datagram-usocket) buffer length &key start end)
182 (multiple-value-bind (buffer size host port)
183 (iolib/sockets:receive-from (socket usocket)
184 :buffer buffer :size length :start start :end end)
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 waiter))))
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-base waiter))))
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-base waiter))))))
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 (socket waiter))
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))))