topenmcl.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
---
topenmcl.lisp (10498B)
---
1 ;;;; See LICENSE for licensing information.
2
3 (in-package :usocket)
4
5 (defun get-host-name ()
6 (ccl::%stack-block ((resultbuf 256))
7 (when (zerop (#_gethostname resultbuf 256))
8 (ccl::%get-cstring resultbuf))))
9
10 (defparameter +openmcl-error-map+
11 '((:address-in-use . address-in-use-error)
12 (:connection-aborted . connection-aborted-error)
13 (:no-buffer-space . no-buffers-error)
14 (:connection-timed-out . timeout-error)
15 (:connection-refused . connection-refused-error)
16 (:host-unreachable . host-unreachable-error)
17 (:host-down . host-down-error)
18 (:network-down . network-down-error)
19 (:address-not-available . address-not-available-error)
20 (:network-reset . network-reset-error)
21 (:connection-reset . connection-reset-error)
22 (:shutdown . shutdown-error)
23 (:access-denied . operation-not-permitted-error)))
24
25 (defparameter +openmcl-nameserver-error-map+
26 '((:no-recovery . ns-no-recovery-error)
27 (:try-again . ns-try-again-condition)
28 (:host-not-found . ns-host-not-found-error)))
29
30 ;; we need something which the openmcl implementors 'forgot' to do:
31 ;; wait for more than one socket-or-fd
32
33 (defun input-available-p (sockets &optional ticks-to-wait)
34 (ccl::rletZ ((tv :timeval))
35 (ccl::ticks-to-timeval ticks-to-wait tv)
36 ;;### The trickery below can be moved to the wait-list now...
37 (ccl::%stack-block ((infds ccl::*fd-set-size*))
38 (ccl::fd-zero infds)
39 (let ((max-fd -1))
40 (dolist (sock sockets)
41 (let ((fd (openmcl-socket:socket-os-fd (socket sock))))
42 (when fd ;; may be NIL if closed
43 (setf max-fd (max max-fd fd))
44 (ccl::fd-set fd infds))))
45 (let ((res (#_select (1+ max-fd)
46 infds (ccl::%null-ptr) (ccl::%null-ptr)
47 (if ticks-to-wait tv (ccl::%null-ptr)))))
48 (when (> res 0)
49 (dolist (sock sockets)
50 (let ((fd (openmcl-socket:socket-os-fd (socket sock))))
51 (when (and fd (ccl::fd-is-set fd infds))
52 (setf (state sock) :READ)))))
53 sockets)))))
54
55 (defun raise-error-from-id (condition-id socket real-condition)
56 (let ((usock-err (cdr (assoc condition-id +openmcl-error-map+))))
57 (if usock-err
58 (error usock-err :socket socket)
59 (error 'unknown-error :socket socket :real-error real-condition))))
60
61 (defun handle-condition (condition &optional socket)
62 (typecase condition
63 (openmcl-socket:socket-error
64 (raise-error-from-id (openmcl-socket:socket-error-identifier condition)
65 socket condition))
66 (ccl:input-timeout
67 (error 'timeout-error :socket socket))
68 (ccl:communication-deadline-expired
69 (error 'deadline-timeout-error :socket socket))
70 (ccl::socket-creation-error #| ugh! |#
71 (let* ((condition-id (ccl::socket-creation-error-identifier condition))
72 (nameserver-error (cdr (assoc condition-id
73 +openmcl-nameserver-error-map+))))
74 (if nameserver-error
75 (if (typep nameserver-error 'serious-condition)
76 (error nameserver-error :host-or-ip nil)
77 (signal nameserver-error :host-or-ip nil))
78 (raise-error-from-id condition-id socket condition))))))
79
80 (defun to-format (element-type protocol)
81 (cond ((null element-type)
82 (ecase protocol ; default value of different protocol
83 (:stream :text)
84 (:datagram :binary)))
85 ((subtypep element-type 'character)
86 :text)
87 (t :binary)))
88
89 #-ipv6
90 (defun socket-connect (host port &key (protocol :stream) element-type
91 timeout deadline nodelay
92 local-host local-port)
93 (when (eq nodelay :if-supported)
94 (setf nodelay t))
95 (with-mapped-conditions ()
96 (ecase protocol
97 (:stream
98 (let ((mcl-sock
99 (openmcl-socket:make-socket :remote-host (host-to-hostname host)
100 :remote-port port
101 :local-host local-host
102 :local-port local-port
103 :format (to-format element-type protocol)
104 :external-format ccl:*default-external-format*
105 :deadline deadline
106 :nodelay nodelay
107 :connect-timeout timeout)))
108 (make-stream-socket :stream mcl-sock :socket mcl-sock)))
109 (:datagram
110 (let* ((mcl-sock
111 (openmcl-socket:make-socket :address-family :internet
112 :type :datagram
113 :local-host local-host
114 :local-port local-port
115 :input-timeout timeout
116 :format (to-format element-type protocol)
117 :external-format ccl:*default-external-format*))
118 (usocket (make-datagram-socket mcl-sock)))
119 (when (and host port)
120 (ccl::inet-connect (ccl::socket-device mcl-sock)
121 (ccl::host-as-inet-host host)
122 (ccl::port-as-inet-port port "udp")))
123 (setf (connected-p usocket) t)
124 usocket)))))
125
126 #-ipv6
127 (defun socket-listen (host port
128 &key reuseaddress
129 (reuse-address nil reuse-address-supplied-p)
130 (backlog 5)
131 (element-type 'character))
132 (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
133 (real-host (host-to-hostname host))
134 (sock (with-mapped-conditions ()
135 (apply #'openmcl-socket:make-socket
136 (append (list :connect :passive
137 :reuse-address reuseaddress
138 :local-port port
139 :backlog backlog
140 :format (to-format element-type :stream))
141 (unless (eq host *wildcard-host*)
142 (list :local-host real-host)))))))
143 (make-stream-server-socket sock :element-type element-type)))
144
145 (defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
146 (declare (ignore element-type)) ;; openmcl streams are bi/multivalent
147 (let ((sock (with-mapped-conditions (usocket)
148 (openmcl-socket:accept-connection (socket usocket)))))
149 (make-stream-socket :socket sock :stream sock)))
150
151 ;; One close method is sufficient because sockets
152 ;; and their associated objects are represented
153 ;; by the same object.
154 (defmethod socket-close ((usocket usocket))
155 (when (wait-list usocket)
156 (remove-waiter (wait-list usocket) usocket))
157 (with-mapped-conditions (usocket)
158 (close (socket usocket))))
159
160 (defmethod socket-shutdown ((usocket usocket) direction)
161 (with-mapped-conditions (usocket)
162 (openmcl-socket:shutdown (socket usocket) :direction direction)))
163
164 #-ipv6
165 (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
166 (with-mapped-conditions (usocket)
167 (if (and host port)
168 (openmcl-socket:send-to (socket usocket) buffer size
169 :remote-host (host-to-hbo host)
170 :remote-port port
171 :offset offset)
172 ;; Clozure CL's socket function SEND-TO doesn't support operations on connected UDP sockets,
173 ;; so we have to define our own.
174 (let* ((socket (socket usocket))
175 (fd (ccl::socket-device socket)))
176 (multiple-value-setq (buffer offset)
177 (ccl::verify-socket-buffer buffer offset size))
178 (ccl::%stack-block ((bufptr size))
179 (ccl::%copy-ivector-to-ptr buffer offset bufptr 0 size)
180 (ccl::socket-call socket "send"
181 (ccl::with-eagain fd :output
182 (ccl::ignoring-eintr
183 (ccl::check-socket-error (#_send fd bufptr size 0))))))))))
184
185 (defmethod socket-receive ((usocket datagram-usocket) buffer length &key)
186 (with-mapped-conditions (usocket)
187 (openmcl-socket:receive-from (socket usocket) length :buffer buffer)))
188
189 (defun usocket-host-address (address)
190 (cond
191 ((integerp address)
192 (hbo-to-vector-quad address))
193 ((and (arrayp address)
194 (= (length address) 16)
195 (every #'= address #(0 0 0 0 0 0 0 0 0 0 #xff #xff)))
196 (make-array 4 :displaced-to address :displaced-index-offset 12))
197 (t
198 address)))
199
200 (defmethod get-local-address ((usocket usocket))
201 (usocket-host-address (openmcl-socket:local-host (socket usocket))))
202
203 (defmethod get-peer-address ((usocket stream-usocket))
204 (usocket-host-address (openmcl-socket:remote-host (socket usocket))))
205
206 (defmethod get-local-port ((usocket usocket))
207 (openmcl-socket:local-port (socket usocket)))
208
209 (defmethod get-peer-port ((usocket stream-usocket))
210 (openmcl-socket:remote-port (socket usocket)))
211
212 (defmethod get-local-name ((usocket usocket))
213 (values (get-local-address usocket)
214 (get-local-port usocket)))
215
216 (defmethod get-peer-name ((usocket stream-usocket))
217 (values (get-peer-address usocket)
218 (get-peer-port usocket)))
219
220 (defun get-host-by-address (address)
221 (with-mapped-conditions ()
222 (openmcl-socket:ipaddr-to-hostname (host-to-hbo address))))
223
224 (defun get-hosts-by-name (name)
225 (with-mapped-conditions ()
226 (list (hbo-to-vector-quad (openmcl-socket:lookup-hostname
227 (host-to-hostname name))))))
228
229 (defun %setup-wait-list (wait-list)
230 (declare (ignore wait-list)))
231
232 (defun %add-waiter (wait-list waiter)
233 (declare (ignore wait-list waiter)))
234
235 (defun %remove-waiter (wait-list waiter)
236 (declare (ignore wait-list waiter)))
237
238 (defun wait-for-input-internal (wait-list &key timeout)
239 (with-mapped-conditions ()
240 (let* ((ticks-timeout (truncate (* (or timeout 1)
241 ccl::*ticks-per-second*))))
242 (input-available-p (wait-list-waiters wait-list)
243 (when timeout ticks-timeout))
244 wait-list)))
245
246 ;;; Helper functions for option.lisp
247
248 (defun get-socket-option-reuseaddr (socket)
249 (ccl::int-getsockopt (ccl::socket-device socket)
250 #$SOL_SOCKET #$SO_REUSEADDR))
251
252 (defun set-socket-option-reuseaddr (socket value)
253 (ccl::int-setsockopt (ccl::socket-device socket)
254 #$SOL_SOCKET #$SO_REUSEADDR value))
255
256 (defun get-socket-option-broadcast (socket)
257 (ccl::int-getsockopt (ccl::socket-device socket)
258 #$SOL_SOCKET #$SO_BROADCAST))
259
260 (defun set-socket-option-broadcast (socket value)
261 (ccl::int-setsockopt (ccl::socket-device socket)
262 #$SOL_SOCKET #$SO_BROADCAST value))
263
264 (defun get-socket-option-tcp-nodelay (socket)
265 (ccl::int-getsockopt (ccl::socket-device socket)
266 #$IPPROTO_TCP #$TCP_NODELAY))
267
268 (defun set-socket-option-tcp-nodelay (socket value)
269 (ccl::int-setsockopt (ccl::socket-device socket)
270 #$IPPROTO_TCP #$TCP_NODELAY value))