tscl.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
---
tscl.lisp (10164B)
---
1 ;;;; See LICENSE for licensing information.
2
3 (in-package :usocket)
4
5 (defparameter +scl-error-map+
6 (append +unix-errno-condition-map+
7 +unix-errno-error-map+))
8
9 (defun scl-map-socket-error (err &key condition socket)
10 (let ((usock-err (cdr (assoc err +scl-error-map+ :test #'member))))
11 (cond (usock-err
12 (if (subtypep usock-err 'error)
13 (error usock-err :socket socket)
14 (signal usock-err :socket socket)))
15 (t
16 (error 'unknown-error
17 :socket socket
18 :real-error condition)))))
19
20 (defun handle-condition (condition &optional (socket nil))
21 "Dispatch correct usocket condition."
22 (typecase condition
23 (ext::socket-error
24 (scl-map-socket-error (ext::socket-errno condition)
25 :socket socket
26 :condition condition))))
27
28 (defun socket-connect (host port &key (protocol :stream) (element-type 'character)
29 timeout deadline (nodelay t nodelay-specified)
30 (local-host nil local-host-p)
31 (local-port nil local-port-p)
32 &aux
33 (patch-udp-p (fboundp 'ext::inet-socket-send-to)))
34 (when (and nodelay-specified
35 (not (eq nodelay :if-supported)))
36 (unsupported 'nodelay 'socket-connect))
37 (when deadline (unsupported 'deadline 'socket-connect))
38 (when timeout (unsupported 'timeout 'socket-connect))
39 (when (and local-host-p (not patch-udp-p))
40 (unsupported 'local-host 'socket-connect :minimum "1.3.9"))
41 (when (and local-port-p (not patch-udp-p))
42 (unsupported 'local-port 'socket-connect :minimum "1.3.9"))
43
44 (let ((socket))
45 (ecase protocol
46 (:stream
47 (setf socket (let ((args (list (host-to-hbo host) port :kind protocol)))
48 (when (and patch-udp-p (or local-host-p local-port-p))
49 (nconc args (list :local-host (when local-host
50 (host-to-hbo local-host))
51 :local-port local-port)))
52 (with-mapped-conditions (socket)
53 (apply #'ext:connect-to-inet-socket args))))
54 (let ((stream (sys:make-fd-stream socket :input t :output t
55 :element-type element-type
56 :buffering :full)))
57 (make-stream-socket :socket socket :stream stream)))
58 (:datagram
59 (when (not patch-udp-p)
60 (error 'unsupported
61 :feature '(protocol :datagram)
62 :context 'socket-connect
63 :minumum "1.3.9"))
64 (setf socket
65 (if (and host port)
66 (let ((args (list (host-to-hbo host) port :kind protocol)))
67 (when (and patch-udp-p (or local-host-p local-port-p))
68 (nconc args (list :local-host (when local-host
69 (host-to-hbo local-host))
70 :local-port local-port)))
71 (with-mapped-conditions (socket)
72 (apply #'ext:connect-to-inet-socket args)))
73 (if (or local-host-p local-port-p)
74 (with-mapped-conditions ()
75 (ext:create-inet-listener (or local-port 0)
76 protocol
77 :host (when local-host
78 (if (ip= local-host *wildcard-host*)
79 0
80 (host-to-hbo local-host)))))
81 (with-mapped-conditions ()
82 (ext:create-inet-socket protocol)))))
83 (let ((usocket (make-datagram-socket socket :connected-p (and host port t))))
84 (ext:finalize usocket #'(lambda ()
85 (when (%open-p usocket)
86 (ext:close-socket socket))))
87 usocket)))))
88
89 (defun socket-listen (host port
90 &key reuseaddress
91 (reuse-address nil reuse-address-supplied-p)
92 (backlog 5)
93 (element-type 'character))
94 (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
95 (host (if (ip= host *wildcard-host*)
96 0
97 (host-to-hbo host)))
98 (server-sock
99 (with-mapped-conditions ()
100 (ext:create-inet-listener port :stream
101 :host host
102 :reuse-address reuseaddress
103 :backlog backlog))))
104 (make-stream-server-socket server-sock :element-type element-type)))
105
106 (defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
107 (with-mapped-conditions (usocket)
108 (let* ((sock (ext:accept-tcp-connection (socket usocket)))
109 (stream (sys:make-fd-stream sock :input t :output t
110 :element-type (or element-type
111 (element-type usocket))
112 :buffering :full)))
113 (make-stream-socket :socket sock :stream stream))))
114
115 ;; Sockets and their associated streams are modelled as
116 ;; different objects. Be sure to close the socket stream
117 ;; when closing stream-sockets; it makes sure buffers
118 ;; are flushed and the socket is closed correctly afterwards.
119 (defmethod socket-close ((usocket usocket))
120 "Close socket."
121 (when (wait-list usocket)
122 (remove-waiter (wait-list usocket) usocket))
123 (with-mapped-conditions (usocket)
124 (ext:close-socket (socket usocket))))
125
126 (defmethod socket-close ((usocket stream-usocket))
127 "Close socket."
128 (when (wait-list usocket)
129 (remove-waiter (wait-list usocket) usocket))
130 (with-mapped-conditions (usocket)
131 (close (socket-stream usocket))))
132
133 (defmethod socket-close :after ((socket datagram-usocket))
134 (setf (%open-p socket) nil))
135
136 (defmethod socket-shutdown ((usocket usocket) direction)
137 (declare (ignore usocket direction))
138 (unsupported "shutdown" 'socket-shutdown))
139
140 (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port)
141 (let ((s (socket usocket))
142 (host (if host (host-to-hbo host)))
143 (real-buffer (if (zerop offset)
144 buffer
145 (subseq buffer offset (+ offset size)))))
146 (multiple-value-bind (result errno)
147 (ext:inet-socket-send-to s real-buffer size
148 :remote-host host :remote-port port)
149 (or result
150 (scl-map-socket-error errno :socket usocket)))))
151
152 (defmethod socket-receive ((socket datagram-usocket) buffer length &key)
153 (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
154 (integer 0) ; size
155 (unsigned-byte 32) ; host
156 (unsigned-byte 16))) ; port
157 (let ((s (socket socket)))
158 (let ((real-buffer (or buffer
159 (make-array length :element-type '(unsigned-byte 8))))
160 (real-length (or length
161 (length buffer))))
162 (multiple-value-bind (result errno remote-host remote-port)
163 (ext:inet-socket-receive-from s real-buffer real-length)
164 (if result
165 (values real-buffer result remote-host remote-port)
166 (scl-map-socket-error errno :socket socket))))))
167
168 (defmethod get-local-name ((usocket usocket))
169 (multiple-value-bind (address port)
170 (with-mapped-conditions (usocket)
171 (ext:get-socket-host-and-port (socket usocket)))
172 (values (hbo-to-vector-quad address) port)))
173
174 (defmethod get-peer-name ((usocket stream-usocket))
175 (multiple-value-bind (address port)
176 (with-mapped-conditions (usocket)
177 (ext:get-peer-host-and-port (socket usocket)))
178 (values (hbo-to-vector-quad address) port)))
179
180 (defmethod get-local-address ((usocket usocket))
181 (nth-value 0 (get-local-name usocket)))
182
183 (defmethod get-peer-address ((usocket stream-usocket))
184 (nth-value 0 (get-peer-name usocket)))
185
186 (defmethod get-local-port ((usocket usocket))
187 (nth-value 1 (get-local-name usocket)))
188
189 (defmethod get-peer-port ((usocket stream-usocket))
190 (nth-value 1 (get-peer-name usocket)))
191
192
193 (defun get-host-by-address (address)
194 (multiple-value-bind (host errno)
195 (ext:lookup-host-entry (host-byte-order address))
196 (cond (host
197 (ext:host-entry-name host))
198 (t
199 (let ((condition (cdr (assoc errno +unix-ns-error-map+))))
200 (cond (condition
201 (error condition :host-or-ip address))
202 (t
203 (error 'ns-unknown-error :host-or-ip address
204 :real-error errno))))))))
205
206 (defun get-hosts-by-name (name)
207 (multiple-value-bind (host errno)
208 (ext:lookup-host-entry name)
209 (cond (host
210 (mapcar #'hbo-to-vector-quad
211 (ext:host-entry-addr-list host)))
212 (t
213 (let ((condition (cdr (assoc errno +unix-ns-error-map+))))
214 (cond (condition
215 (error condition :host-or-ip name))
216 (t
217 (error 'ns-unknown-error :host-or-ip name
218 :real-error errno))))))))
219
220 (defun get-host-name ()
221 (unix:unix-gethostname))
222
223
224 ;;
225 ;;
226 ;; WAIT-LIST part
227 ;;
228
229
230 (defun %add-waiter (wl waiter)
231 (declare (ignore wl waiter)))
232
233 (defun %remove-waiter (wl waiter)
234 (declare (ignore wl waiter)))
235
236 (defun %setup-wait-list (wl)
237 (declare (ignore wl)))
238
239 (defun wait-for-input-internal (wait-list &key timeout)
240 (let* ((sockets (wait-list-waiters wait-list))
241 (pollfd-size (alien:alien-size (alien:struct unix::pollfd) :bytes))
242 (nfds (length sockets))
243 (bytes (* nfds pollfd-size)))
244 (alien:with-bytes (fds-sap bytes)
245 (do ((sockets sockets (rest sockets))
246 (base 0 (+ base 8)))
247 ((endp sockets))
248 (let ((fd (socket (first sockets))))
249 (setf (sys:sap-ref-32 fds-sap base) fd)
250 (setf (sys:sap-ref-16 fds-sap (+ base 4)) unix::pollin)))
251 (multiple-value-bind (result errno)
252 (let ((thread:*thread-whostate* "Poll wait")
253 (timeout (if timeout
254 (truncate (* timeout 1000))
255 -1)))
256 (declare (inline unix:unix-poll))
257 (unix:unix-poll (alien:sap-alien fds-sap
258 (* (alien:struct unix::pollfd)))
259 nfds timeout))
260 (cond ((not result)
261 (error "~@<Polling error: ~A~:@>"
262 (unix:get-unix-error-msg errno)))
263 (t
264 (do ((sockets sockets (rest sockets))
265 (base 0 (+ base 8)))
266 ((endp sockets))
267 (let ((flags (sys:sap-ref-16 fds-sap (+ base 6))))
268 (unless (zerop (logand flags unix::pollin))
269 (setf (state (first sockets)) :READ))))))))))
270