/common-lisp/3rd-party/usocket/usocket.lisp
Lisp | 576 lines | 440 code | 96 blank | 40 comment | 21 complexity | 03b4f0138141e2776b4a5d055614a07c MD5 | raw file
1;;;; $Id: usocket.lisp 719 2013-06-17 16:52:12Z ctian $ 2;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/tags/0.6.1/usocket.lisp $ 3 4;;;; See LICENSE for licensing information. 5 6(in-package :usocket) 7 8(defparameter *wildcard-host* #(0 0 0 0) 9 "Hostname to pass when all interfaces in the current system are to be bound.") 10 11(defparameter *auto-port* 0 12 "Port number to pass when an auto-assigned port number is wanted.") 13 14(defconstant +max-datagram-packet-size+ 65507 15 "The theoretical maximum amount of data in a UDP datagram. 16 17The IPv4 UDP packets have a 16-bit length constraint, and IP+UDP header has 28-byte. 18 19IP_MAXPACKET = 65535, /* netinet/ip.h */ 20sizeof(struct ip) = 20, /* netinet/ip.h */ 21sizeof(struct udphdr) = 8, /* netinet/udp.h */ 22 2365535 - 20 - 8 = 65507 24 25(But for UDP broadcast, the maximum message size is limited by the MTU size of the underlying link)") 26 27(defclass usocket () 28 ((socket 29 :initarg :socket 30 :accessor socket 31 :documentation "Implementation specific socket object instance.'") 32 (wait-list 33 :initform nil 34 :accessor wait-list 35 :documentation "WAIT-LIST the object is associated with.") 36 (state 37 :initform nil 38 :accessor state 39 :documentation "Per-socket return value for the `wait-for-input' function. 40 41The value stored in this slot can be any of 42 NIL - not ready 43 :READ - ready to read 44 :READ-WRITE - ready to read and write 45 :WRITE - ready to write 46 47The last two remain unused in the current version. 48") 49 #+(and win32 (or sbcl ecl lispworks)) 50 (%ready-p 51 :initform nil 52 :accessor %ready-p 53 :documentation "Indicates whether the socket has been signalled 54as ready for reading a new connection. 55 56The value will be set to T by `wait-for-input-internal' (given the 57right conditions) and reset to NIL by `socket-accept'. 58 59Don't modify this slot or depend on it as it is really intended 60to be internal only. 61 62Note: Accessed, but not used for 'stream-usocket'. 63" 64 )) 65 (:documentation 66"The main socket class. 67 68Sockets should be closed using the `socket-close' method.")) 69 70(defclass stream-usocket (usocket) 71 ((stream 72 :initarg :stream 73 :accessor socket-stream 74 :documentation "Stream instance associated with the socket." 75;; 76;;Iff an external-format was passed to `socket-connect' or `socket-listen' 77;;the stream is a flexi-stream. Otherwise the stream is implementation 78;;specific." 79)) 80 (:documentation 81"Stream socket class. 82' 83Contrary to other sockets, these sockets may be closed either 84with the `socket-close' method or by closing the associated stream 85(which can be retrieved with the `socket-stream' accessor).")) 86 87(defclass stream-server-usocket (usocket) 88 ((element-type 89 :initarg :element-type 90 :initform #-lispworks 'character 91 #+lispworks 'base-char 92 :reader element-type 93 :documentation "Default element type for streams created by 94`socket-accept'.")) 95 (:documentation "Socket which listens for stream connections to 96be initiated from remote sockets.")) 97 98(defclass datagram-usocket (usocket) 99 ((connected-p :type boolean 100 :accessor connected-p 101 :initarg :connected-p) 102 #+(or cmu scl lispworks mcl 103 (and clisp ffi (not rawsock))) 104 (%open-p :type boolean 105 :accessor %open-p 106 :initform t 107 :documentation "Flag to indicate if usocket is open, 108for GC on implementions operate on raw socket fd.") 109 #+(or lispworks mcl 110 (and clisp ffi (not rawsock))) 111 (recv-buffer :documentation "Private RECV buffer.") 112 #+(or lispworks mcl) 113 (send-buffer :documentation "Private SEND buffer.")) 114 (:documentation "UDP (inet-datagram) socket")) 115 116(defun usocket-p (socket) 117 (typep socket 'usocket)) 118 119(defun stream-usocket-p (socket) 120 (typep socket 'stream-usocket)) 121 122(defun stream-server-usocket-p (socket) 123 (typep socket 'stream-server-usocket)) 124 125(defun datagram-usocket-p (socket) 126 (typep socket 'datagram-usocket)) 127 128(defun make-socket (&key socket) 129 "Create a usocket socket type from implementation specific socket." 130 (unless socket 131 (error 'invalid-socket-error)) 132 (make-stream-socket :socket socket)) 133 134(defun make-stream-socket (&key socket stream) 135 "Create a usocket socket type from implementation specific socket 136and stream objects. 137 138Sockets returned should be closed using the `socket-close' method or 139by closing the stream associated with the socket. 140" 141 (unless socket 142 (error 'invalid-socket-error)) 143 (unless stream 144 (error 'invalid-socket-stream-error)) 145 (make-instance 'stream-usocket 146 :socket socket 147 :stream stream)) 148 149(defun make-stream-server-socket (socket &key (element-type 150 #-lispworks 'character 151 #+lispworks 'base-char)) 152 "Create a usocket-server socket type from an 153implementation-specific socket object. 154 155The returned value is a subtype of `stream-server-usocket'. 156" 157 (unless socket 158 (error 'invalid-socket-error)) 159 (make-instance 'stream-server-usocket 160 :socket socket 161 :element-type element-type)) 162 163(defun make-datagram-socket (socket &key connected-p) 164 (unless socket 165 (error 'invalid-socket-error)) 166 (make-instance 'datagram-usocket 167 :socket socket 168 :connected-p connected-p)) 169 170(defgeneric socket-accept (socket &key element-type) 171 (:documentation 172 "Accepts a connection from `socket', returning a `stream-socket'. 173 174The stream associated with the socket returned has `element-type' when 175explicitly specified, or the element-type passed to `socket-listen' otherwise.")) 176 177(defgeneric socket-close (usocket) 178 (:documentation "Close a previously opened `usocket'.")) 179 180(defgeneric socket-send (usocket buffer length &key host port) 181 (:documentation "Send packets through a previously opend `usocket'.")) 182 183(defgeneric socket-receive (usocket buffer length &key) 184 (:documentation "Receive packets from a previously opend `usocket'. 185 186Returns 4 values: (values buffer size host port)")) 187 188(defgeneric get-local-address (socket) 189 (:documentation "Returns the IP address of the socket.")) 190 191(defgeneric get-peer-address (socket) 192 (:documentation 193 "Returns the IP address of the peer the socket is connected to.")) 194 195(defgeneric get-local-port (socket) 196 (:documentation "Returns the IP port of the socket. 197 198This function applies to both `stream-usocket' and `server-stream-usocket' 199type objects.")) 200 201(defgeneric get-peer-port (socket) 202 (:documentation "Returns the IP port of the peer the socket to.")) 203 204(defgeneric get-local-name (socket) 205 (:documentation "Returns the IP address and port of the socket as values. 206 207This function applies to both `stream-usocket' and `server-stream-usocket' 208type objects.")) 209 210(defgeneric get-peer-name (socket) 211 (:documentation 212 "Returns the IP address and port of the peer 213the socket is connected to as values.")) 214 215(defmacro with-connected-socket ((var socket) &body body) 216 "Bind `socket' to `var', ensuring socket destruction on exit. 217 218`body' is only evaluated when `var' is bound to a non-null value. 219 220The `body' is an implied progn form." 221 `(let ((,var ,socket)) 222 (unwind-protect 223 (when ,var 224 (with-mapped-conditions (,var) 225 ,@body)) 226 (when ,var 227 (socket-close ,var))))) 228 229(defmacro with-client-socket ((socket-var stream-var &rest socket-connect-args) 230 &body body) 231 "Bind the socket resulting from a call to `socket-connect' with 232the arguments `socket-connect-args' to `socket-var' and if `stream-var' is 233non-nil, bind the associated socket stream to it." 234 `(with-connected-socket (,socket-var (socket-connect ,@socket-connect-args)) 235 ,(if (null stream-var) 236 `(progn ,@body) 237 `(let ((,stream-var (socket-stream ,socket-var))) 238 ,@body)))) 239 240(defmacro with-server-socket ((var server-socket) &body body) 241 "Bind `server-socket' to `var', ensuring socket destruction on exit. 242 243`body' is only evaluated when `var' is bound to a non-null value. 244 245The `body' is an implied progn form." 246 `(with-connected-socket (,var ,server-socket) 247 ,@body)) 248 249(defmacro with-socket-listener ((socket-var &rest socket-listen-args) 250 &body body) 251 "Bind the socket resulting from a call to `socket-listen' with arguments 252`socket-listen-args' to `socket-var'." 253 `(with-server-socket (,socket-var (socket-listen ,@socket-listen-args)) 254 ,@body)) 255 256(defstruct (wait-list (:constructor %make-wait-list)) 257 %wait ;; implementation specific 258 waiters ;; the list of all usockets 259 map) ;; maps implementation sockets to usockets 260 261;; Implementation specific: 262;; 263;; %setup-wait-list 264;; %add-waiter 265;; %remove-waiter 266 267(defun make-wait-list (waiters) 268 (let ((wl (%make-wait-list))) 269 (setf (wait-list-map wl) (make-hash-table)) 270 (%setup-wait-list wl) 271 (dolist (x waiters wl) 272 (add-waiter wl x)))) 273 274(defun add-waiter (wait-list input) 275 (setf (gethash (socket input) (wait-list-map wait-list)) input 276 (wait-list input) wait-list) 277 (pushnew input (wait-list-waiters wait-list)) 278 (%add-waiter wait-list input)) 279 280(defun remove-waiter (wait-list input) 281 (%remove-waiter wait-list input) 282 (setf (wait-list-waiters wait-list) 283 (remove input (wait-list-waiters wait-list)) 284 (wait-list input) nil) 285 (remhash (socket input) (wait-list-map wait-list))) 286 287(defun remove-all-waiters (wait-list) 288 (dolist (waiter (wait-list-waiters wait-list)) 289 (%remove-waiter wait-list waiter)) 290 (setf (wait-list-waiters wait-list) nil) 291 (clrhash (wait-list-map wait-list))) 292 293(defun wait-for-input (socket-or-sockets &key timeout ready-only) 294 "Waits for one or more streams to become ready for reading from 295the socket. When `timeout' (a non-negative real number) is 296specified, wait `timeout' seconds, or wait indefinitely when 297it isn't specified. A `timeout' value of 0 (zero) means polling. 298 299Returns two values: the first value is the list of streams which 300are readable (or in case of server streams acceptable). NIL may 301be returned for this value either when waiting timed out or when 302it was interrupted (EINTR). The second value is a real number 303indicating the time remaining within the timeout period or NIL if 304none. 305 306Without the READY-ONLY arg, WAIT-FOR-INPUT will return all sockets in 307the original list you passed it. This prevents a new list from being 308consed up. Some users of USOCKET were reluctant to use it if it 309wouldn't behave that way, expecting it to cost significant performance 310to do the associated garbage collection. 311 312Without the READY-ONLY arg, you need to check the socket STATE slot for 313the values documented in usocket.lisp in the usocket class." 314 (unless (wait-list-p socket-or-sockets) 315 (let ((wl (make-wait-list (if (listp socket-or-sockets) 316 socket-or-sockets (list socket-or-sockets))))) 317 (multiple-value-bind 318 (socks to) 319 (wait-for-input wl :timeout timeout :ready-only ready-only) 320 (return-from wait-for-input 321 (values (if ready-only socks socket-or-sockets) to))))) 322 (let* ((start (get-internal-real-time)) 323 (sockets-ready 0)) 324 (dolist (x (wait-list-waiters socket-or-sockets)) 325 (when (setf (state x) 326 #+(and win32 (or sbcl ecl)) nil ; they cannot rely on LISTEN 327 #-(and win32 (or sbcl ecl)) 328 (if (and (stream-usocket-p x) 329 (listen (socket-stream x))) 330 :read 331 nil)) 332 (incf sockets-ready))) 333 ;; the internal routine is responsibe for 334 ;; making sure the wait doesn't block on socket-streams of 335 ;; which theready- socket isn't ready, but there's space left in the 336 ;; buffer 337 (wait-for-input-internal socket-or-sockets 338 :timeout (if (zerop sockets-ready) timeout 0)) 339 (let ((to-result (when timeout 340 (let ((elapsed (/ (- (get-internal-real-time) start) 341 internal-time-units-per-second))) 342 (when (< elapsed timeout) 343 (- timeout elapsed)))))) 344 (values (if ready-only 345 (remove-if #'null (wait-list-waiters socket-or-sockets) :key #'state) 346 socket-or-sockets) 347 to-result)))) 348 349;; 350;; Data utility functions 351;; 352 353(defun integer-to-octet-buffer (integer buffer octets &key (start 0)) 354 (do ((b start (1+ b)) 355 (i (ash (1- octets) 3) ;; * 8 356 (- i 8))) 357 ((> 0 i) buffer) 358 (setf (aref buffer b) 359 (ldb (byte 8 i) integer)))) 360 361(defun octet-buffer-to-integer (buffer octets &key (start 0)) 362 (let ((integer 0)) 363 (do ((b start (1+ b)) 364 (i (ash (1- octets) 3) ;; * 8 365 (- i 8))) 366 ((> 0 i) 367 integer) 368 (setf (ldb (byte 8 i) integer) 369 (aref buffer b))))) 370 371(defmacro port-to-octet-buffer (port buffer &key (start 0)) 372 `(integer-to-octet-buffer ,port ,buffer 2 :start ,start)) 373 374(defmacro ip-to-octet-buffer (ip buffer &key (start 0)) 375 `(integer-to-octet-buffer (host-byte-order ,ip) ,buffer 4 :start ,start)) 376 377(defmacro port-from-octet-buffer (buffer &key (start 0)) 378 `(octet-buffer-to-integer ,buffer 2 :start ,start)) 379 380(defmacro ip-from-octet-buffer (buffer &key (start 0)) 381 `(octet-buffer-to-integer ,buffer 4 :start ,start)) 382 383;; 384;; IP(v4) utility functions 385;; 386 387(defun list-of-strings-to-integers (list) 388 "Take a list of strings and return a new list of integers (from 389parse-integer) on each of the string elements." 390 (let ((new-list nil)) 391 (dolist (element (reverse list)) 392 (push (parse-integer element) new-list)) 393 new-list)) 394 395(defun ip-address-string-p (string) 396 "Return a true value if the given string could be an IP address." 397 (every (lambda (char) 398 (or (digit-char-p char) 399 (eql char #\.))) 400 string)) 401 402(defun hbo-to-dotted-quad (integer) 403 "Host-byte-order integer to dotted-quad string conversion utility." 404 (let ((first (ldb (byte 8 24) integer)) 405 (second (ldb (byte 8 16) integer)) 406 (third (ldb (byte 8 8) integer)) 407 (fourth (ldb (byte 8 0) integer))) 408 (format nil "~A.~A.~A.~A" first second third fourth))) 409 410(defun hbo-to-vector-quad (integer) 411 "Host-byte-order integer to dotted-quad string conversion utility." 412 (let ((first (ldb (byte 8 24) integer)) 413 (second (ldb (byte 8 16) integer)) 414 (third (ldb (byte 8 8) integer)) 415 (fourth (ldb (byte 8 0) integer))) 416 (vector first second third fourth))) 417 418(defun vector-quad-to-dotted-quad (vector) 419 (format nil "~A.~A.~A.~A" 420 (aref vector 0) 421 (aref vector 1) 422 (aref vector 2) 423 (aref vector 3))) 424 425(defun dotted-quad-to-vector-quad (string) 426 (let ((list (list-of-strings-to-integers (split-sequence #\. string)))) 427 (vector (first list) (second list) (third list) (fourth list)))) 428 429(defgeneric host-byte-order (address)) 430(defmethod host-byte-order ((string string)) 431 "Convert a string, such as 192.168.1.1, to host-byte-order, 432such as 3232235777." 433 (let ((list (list-of-strings-to-integers (split-sequence #\. string)))) 434 (+ (* (first list) 256 256 256) (* (second list) 256 256) 435 (* (third list) 256) (fourth list)))) 436 437(defmethod host-byte-order ((vector vector)) 438 "Convert a vector, such as #(192 168 1 1), to host-byte-order, such as 4393232235777." 440 (+ (* (aref vector 0) 256 256 256) (* (aref vector 1) 256 256) 441 (* (aref vector 2) 256) (aref vector 3))) 442 443(defmethod host-byte-order ((int integer)) 444 int) 445 446(defun host-to-hostname (host) 447 "Translate a string or vector quad to a stringified hostname." 448 (etypecase host 449 (string host) 450 ((or (vector t 4) 451 (array (unsigned-byte 8) (4))) 452 (vector-quad-to-dotted-quad host)) 453 (integer (hbo-to-dotted-quad host)) 454 (null "0.0.0.0"))) 455 456(defun ip= (ip1 ip2) 457 (etypecase ip1 458 (string (string= ip1 (host-to-hostname ip2))) 459 ((or (vector t 4) 460 (array (unsigned-byte 8) (4))) 461 (or (eq ip1 ip2) 462 (and (= (aref ip1 0) (aref ip2 0)) 463 (= (aref ip1 1) (aref ip2 1)) 464 (= (aref ip1 2) (aref ip2 2)) 465 (= (aref ip1 3) (aref ip2 3))))) 466 (integer (= ip1 (host-byte-order ip2))))) 467 468(defun ip/= (ip1 ip2) 469 (not (ip= ip1 ip2))) 470 471;; 472;; DNS helper functions 473;; 474 475(defun get-host-by-name (name) 476 (let ((hosts (get-hosts-by-name name))) 477 (car hosts))) 478 479(defun get-random-host-by-name (name) 480 (let ((hosts (get-hosts-by-name name))) 481 (when hosts 482 (elt hosts (random (length hosts)))))) 483 484(defun host-to-vector-quad (host) 485 "Translate a host specification (vector quad, dotted quad or domain name) 486to a vector quad." 487 (etypecase host 488 (string (let* ((ip (when (ip-address-string-p host) 489 (dotted-quad-to-vector-quad host)))) 490 (if (and ip (= 4 (length ip))) 491 ;; valid IP dotted quad? 492 ip 493 (get-random-host-by-name host)))) 494 ((or (vector t 4) 495 (array (unsigned-byte 8) (4))) 496 host) 497 (integer (hbo-to-vector-quad host)))) 498 499(defun host-to-hbo (host) 500 (etypecase host 501 (string (let ((ip (when (ip-address-string-p host) 502 (dotted-quad-to-vector-quad host)))) 503 (if (and ip (= 4 (length ip))) 504 (host-byte-order ip) 505 (host-to-hbo (get-host-by-name host))))) 506 ((or (vector t 4) 507 (array (unsigned-byte 8) (4))) 508 (host-byte-order host)) 509 (integer host))) 510 511;; 512;; Other utility functions 513;; 514 515(defun split-timeout (timeout &optional (fractional 1000000)) 516 "Split real value timeout into seconds and microseconds. 517Optionally, a different fractional part can be specified." 518 (multiple-value-bind 519 (secs sec-frac) 520 (truncate timeout 1) 521 (values secs 522 (truncate (* fractional sec-frac) 1)))) 523 524;; 525;; Setting of documentation for backend defined functions 526;; 527 528;; Documentation for the function 529;; 530;; (defun SOCKET-CONNECT (host port &key element-type nodelay some-other-keys...) ..) 531;; 532(setf (documentation 'socket-connect 'function) 533 "Connect to `host' on `port'. `host' is assumed to be a string or 534an IP address represented in vector notation, such as #(192 168 1 1). 535`port' is assumed to be an integer. 536 537`element-type' specifies the element type to use when constructing the 538stream associated with the socket. The default is 'character. 539 540`nodelay' Allows to disable/enable Nagle's algorithm (http://en.wikipedia.org/wiki/Nagle%27s_algorithm). 541If this parameter is omitted, the behaviour is inherited from the 542CL implementation (in most cases, Nagle's algorithm is 543enabled by default, but for example in ACL it is disabled). 544If the parmeter is specified, one of these three values is possible: 545 T - Disable Nagle's algorithm; signals an UNSUPPORTED 546 condition if the implementation does not support explicit 547 manipulation with that option. 548 NIL - Leave Nagle's algorithm enabled on the socket; 549 signals an UNSUPPORTED condition if the implementation does 550 not support explicit manipulation with that option. 551 :IF-SUPPORTED - Disables Nagle's algorithm if the implementation 552 allows this, otherwises just ignore this option. 553 554Returns a usocket object.") 555 556;; Documentation for the function 557;; 558;; (defun SOCKET-LISTEN (host port &key reuseaddress backlog element-type) ..) 559;;###FIXME: extend with default-element-type 560(setf (documentation 'socket-listen 'function) 561 "Bind to interface `host' on `port'. `host' should be the 562representation of an ready-interface address. The implementation is not 563required to do an address lookup, making no guarantees that hostnames 564will be correctly resolved. If `*wildcard-host*' is passed for `host', 565the socket will be bound to all available interfaces for the IPv4 566protocol in the system. `port' can be selected by the IP stack by 567passing `*auto-port*'. 568 569Returns an object of type `stream-server-usocket'. 570 571`reuse-address' and `backlog' are advisory parameters for setting socket 572options at creation time. `element-type' is the element type of the 573streams to be created by `socket-accept'. `reuseaddress' is supported for 574backward compatibility (but deprecated); when both `reuseaddress' and 575`reuse-address' have been specified, the latter takes precedence. 576")