openmcl.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
---
openmcl.lisp (10491B)
---
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 (host-or-ip nil))
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 host-or-ip)
77 (signal nameserver-error :host-or-ip host-or-ip))
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 (nil host)
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 (nil host)
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 (with-mapped-conditions (usocket)
156 (close (socket usocket))))
157
158 (defmethod socket-shutdown ((usocket usocket) direction)
159 (with-mapped-conditions (usocket)
160 (openmcl-socket:shutdown (socket usocket) :direction direction)))
161
162 #-ipv6
163 (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
164 (with-mapped-conditions (usocket host)
165 (if (and host port)
166 (openmcl-socket:send-to (socket usocket) buffer size
167 :remote-host (host-to-hbo host)
168 :remote-port port
169 :offset offset)
170 ;; Clozure CL's socket function SEND-TO doesn't support operations on connected UDP sockets,
171 ;; so we have to define our own.
172 (let* ((socket (socket usocket))
173 (fd (ccl::socket-device socket)))
174 (multiple-value-setq (buffer offset)
175 (ccl::verify-socket-buffer buffer offset size))
176 (ccl::%stack-block ((bufptr size))
177 (ccl::%copy-ivector-to-ptr buffer offset bufptr 0 size)
178 (ccl::socket-call socket "send"
179 (ccl::with-eagain fd :output
180 (ccl::ignoring-eintr
181 (ccl::check-socket-error (#_send fd bufptr size 0))))))))))
182
183 (defmethod socket-receive ((usocket datagram-usocket) buffer length &key)
184 (with-mapped-conditions (usocket)
185 (openmcl-socket:receive-from (socket usocket) length :buffer buffer)))
186
187 (defun usocket-host-address (address)
188 (cond
189 ((integerp address)
190 (hbo-to-vector-quad address))
191 ((and (arrayp address)
192 (= (length address) 16)
193 (every #'= address #(0 0 0 0 0 0 0 0 0 0 #xff #xff)))
194 (make-array 4 :displaced-to address :displaced-index-offset 12))
195 (t
196 address)))
197
198 (defmethod get-local-address ((usocket usocket))
199 (usocket-host-address (openmcl-socket:local-host (socket usocket))))
200
201 (defmethod get-peer-address ((usocket stream-usocket))
202 (usocket-host-address (openmcl-socket:remote-host (socket usocket))))
203
204 (defmethod get-local-port ((usocket usocket))
205 (openmcl-socket:local-port (socket usocket)))
206
207 (defmethod get-peer-port ((usocket stream-usocket))
208 (openmcl-socket:remote-port (socket usocket)))
209
210 (defmethod get-local-name ((usocket usocket))
211 (values (get-local-address usocket)
212 (get-local-port usocket)))
213
214 (defmethod get-peer-name ((usocket stream-usocket))
215 (values (get-peer-address usocket)
216 (get-peer-port usocket)))
217
218 (defun get-host-by-address (address)
219 (with-mapped-conditions (nil address)
220 (openmcl-socket:ipaddr-to-hostname (host-to-hbo address))))
221
222 (defun get-hosts-by-name (name)
223 (with-mapped-conditions (nil name)
224 (list (hbo-to-vector-quad (openmcl-socket:lookup-hostname
225 (host-to-hostname name))))))
226
227 (defun %setup-wait-list (wait-list)
228 (declare (ignore wait-list)))
229
230 (defun %add-waiter (wait-list waiter)
231 (declare (ignore wait-list waiter)))
232
233 (defun %remove-waiter (wait-list waiter)
234 (declare (ignore wait-list waiter)))
235
236 (defun wait-for-input-internal (wait-list &key timeout)
237 (with-mapped-conditions ()
238 (let* ((ticks-timeout (truncate (* (or timeout 1)
239 ccl::*ticks-per-second*))))
240 (input-available-p (wait-list-waiters wait-list)
241 (when timeout ticks-timeout))
242 wait-list)))
243
244 ;;; Helper functions for option.lisp
245
246 (defun get-socket-option-reuseaddr (socket)
247 (ccl::int-getsockopt (ccl::socket-device socket)
248 #$SOL_SOCKET #$SO_REUSEADDR))
249
250 (defun set-socket-option-reuseaddr (socket value)
251 (ccl::int-setsockopt (ccl::socket-device socket)
252 #$SOL_SOCKET #$SO_REUSEADDR value))
253
254 (defun get-socket-option-broadcast (socket)
255 (ccl::int-getsockopt (ccl::socket-device socket)
256 #$SOL_SOCKET #$SO_BROADCAST))
257
258 (defun set-socket-option-broadcast (socket value)
259 (ccl::int-setsockopt (ccl::socket-device socket)
260 #$SOL_SOCKET #$SO_BROADCAST value))
261
262 (defun get-socket-option-tcp-nodelay (socket)
263 (ccl::int-getsockopt (ccl::socket-device socket)
264 #$IPPROTO_TCP #$TCP_NODELAY))
265
266 (defun set-socket-option-tcp-nodelay (socket value)
267 (ccl::int-setsockopt (ccl::socket-device socket)
268 #$IPPROTO_TCP #$TCP_NODELAY value))