scl.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
---
scl.lisp (10025B)
---
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) (host-or-ip 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 (with-mapped-conditions (usocket)
122 (ext:close-socket (socket usocket))))
123
124 (defmethod socket-close ((usocket stream-usocket))
125 "Close socket."
126 (with-mapped-conditions (usocket)
127 (close (socket-stream usocket))))
128
129 (defmethod socket-close :after ((socket datagram-usocket))
130 (setf (%open-p socket) nil))
131
132 (defmethod socket-shutdown ((usocket usocket) direction)
133 (declare (ignore usocket direction))
134 (unsupported "shutdown" 'socket-shutdown))
135
136 (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port)
137 (let ((s (socket usocket))
138 (host (if host (host-to-hbo host)))
139 (real-buffer (if (zerop offset)
140 buffer
141 (subseq buffer offset (+ offset size)))))
142 (multiple-value-bind (result errno)
143 (ext:inet-socket-send-to s real-buffer size
144 :remote-host host :remote-port port)
145 (or result
146 (scl-map-socket-error errno :socket usocket)))))
147
148 (defmethod socket-receive ((socket datagram-usocket) buffer length &key)
149 (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
150 (integer 0) ; size
151 (unsigned-byte 32) ; host
152 (unsigned-byte 16))) ; port
153 (let ((s (socket socket)))
154 (let ((real-buffer (or buffer
155 (make-array length :element-type '(unsigned-byte 8))))
156 (real-length (or length
157 (length buffer))))
158 (multiple-value-bind (result errno remote-host remote-port)
159 (ext:inet-socket-receive-from s real-buffer real-length)
160 (if result
161 (values real-buffer result remote-host remote-port)
162 (scl-map-socket-error errno :socket socket))))))
163
164 (defmethod get-local-name ((usocket usocket))
165 (multiple-value-bind (address port)
166 (with-mapped-conditions (usocket)
167 (ext:get-socket-host-and-port (socket usocket)))
168 (values (hbo-to-vector-quad address) port)))
169
170 (defmethod get-peer-name ((usocket stream-usocket))
171 (multiple-value-bind (address port)
172 (with-mapped-conditions (usocket)
173 (ext:get-peer-host-and-port (socket usocket)))
174 (values (hbo-to-vector-quad address) port)))
175
176 (defmethod get-local-address ((usocket usocket))
177 (nth-value 0 (get-local-name usocket)))
178
179 (defmethod get-peer-address ((usocket stream-usocket))
180 (nth-value 0 (get-peer-name usocket)))
181
182 (defmethod get-local-port ((usocket usocket))
183 (nth-value 1 (get-local-name usocket)))
184
185 (defmethod get-peer-port ((usocket stream-usocket))
186 (nth-value 1 (get-peer-name usocket)))
187
188
189 (defun get-host-by-address (address)
190 (multiple-value-bind (host errno)
191 (ext:lookup-host-entry (host-byte-order address))
192 (cond (host
193 (ext:host-entry-name host))
194 (t
195 (let ((condition (cdr (assoc errno +unix-ns-error-map+))))
196 (cond (condition
197 (error condition :host-or-ip address))
198 (t
199 (error 'ns-unknown-error :host-or-ip address
200 :real-error errno))))))))
201
202 (defun get-hosts-by-name (name)
203 (multiple-value-bind (host errno)
204 (ext:lookup-host-entry name)
205 (cond (host
206 (mapcar #'hbo-to-vector-quad
207 (ext:host-entry-addr-list host)))
208 (t
209 (let ((condition (cdr (assoc errno +unix-ns-error-map+))))
210 (cond (condition
211 (error condition :host-or-ip name))
212 (t
213 (error 'ns-unknown-error :host-or-ip name
214 :real-error errno))))))))
215
216 (defun get-host-name ()
217 (unix:unix-gethostname))
218
219
220 ;;
221 ;;
222 ;; WAIT-LIST part
223 ;;
224
225
226 (defun %add-waiter (wl waiter)
227 (declare (ignore wl waiter)))
228
229 (defun %remove-waiter (wl waiter)
230 (declare (ignore wl waiter)))
231
232 (defun %setup-wait-list (wl)
233 (declare (ignore wl)))
234
235 (defun wait-for-input-internal (wait-list &key timeout)
236 (let* ((sockets (wait-list-waiters wait-list))
237 (pollfd-size (alien:alien-size (alien:struct unix::pollfd) :bytes))
238 (nfds (length sockets))
239 (bytes (* nfds pollfd-size)))
240 (alien:with-bytes (fds-sap bytes)
241 (do ((sockets sockets (rest sockets))
242 (base 0 (+ base 8)))
243 ((endp sockets))
244 (let ((fd (socket (first sockets))))
245 (setf (sys:sap-ref-32 fds-sap base) fd)
246 (setf (sys:sap-ref-16 fds-sap (+ base 4)) unix::pollin)))
247 (multiple-value-bind (result errno)
248 (let ((thread:*thread-whostate* "Poll wait")
249 (timeout (if timeout
250 (truncate (* timeout 1000))
251 -1)))
252 (declare (inline unix:unix-poll))
253 (unix:unix-poll (alien:sap-alien fds-sap
254 (* (alien:struct unix::pollfd)))
255 nfds timeout))
256 (cond ((not result)
257 (error "~@<Polling error: ~A~:@>"
258 (unix:get-unix-error-msg errno)))
259 (t
260 (do ((sockets sockets (rest sockets))
261 (base 0 (+ base 8)))
262 ((endp sockets))
263 (let ((flags (sys:sap-ref-16 fds-sap (+ base 6))))
264 (unless (zerop (logand flags unix::pollin))
265 (setf (state (first sockets)) :READ))))))))))
266