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

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