usocket.lisp - clic - Clic is an command line interactive client for gopher wri… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
usocket.lisp (27397B) | |
--- | |
1 ;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKE… | |
2 ;;;; See LICENSE for licensing information. | |
3 | |
4 (in-package :usocket) | |
5 | |
6 (defparameter *wildcard-host* #(0 0 0 0) | |
7 "Hostname to pass when all interfaces in the current system are to | |
8 be bound. If this variable is passed to socket-listen, IPv6 capable | |
9 systems will also listen for IPv6 connections.") | |
10 | |
11 (defparameter *auto-port* 0 | |
12 "Port number to pass when an auto-assigned port number is wanted.") | |
13 | |
14 (defparameter *version* #.(asdf:component-version (asdf:find-system :uso… | |
15 "usocket version string") | |
16 | |
17 (defconstant +max-datagram-packet-size+ 65507 | |
18 "The theoretical maximum amount of data in a UDP datagram. | |
19 | |
20 The IPv4 UDP packets have a 16-bit length constraint, and IP+UDP header … | |
21 | |
22 IP_MAXPACKET = 65535, /* netinet/ip.h */ | |
23 sizeof(struct ip) = 20, /* netinet/ip.h */ | |
24 sizeof(struct udphdr) = 8, /* netinet/udp.h */ | |
25 | |
26 65535 - 20 - 8 = 65507 | |
27 | |
28 (But for UDP broadcast, the maximum message size is limited by the MTU s… | |
29 | |
30 (defclass usocket () | |
31 ((socket | |
32 :initarg :socket | |
33 :accessor socket | |
34 :documentation "Implementation specific socket object instance.'") | |
35 (wait-list | |
36 :initform nil | |
37 :accessor wait-list | |
38 :documentation "WAIT-LIST the object is associated with.") | |
39 (state | |
40 :initform nil | |
41 :accessor state | |
42 :documentation "Per-socket return value for the `wait-for-input' fun… | |
43 | |
44 The value stored in this slot can be any of | |
45 NIL - not ready | |
46 :READ - ready to read | |
47 :READ-WRITE - ready to read and write | |
48 :WRITE - ready to write | |
49 | |
50 The last two remain unused in the current version. | |
51 ") | |
52 #+(and win32 (or sbcl ecl lispworks)) | |
53 (%ready-p | |
54 :initform nil | |
55 :accessor %ready-p | |
56 :documentation "Indicates whether the socket has been signalled | |
57 as ready for reading a new connection. | |
58 | |
59 The value will be set to T by `wait-for-input-internal' (given the | |
60 right conditions) and reset to NIL by `socket-accept'. | |
61 | |
62 Don't modify this slot or depend on it as it is really intended | |
63 to be internal only. | |
64 | |
65 Note: Accessed, but not used for 'stream-usocket'. | |
66 " | |
67 )) | |
68 (:documentation | |
69 "The main socket class. | |
70 | |
71 Sockets should be closed using the `socket-close' method.")) | |
72 | |
73 (defgeneric socket-state (socket) | |
74 (:documentation "NIL - not ready | |
75 :READ - ready to read | |
76 :READ-WRITE - ready to read and write | |
77 :WRITE - ready to write")) | |
78 | |
79 (defmethod socket-state ((socket usocket)) | |
80 (state socket)) | |
81 | |
82 (defclass stream-usocket (usocket) | |
83 ((stream | |
84 :initarg :stream | |
85 :accessor socket-stream | |
86 :documentation "Stream instance associated with the socket." | |
87 ;; | |
88 ;;Iff an external-format was passed to `socket-connect' or `socket-liste… | |
89 ;;the stream is a flexi-stream. Otherwise the stream is implementation | |
90 ;;specific." | |
91 )) | |
92 (:documentation | |
93 "Stream socket class. | |
94 ' | |
95 Contrary to other sockets, these sockets may be closed either | |
96 with the `socket-close' method or by closing the associated stream | |
97 (which can be retrieved with the `socket-stream' accessor).")) | |
98 | |
99 (defclass stream-server-usocket (usocket) | |
100 ((element-type | |
101 :initarg :element-type | |
102 :initform #-lispworks 'character | |
103 #+lispworks 'base-char | |
104 :reader element-type | |
105 :documentation "Default element type for streams created by | |
106 `socket-accept'.")) | |
107 (:documentation "Socket which listens for stream connections to | |
108 be initiated from remote sockets.")) | |
109 | |
110 (defclass datagram-usocket (usocket) | |
111 ((connected-p :type boolean | |
112 :accessor connected-p | |
113 :initarg :connected-p) | |
114 #+(or cmu scl lispworks mcl | |
115 (and clisp ffi (not rawsock))) | |
116 (%open-p :type boolean | |
117 :accessor %open-p | |
118 :initform t | |
119 :documentation "Flag to indicate if usocket is open, | |
120 for GC on implementions operate on raw socket fd.") | |
121 #+(or lispworks mcl | |
122 (and clisp ffi (not rawsock))) | |
123 (recv-buffer :documentation "Private RECV buffer.") | |
124 #+(or lispworks mcl) | |
125 (send-buffer :documentation "Private SEND buffer.")) | |
126 (:documentation "UDP (inet-datagram) socket")) | |
127 | |
128 (defun usocket-p (socket) | |
129 (typep socket 'usocket)) | |
130 | |
131 (defun stream-usocket-p (socket) | |
132 (typep socket 'stream-usocket)) | |
133 | |
134 (defun stream-server-usocket-p (socket) | |
135 (typep socket 'stream-server-usocket)) | |
136 | |
137 (defun datagram-usocket-p (socket) | |
138 (typep socket 'datagram-usocket)) | |
139 | |
140 (defun make-socket (&key socket) | |
141 "Create a usocket socket type from implementation specific socket." | |
142 (unless socket | |
143 (error 'invalid-socket-error)) | |
144 (make-stream-socket :socket socket)) | |
145 | |
146 (defun make-stream-socket (&key socket stream) | |
147 "Create a usocket socket type from implementation specific socket | |
148 and stream objects. | |
149 | |
150 Sockets returned should be closed using the `socket-close' method or | |
151 by closing the stream associated with the socket. | |
152 " | |
153 (unless socket | |
154 (error 'invalid-socket-error)) | |
155 (unless stream | |
156 (error 'invalid-socket-stream-error)) | |
157 (make-instance 'stream-usocket | |
158 :socket socket | |
159 :stream stream)) | |
160 | |
161 (defun make-stream-server-socket (socket &key (element-type | |
162 #-lispworks 'character | |
163 #+lispworks 'base-char)) | |
164 "Create a usocket-server socket type from an | |
165 implementation-specific socket object. | |
166 | |
167 The returned value is a subtype of `stream-server-usocket'. | |
168 " | |
169 (unless socket | |
170 (error 'invalid-socket-error)) | |
171 (make-instance 'stream-server-usocket | |
172 :socket socket | |
173 :element-type element-type)) | |
174 | |
175 (defun make-datagram-socket (socket &key connected-p) | |
176 (unless socket | |
177 (error 'invalid-socket-error)) | |
178 (make-instance 'datagram-usocket | |
179 :socket socket | |
180 :connected-p connected-p)) | |
181 | |
182 (defgeneric socket-accept (socket &key element-type) | |
183 (:documentation | |
184 "Accepts a connection from `socket', returning a `stream-socket'. | |
185 | |
186 The stream associated with the socket returned has `element-type' when | |
187 explicitly specified, or the element-type passed to `socket-listen' othe… | |
188 | |
189 (defgeneric socket-close (usocket) | |
190 (:documentation "Close a previously opened `usocket'.")) | |
191 | |
192 (defmethod socket-close :before ((usocket usocket)) | |
193 (when (wait-list usocket) | |
194 (remove-waiter (wait-list usocket) usocket))) | |
195 | |
196 ;; also see http://stackoverflow.com/questions/4160347/close-vs-shutdown… | |
197 (defgeneric socket-shutdown (usocket direction) | |
198 (:documentation "Shutdown communication on the socket in DIRECTION. | |
199 | |
200 After a shutdown no input and/or output of the indicated DIRECTION | |
201 can be performed on the `usocket'. | |
202 | |
203 DIRECTION should be either :INPUT or :OUTPUT or :IO")) | |
204 | |
205 (defgeneric socket-send (usocket buffer length &key host port) | |
206 (:documentation "Send packets through a previously opend `usocket'.")) | |
207 | |
208 (defgeneric socket-receive (usocket buffer length &key) | |
209 (:documentation "Receive packets from a previously opend `usocket'. | |
210 | |
211 Returns 4 values: (values buffer size host port)")) | |
212 | |
213 (defgeneric get-local-address (socket) | |
214 (:documentation "Returns the IP address of the socket.")) | |
215 | |
216 (defgeneric get-peer-address (socket) | |
217 (:documentation | |
218 "Returns the IP address of the peer the socket is connected to.")) | |
219 | |
220 (defgeneric get-local-port (socket) | |
221 (:documentation "Returns the IP port of the socket. | |
222 | |
223 This function applies to both `stream-usocket' and `server-stream-usocke… | |
224 type objects.")) | |
225 | |
226 (defgeneric get-peer-port (socket) | |
227 (:documentation "Returns the IP port of the peer the socket to.")) | |
228 | |
229 (defgeneric get-local-name (socket) | |
230 (:documentation "Returns the IP address and port of the socket as valu… | |
231 | |
232 This function applies to both `stream-usocket' and `server-stream-usocke… | |
233 type objects.")) | |
234 | |
235 (defgeneric get-peer-name (socket) | |
236 (:documentation | |
237 "Returns the IP address and port of the peer | |
238 the socket is connected to as values.")) | |
239 | |
240 (defmacro with-connected-socket ((var socket) &body body) | |
241 "Bind `socket' to `var', ensuring socket destruction on exit. | |
242 | |
243 `body' is only evaluated when `var' is bound to a non-null value. | |
244 | |
245 The `body' is an implied progn form." | |
246 `(let ((,var ,socket)) | |
247 (unwind-protect | |
248 (when ,var | |
249 (with-mapped-conditions (,var) | |
250 ,@body)) | |
251 (when ,var | |
252 (socket-close ,var))))) | |
253 | |
254 (defmacro with-client-socket ((socket-var stream-var &rest socket-connec… | |
255 &body body) | |
256 "Bind the socket resulting from a call to `socket-connect' with | |
257 the arguments `socket-connect-args' to `socket-var' and if `stream-var' … | |
258 non-nil, bind the associated socket stream to it." | |
259 `(with-connected-socket (,socket-var (socket-connect ,@socket-connect-… | |
260 ,(if (null stream-var) | |
261 `(progn ,@body) | |
262 `(let ((,stream-var (socket-stream ,socket-var))) | |
263 ,@body)))) | |
264 | |
265 (defmacro with-server-socket ((var server-socket) &body body) | |
266 "Bind `server-socket' to `var', ensuring socket destruction on exit. | |
267 | |
268 `body' is only evaluated when `var' is bound to a non-null value. | |
269 | |
270 The `body' is an implied progn form." | |
271 `(with-connected-socket (,var ,server-socket) | |
272 ,@body)) | |
273 | |
274 (defmacro with-socket-listener ((socket-var &rest socket-listen-args) | |
275 &body body) | |
276 "Bind the socket resulting from a call to `socket-listen' with argumen… | |
277 `socket-listen-args' to `socket-var'." | |
278 `(with-server-socket (,socket-var (socket-listen ,@socket-listen-args)) | |
279 ,@body)) | |
280 | |
281 (defstruct (wait-list (:constructor %make-wait-list)) | |
282 %wait ;; implementation specific | |
283 waiters ;; the list of all usockets | |
284 map) ;; maps implementation sockets to usockets | |
285 | |
286 ;; Implementation specific: | |
287 ;; | |
288 ;; %setup-wait-list | |
289 ;; %add-waiter | |
290 ;; %remove-waiter | |
291 | |
292 (defun make-wait-list (waiters) | |
293 (let ((wl (%make-wait-list))) | |
294 (setf (wait-list-map wl) (make-hash-table)) | |
295 (%setup-wait-list wl) | |
296 (dolist (x waiters wl) ; wl is returned | |
297 (add-waiter wl x)))) | |
298 | |
299 (defun add-waiter (wait-list input) | |
300 (setf (gethash (socket input) (wait-list-map wait-list)) input | |
301 (wait-list input) wait-list) | |
302 (pushnew input (wait-list-waiters wait-list)) | |
303 (%add-waiter wait-list input)) | |
304 | |
305 (defun remove-waiter (wait-list input) | |
306 (%remove-waiter wait-list input) | |
307 (setf (wait-list-waiters wait-list) | |
308 (remove input (wait-list-waiters wait-list)) | |
309 (wait-list input) nil) | |
310 (remhash (socket input) (wait-list-map wait-list))) | |
311 | |
312 (defun remove-all-waiters (wait-list) | |
313 (dolist (waiter (wait-list-waiters wait-list)) | |
314 (%remove-waiter wait-list waiter)) | |
315 (setf (wait-list-waiters wait-list) nil) | |
316 (clrhash (wait-list-map wait-list))) | |
317 | |
318 (defun wait-for-input (socket-or-sockets &key timeout ready-only | |
319 &aux (single-socket-p | |
320 (usocket-p socket-or-sock… | |
321 "Waits for one or more streams to become ready for reading from | |
322 the socket. When `timeout' (a non-negative real number) is | |
323 specified, wait `timeout' seconds, or wait indefinitely when | |
324 it isn't specified. A `timeout' value of 0 (zero) means polling. | |
325 | |
326 Returns two values: the first value is the list of streams which | |
327 are readable (or in case of server streams acceptable). NIL may | |
328 be returned for this value either when waiting timed out or when | |
329 it was interrupted (EINTR). The second value is a real number | |
330 indicating the time remaining within the timeout period or NIL if | |
331 none. | |
332 | |
333 Without the READY-ONLY arg, WAIT-FOR-INPUT will return all sockets in | |
334 the original list you passed it. This prevents a new list from being | |
335 consed up. Some users of USOCKET were reluctant to use it if it | |
336 wouldn't behave that way, expecting it to cost significant performance | |
337 to do the associated garbage collection. | |
338 | |
339 Without the READY-ONLY arg, you need to check the socket STATE slot for | |
340 the values documented in usocket.lisp in the usocket class." | |
341 | |
342 ;; for NULL sockets, return NIL with respect of TIMEOUT. | |
343 (when (null socket-or-sockets) | |
344 (when timeout | |
345 (sleep timeout)) | |
346 (return-from wait-for-input nil)) | |
347 | |
348 ;; create a new wait-list if it's not created by the caller. | |
349 (unless (wait-list-p socket-or-sockets) | |
350 ;; OPTIMIZATION: in case socket-or-sockets is an atom, create the wa… | |
351 ;; only once and store it into the usocket itself. | |
352 (let ((wl (if (and single-socket-p | |
353 (wait-list socket-or-sockets)) | |
354 (wait-list socket-or-sockets) ; reuse the per-usocket … | |
355 (make-wait-list (if (listp socket-or-sockets) | |
356 socket-or-sockets (list socket-or-so… | |
357 (multiple-value-bind (sockets to-result) | |
358 (wait-for-input wl :timeout timeout :ready-only ready-only) | |
359 ;; in case of single socket, keep the wait-list | |
360 (unless single-socket-p | |
361 (remove-all-waiters wl)) | |
362 (return-from wait-for-input | |
363 (values (if ready-only sockets socket-or-sockets) to-result)))… | |
364 | |
365 (let* ((start (get-internal-real-time)) | |
366 (sockets-ready 0)) | |
367 (dolist (x (wait-list-waiters socket-or-sockets)) | |
368 (when (setf (state x) | |
369 #+(and win32 (or sbcl ecl)) nil ; they cannot rely on … | |
370 #-(and win32 (or sbcl ecl)) | |
371 (if (and (stream-usocket-p x) | |
372 (listen (socket-stream x))) | |
373 :read | |
374 nil)) | |
375 (incf sockets-ready))) | |
376 ;; the internal routine is responsibe for | |
377 ;; making sure the wait doesn't block on socket-streams of | |
378 ;; which theready- socket isn't ready, but there's space left in the | |
379 ;; buffer. socket-or-sockets is not destructed. | |
380 (wait-for-input-internal socket-or-sockets | |
381 :timeout (if (zerop sockets-ready) timeout … | |
382 (let ((to-result (when timeout | |
383 (let ((elapsed (/ (- (get-internal-real-time) sta… | |
384 internal-time-units-per-second)… | |
385 (when (< elapsed timeout) | |
386 (- timeout elapsed)))))) | |
387 ;; two return values: | |
388 ;; 1) the original wait-list, or available sockets (ready-only) | |
389 ;; 2) remaining timeout | |
390 (values (cond (ready-only | |
391 (cond (single-socket-p | |
392 (if (null (state (car (wait-list-waiters soc… | |
393 nil ; nothing left if the only socket is… | |
394 (wait-list-waiters socket-or-sockets))) | |
395 (t (remove-if #'null (wait-list-waiters socke… | |
396 (t socket-or-sockets)) | |
397 to-result)))) | |
398 | |
399 ;; | |
400 ;; Data utility functions | |
401 ;; | |
402 | |
403 (defun integer-to-octet-buffer (integer buffer octets &key (start 0)) | |
404 (do ((b start (1+ b)) | |
405 (i (ash (1- octets) 3) ;; * 8 | |
406 (- i 8))) | |
407 ((> 0 i) buffer) | |
408 (setf (aref buffer b) | |
409 (ldb (byte 8 i) integer)))) | |
410 | |
411 (defun octet-buffer-to-integer (buffer octets &key (start 0)) | |
412 (let ((integer 0)) | |
413 (do ((b start (1+ b)) | |
414 (i (ash (1- octets) 3) ;; * 8 | |
415 (- i 8))) | |
416 ((> 0 i) | |
417 integer) | |
418 (setf (ldb (byte 8 i) integer) | |
419 (aref buffer b))))) | |
420 | |
421 (defmacro port-to-octet-buffer (port buffer &key (start 0)) | |
422 `(integer-to-octet-buffer ,port ,buffer 2 :start ,start)) | |
423 | |
424 (defmacro ip-to-octet-buffer (ip buffer &key (start 0)) | |
425 `(integer-to-octet-buffer (host-byte-order ,ip) ,buffer 4 :start ,star… | |
426 | |
427 (defmacro port-from-octet-buffer (buffer &key (start 0)) | |
428 `(octet-buffer-to-integer ,buffer 2 :start ,start)) | |
429 | |
430 (defmacro ip-from-octet-buffer (buffer &key (start 0)) | |
431 `(octet-buffer-to-integer ,buffer 4 :start ,start)) | |
432 | |
433 ;; | |
434 ;; IPv4 utility functions | |
435 ;; | |
436 | |
437 (defun list-of-strings-to-integers (list) | |
438 "Take a list of strings and return a new list of integers (from | |
439 parse-integer) on each of the string elements." | |
440 (let ((new-list nil)) | |
441 (dolist (element (reverse list)) | |
442 (push (parse-integer element) new-list)) | |
443 new-list)) | |
444 | |
445 (defun ip-address-string-p (string) | |
446 "Return a true value if the given string could be an IP address." | |
447 (every (lambda (char) | |
448 (or (digit-char-p char) | |
449 (eql char #\.))) | |
450 string)) | |
451 | |
452 (defun hbo-to-dotted-quad (integer) ; exported | |
453 "Host-byte-order integer to dotted-quad string conversion utility." | |
454 (let ((first (ldb (byte 8 24) integer)) | |
455 (second (ldb (byte 8 16) integer)) | |
456 (third (ldb (byte 8 8) integer)) | |
457 (fourth (ldb (byte 8 0) integer))) | |
458 (format nil "~A.~A.~A.~A" first second third fourth))) | |
459 | |
460 (defun hbo-to-vector-quad (integer) ; exported | |
461 "Host-byte-order integer to dotted-quad string conversion utility." | |
462 (let ((first (ldb (byte 8 24) integer)) | |
463 (second (ldb (byte 8 16) integer)) | |
464 (third (ldb (byte 8 8) integer)) | |
465 (fourth (ldb (byte 8 0) integer))) | |
466 (vector first second third fourth))) | |
467 | |
468 (defun vector-quad-to-dotted-quad (vector) ; exported | |
469 (format nil "~A.~A.~A.~A" | |
470 (aref vector 0) | |
471 (aref vector 1) | |
472 (aref vector 2) | |
473 (aref vector 3))) | |
474 | |
475 (defun dotted-quad-to-vector-quad (string) ; exported | |
476 (let ((list (list-of-strings-to-integers (split-sequence #\. string)))) | |
477 (vector (first list) (second list) (third list) (fourth list)))) | |
478 | |
479 (defgeneric host-byte-order (address)) ; exported | |
480 | |
481 (defmethod host-byte-order ((string string)) | |
482 "Convert a string, such as 192.168.1.1, to host-byte-order, | |
483 such as 3232235777." | |
484 (let ((list (list-of-strings-to-integers (split-sequence #\. string)))) | |
485 (+ (* (first list) 256 256 256) (* (second list) 256 256) | |
486 (* (third list) 256) (fourth list)))) | |
487 | |
488 (defmethod host-byte-order ((vector vector)) ; IPv4 only | |
489 "Convert a vector, such as #(192 168 1 1), to host-byte-order, such as | |
490 3232235777." | |
491 (+ (* (aref vector 0) 256 256 256) (* (aref vector 1) 256 256) | |
492 (* (aref vector 2) 256) (aref vector 3))) | |
493 | |
494 (defmethod host-byte-order ((int integer)) | |
495 int) ; this assume input integer is already host-byte-order | |
496 | |
497 ;; | |
498 ;; IPv6 utility functions | |
499 ;; | |
500 | |
501 (defun vector-to-ipv6-host (vector) ; exported | |
502 (with-output-to-string (*standard-output*) | |
503 (loop with zeros-collapsed-p | |
504 with collapsing-zeros-p | |
505 for i below 16 by 2 | |
506 for word = (+ (ash (aref vector i) 8) | |
507 (aref vector (1+ i))) | |
508 do (cond | |
509 ((and (zerop word) | |
510 (not collapsing-zeros-p) | |
511 (not zeros-collapsed-p)) | |
512 (setf collapsing-zeros-p t)) | |
513 ((or (not (zerop word)) | |
514 zeros-collapsed-p) | |
515 (when collapsing-zeros-p | |
516 (write-string ":") | |
517 (setf collapsing-zeros-p nil | |
518 zeros-collapsed-p t)) | |
519 (format t "~:[~;:~]~X" (plusp i) word))) | |
520 finally (when collapsing-zeros-p | |
521 (write-string "::"))))) | |
522 | |
523 (defun split-ipv6-address (string) | |
524 (let ((pos 0) | |
525 word | |
526 double-colon-seen-p | |
527 words-before-double-colon | |
528 words-after-double-colon) | |
529 (loop | |
530 (multiple-value-setq (word pos) (parse-integer string :radix 16 :j… | |
531 (labels ((at-end-p () | |
532 (= pos (length string))) | |
533 (looking-at-colon-p () | |
534 (char= (char string pos) #\:)) | |
535 (ensure-colon () | |
536 (unless (looking-at-colon-p) | |
537 (error "unsyntactic IPv6 address string ~S, expected … | |
538 string pos)) | |
539 (incf pos))) | |
540 (cond | |
541 ((null word) | |
542 (when double-colon-seen-p | |
543 (error "unsyntactic IPv6 address string ~S, can only have o… | |
544 string)) | |
545 (setf double-colon-seen-p t)) | |
546 (double-colon-seen-p | |
547 (push word words-after-double-colon)) | |
548 (t | |
549 (push word words-before-double-colon))) | |
550 (if (at-end-p) | |
551 (return (list (nreverse words-before-double-colon) (nreverse… | |
552 (ensure-colon)))))) | |
553 | |
554 (defun ipv6-host-to-vector (string) ; exported | |
555 (assert (> (length string) 2) () | |
556 "Unsyntactic IPv6 address literal ~S, expected at least three … | |
557 (destructuring-bind (words-before-double-colon words-after-double-colo… | |
558 (split-ipv6-address (concatenate 'string | |
559 (when (eql (char string 0) #\:) | |
560 "0") | |
561 string | |
562 (when (eql (char string (1- (leng… | |
563 "0"))) | |
564 (let ((number-of-words-specified (+ (length words-before-double-colo… | |
565 (assert (<= number-of-words-specified 8) () | |
566 "Unsyntactic IPv6 address literal ~S, too many colon separ… | |
567 (assert (or (= number-of-words-specified 8) words-after-double-col… | |
568 "Unsyntactic IPv6 address literal ~S, too few address comp… | |
569 (loop with vector = (make-array 16 :element-type '(unsigned-byte 8… | |
570 for i below 16 by 2 | |
571 for word in (append words-before-double-colon | |
572 (make-list (- 8 number-of-words-specifie… | |
573 words-after-double-colon) | |
574 do (setf (aref vector i) (ldb (byte 8 8) word) | |
575 (aref vector (1+ i)) (ldb (byte 8 0) word)) | |
576 finally (return vector))))) | |
577 | |
578 ;; exported since 0.8.0 | |
579 (defun host-to-hostname (host) ; host -> string | |
580 "Translate a string, vector quad or 16 byte IPv6 address to a | |
581 stringified hostname." | |
582 (etypecase host | |
583 (string host) ; IPv4 or IPv6 | |
584 ((or (vector t 4) ; IPv4 | |
585 (array (unsigned-byte 8) (4))) | |
586 (vector-quad-to-dotted-quad host)) | |
587 ((or (vector t 16) ; IPv6 | |
588 (array (unsigned-byte 8) (16))) | |
589 (vector-to-ipv6-host host)) | |
590 (integer (hbo-to-dotted-quad host)) ; integer input is IPv4 only | |
591 (null "0.0.0.0"))) ; null is IPv4 | |
592 | |
593 (defun ip= (ip1 ip2) ; exported | |
594 (etypecase ip1 | |
595 (string (string= ip1 ; IPv4 or IPv6 | |
596 (host-to-hostname ip2))) | |
597 ((or (vector t 4) ; IPv4 | |
598 (array (unsigned-byte 8) (4)) ; IPv4 | |
599 (vector t 16) ; IPv6 | |
600 (array (unsigned-byte 8) (16))) ; IPv6 | |
601 (equalp ip1 ip2)) | |
602 (integer (= ip1 ; IPv4 only | |
603 (host-byte-order ip2))))) ; convert ip2 to integer (hbo) | |
604 | |
605 (defun ip/= (ip1 ip2) ; exported | |
606 (not (ip= ip1 ip2))) | |
607 | |
608 ;; | |
609 ;; DNS helper functions | |
610 ;; | |
611 | |
612 (defun get-host-by-name (name) | |
613 "0.7.1+: if there're IPv4 addresses, return the first IPv4 address." | |
614 (let* ((hosts (get-hosts-by-name name)) | |
615 (pos (position-if #'(lambda (ip) (= 4 (length ip))) hosts))) | |
616 (if pos (elt hosts pos) | |
617 (car hosts)))) | |
618 | |
619 (defun get-random-host-by-name (name) | |
620 "0.7.1+: if there're IPv4 addresses, only return a random IPv4 address… | |
621 (let* ((hosts (get-hosts-by-name name)) | |
622 (ipv4-hosts (remove-if-not #'(lambda (ip) (= 4 (length ip))) ho… | |
623 (cond (ipv4-hosts | |
624 (elt ipv4-hosts (random (length ipv4-hosts)))) | |
625 (hosts | |
626 (elt hosts (random (length hosts))))))) | |
627 | |
628 (defun host-to-vector-quad (host) ; internal | |
629 "Translate a host specification (vector quad, dotted quad or domain na… | |
630 to a vector quad." | |
631 (etypecase host | |
632 (string (let* ((ip (when (ip-address-string-p host) | |
633 (dotted-quad-to-vector-quad host)))) | |
634 (if (and ip (= 4 (length ip))) | |
635 ;; valid IP dotted quad? not sure | |
636 ip | |
637 (get-random-host-by-name host)))) | |
638 ((or (vector t 4) | |
639 (array (unsigned-byte 8) (4))) | |
640 host) | |
641 (integer (hbo-to-vector-quad host)))) | |
642 | |
643 (defun host-to-hbo (host) ; internal | |
644 (etypecase host | |
645 (string (let ((ip (when (ip-address-string-p host) | |
646 (dotted-quad-to-vector-quad host)))) | |
647 (if (and ip (= 4 (length ip))) | |
648 (host-byte-order ip) | |
649 (host-to-hbo (get-host-by-name host))))) | |
650 ((or (vector t 4) | |
651 (array (unsigned-byte 8) (4))) | |
652 (host-byte-order host)) | |
653 (integer host))) | |
654 | |
655 ;; | |
656 ;; Other utility functions | |
657 ;; | |
658 | |
659 (defun split-timeout (timeout &optional (fractional 1000000)) | |
660 "Split real value timeout into seconds and microseconds. | |
661 Optionally, a different fractional part can be specified." | |
662 (multiple-value-bind | |
663 (secs sec-frac) | |
664 (truncate timeout 1) | |
665 (values secs | |
666 (truncate (* fractional sec-frac) 1)))) | |
667 | |
668 ;; | |
669 ;; Setting of documentation for backend defined functions | |
670 ;; | |
671 | |
672 ;; Documentation for the function | |
673 ;; | |
674 ;; (defun SOCKET-CONNECT (host port &key element-type nodelay some-other… | |
675 ;; | |
676 (setf (documentation 'socket-connect 'function) | |
677 "Connect to `host' on `port'. `host' is assumed to be a string or | |
678 an IP address represented in vector notation, such as #(192 168 1 1). | |
679 `port' is assumed to be an integer. | |
680 | |
681 `element-type' specifies the element type to use when constructing the | |
682 stream associated with the socket. The default is 'character. | |
683 | |
684 `nodelay' Allows to disable/enable Nagle's algorithm (http://en.wikipedi… | |
685 If this parameter is omitted, the behaviour is inherited from the | |
686 CL implementation (in most cases, Nagle's algorithm is | |
687 enabled by default, but for example in ACL it is disabled). | |
688 If the parameter is specified, one of these three values is possible: | |
689 T - Disable Nagle's algorithm; signals an UNSUPPORTED | |
690 condition if the implementation does not support explicit | |
691 manipulation with that option. | |
692 NIL - Leave Nagle's algorithm enabled on the socket; | |
693 signals an UNSUPPORTED condition if the implementation does | |
694 not support explicit manipulation with that option. | |
695 :IF-SUPPORTED - Disables Nagle's algorithm if the implementation | |
696 allows this, otherwises just ignore this option. | |
697 | |
698 Returns a usocket object.") | |
699 | |
700 ;; Documentation for the function | |
701 ;; | |
702 ;; (defun SOCKET-LISTEN (host port &key reuseaddress backlog element-typ… | |
703 ;;###FIXME: extend with default-element-type | |
704 (setf (documentation 'socket-listen 'function) | |
705 "Bind to interface `host' on `port'. `host' should be the | |
706 representation of an ready-interface address. The implementation is | |
707 not required to do an address lookup, making no guarantees that | |
708 hostnames will be correctly resolved. If `*wildcard-host*' or NIL is | |
709 passed for `host', the socket will be bound to all available | |
710 interfaces for the system. `port' can be selected by the IP stack by | |
711 passing `*auto-port*'. | |
712 | |
713 Returns an object of type `stream-server-usocket'. | |
714 | |
715 `reuse-address' and `backlog' are advisory parameters for setting socket | |
716 options at creation time. `element-type' is the element type of the | |
717 streams to be created by `socket-accept'. `reuseaddress' is supported f… | |
718 backward compatibility (but deprecated); when both `reuseaddress' and | |
719 `reuse-address' have been specified, the latter takes precedence. | |
720 ") | |
721 | |
722 ;;; Small utility functions mapping true/false to 1/0, moved here from o… | |
723 | |
724 (proclaim '(inline bool->int int->bool)) | |
725 | |
726 (defun bool->int (bool) (if bool 1 0)) | |
727 (defun int->bool (int) (= 1 int)) |