/common-lisp/3rd-party/usocket/usocket.lisp

  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")