PageRenderTime 55ms CodeModel.GetById 27ms RepoModel.GetById 1ms app.codeStats 0ms

/asdf-systems/acl-compat/sbcl/acl-socket.lisp

https://bitbucket.org/mt/biobike
Lisp | 283 lines | 240 code | 33 blank | 10 comment | 11 complexity | 13cfa9016783ad792701ab3cd2d9bee0 MD5 | raw file
Possible License(s): LGPL-2.1, BSD-3-Clause
  1. ;; This package is designed for sbcl. It implements the
  2. ;; ACL-style socket interface on top of sbcl.
  3. ;;
  4. ;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt
  5. ;; for Lispworks and net.lisp in the port library of CLOCC.
  6. (in-package #:acl-compat.socket)
  7. (defclass server-socket ()
  8. ((socket :initarg :socket :reader socket
  9. :initform (error "No value supplied for socket"))
  10. (element-type :type (member signed-byte unsigned-byte base-char)
  11. :initarg :element-type
  12. :reader element-type
  13. :initform (error "No value supplied for element-type"))
  14. (port :type fixnum
  15. :initarg :port
  16. :reader port
  17. :initform (error "No value supplied for port"))
  18. (stream-type :type (member :text :binary :bivalent)
  19. :initarg :stream-type
  20. :reader stream-type
  21. :initform (error "No value supplied for stream-type"))))
  22. (defclass datagram-socket (server-socket)
  23. ())
  24. (defmethod print-object ((socket server-socket) stream)
  25. (print-unreadable-object (socket stream :type t :identity nil)
  26. (format stream "listening on port ~d" (port socket))))
  27. (defmethod print-object ((socket datagram-socket) stream)
  28. (print-unreadable-object (socket stream :type t :identity nil)
  29. (format stream "datagram socket listening on port ~d" (port socket))))
  30. (defgeneric accept-connection (socket &key wait))
  31. (defmethod accept-connection ((server-socket server-socket)
  32. &key (wait t))
  33. "Return a bidirectional stream connected to socket."
  34. (if (sb-sys:wait-until-fd-usable (socket-file-descriptor (socket server-socket))
  35. :input (if (numberp wait) wait nil))
  36. (let* ((socket (socket-accept (socket server-socket)))
  37. (stream (socket-make-stream socket
  38. :input t :output t
  39. ; :buffering :none
  40. :element-type
  41. (element-type server-socket)
  42. :auto-close t)))
  43. (if (eq (stream-type server-socket) :bivalent)
  44. ;; HACK: remember socket, so we can do peer lookup
  45. (make-bivalent-stream stream :plist `(:socket ,socket))
  46. stream))
  47. nil))
  48. (defmethod receive-from ((socket datagram-socket) size &key buffer extract)
  49. (multiple-value-bind (rbuf len address port)
  50. (socket-receive (socket socket) buffer size)
  51. (declare (ignore port))
  52. (let ((buf
  53. (if (not extract)
  54. rbuf
  55. (subseq rbuf 0 len)))) ;; FIXME: am I right?
  56. (when buffer
  57. (replace buffer buf :end2 len))
  58. (values
  59. (if buffer buffer buf)
  60. len
  61. address))))
  62. (defmethod send-to ((socket datagram-socket) buffer size &key remote-host remote-port)
  63. (let* ((rhost (typecase remote-host
  64. (string (lookup-hostname remote-host))
  65. (otherwise remote-host)))
  66. (s (socket socket))
  67. (stream (progn
  68. (socket-connect s rhost remote-port)
  69. (socket-make-stream s :input t :output t :buffering :none))))
  70. (write-sequence buffer stream)
  71. size))
  72. (defun make-socket (&key
  73. (type :stream)
  74. (remote-host "localhost")
  75. local-port
  76. remote-port
  77. (connect :active)
  78. (format :text)
  79. (reuse-address t)
  80. &allow-other-keys)
  81. "Return a stream connected to remote-host if connect is :active, or
  82. something listening on local-port that can be fed to accept-connection
  83. if connect is :passive.
  84. This is an incomplete implementation of ACL's make-socket function!
  85. It was written to provide the functionality necessary to port
  86. AllegroServe. Refer to
  87. http://franz.com/support/documentation/6.1/doc/pages/operators/socket/make-socket.htm
  88. to read about the missing parts."
  89. (check-type remote-host string)
  90. (let ((element-type (ecase format
  91. (:text 'base-char)
  92. (:binary 'signed-byte)
  93. (:bivalent 'unsigned-byte)))
  94. (socket
  95. (if (eq type :datagram)
  96. (progn
  97. (setf connect :passive-udp)
  98. (make-instance 'inet-socket :type :datagram :protocol :udp))
  99. (make-instance 'inet-socket :type :stream :protocol :tcp))))
  100. (ecase connect
  101. (:passive-udp
  102. (setf (sockopt-reuse-address socket) reuse-address)
  103. (if local-port
  104. (socket-bind socket #(0 0 0 0) local-port))
  105. (make-instance 'datagram-socket
  106. :port (nth-value 1 (socket-name socket))
  107. :socket socket
  108. :element-type element-type
  109. :stream-type format))
  110. (:passive
  111. (setf (sockopt-reuse-address socket) reuse-address)
  112. (if local-port
  113. (socket-bind socket #(0 0 0 0) local-port))
  114. (socket-listen socket 10) ;Arbitrarily chosen backlog value
  115. (make-instance 'server-socket
  116. :port (nth-value 1 (socket-name socket))
  117. :socket socket
  118. :element-type element-type
  119. :stream-type format))
  120. (:active
  121. (socket-connect socket (lookup-hostname remote-host) remote-port)
  122. (let ((stream (socket-make-stream socket :input t :output t
  123. :element-type element-type
  124. ; :buffering :none
  125. )))
  126. (if (eq :bivalent format)
  127. ;; HACK: remember socket, so we can do peer lookup
  128. (make-bivalent-stream stream :plist `(:socket ,socket))
  129. stream))))))
  130. (defmethod close ((server server-socket) &key abort)
  131. "Kill a passive (listening) socket. (Active sockets are actually
  132. streams and handled by their close methods."
  133. (declare (ignore abort))
  134. (socket-close (socket server)))
  135. #+ignore
  136. (declaim (ftype (function ((unsigned-byte 32) &key (:values t))
  137. (or (values fixnum fixnum fixnum fixnum)
  138. (values simple-string)))
  139. ipaddr-to-dotted))
  140. (defun ipaddr-to-dotted (ipaddr &key values)
  141. "Convert from 32-bit integer to dotted string."
  142. (declare (type (unsigned-byte 32) ipaddr))
  143. (let ((a (logand #xff (ash ipaddr -24)))
  144. (b (logand #xff (ash ipaddr -16)))
  145. (c (logand #xff (ash ipaddr -8)))
  146. (d (logand #xff ipaddr)))
  147. (if values
  148. (values a b c d)
  149. (format nil "~d.~d.~d.~d" a b c d))))
  150. (defun ipaddr-to-vector (ipaddr)
  151. "Convert from 32-bit integer to a vector of octets."
  152. (declare (type (unsigned-byte 32) ipaddr))
  153. (let ((a (logand #xff (ash ipaddr -24)))
  154. (b (logand #xff (ash ipaddr -16)))
  155. (c (logand #xff (ash ipaddr -8)))
  156. (d (logand #xff ipaddr)))
  157. (make-array 4 :initial-contents (list a b c d))))
  158. (declaim (ftype (function (vector)
  159. (values (unsigned-byte 32)))
  160. vector-to-ipaddr))
  161. (defun vector-to-ipaddr (sensible-ipaddr)
  162. "Convert from 4-integer vector to 32-bit integer."
  163. (loop with result = 0
  164. for component across sensible-ipaddr
  165. do (setf result (+ (ash result 8) component))
  166. finally (return result)))
  167. (defun string-tokens (string)
  168. (labels ((get-token (str pos1 acc)
  169. (let ((pos2 (position #\Space str :start pos1)))
  170. (if (not pos2)
  171. (nreverse acc)
  172. (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2))
  173. acc))))))
  174. (get-token (concatenate 'string string " ") 0 nil)))
  175. (declaim (ftype (function (string &key (:errorp t))
  176. (or null (unsigned-byte 32)))
  177. dotted-to-ipaddr))
  178. (defun dotted-to-ipaddr (dotted &key (errorp t))
  179. "Convert from dotted string to 32-bit integer."
  180. (declare (string dotted))
  181. (if errorp
  182. (let ((ll (string-tokens (substitute #\Space #\. dotted))))
  183. (+ (ash (first ll) 24) (ash (second ll) 16)
  184. (ash (third ll) 8) (fourth ll)))
  185. (ignore-errors
  186. (let ((ll (string-tokens (substitute #\Space #\. dotted))))
  187. (+ (ash (first ll) 24) (ash (second ll) 16)
  188. (ash (third ll) 8) (fourth ll))))))
  189. (defun ipaddr-to-hostname (ipaddr &key ignore-cache)
  190. (when ignore-cache
  191. (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported."))
  192. (host-ent-name (get-host-by-address (ipaddr-to-vector ipaddr))))
  193. (defun lookup-hostname (host &key ignore-cache)
  194. (when ignore-cache
  195. (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
  196. (if (stringp host)
  197. (host-ent-address (get-host-by-name host))
  198. (dotted-to-ipaddr (ipaddr-to-dotted host))))
  199. (defun remote-host (socket-stream)
  200. (let (socket)
  201. (if (and (typep socket-stream 'chunked-stream)
  202. (setf socket (getf (stream-plist socket-stream) :socket)))
  203. (vector-to-ipaddr (socket-peername socket))
  204. (progn (warn "Could not get remote host for ~S" socket-stream)
  205. 0))))
  206. (defun remote-port (socket-stream)
  207. (let (socket)
  208. (if (and (typep socket-stream 'chunked-stream)
  209. (setq socket (getf (stream-plist socket-stream) :socket)))
  210. (nth-value 1 (socket-peername socket))
  211. (progn (warn "Could not get remote port for ~S" socket-stream)
  212. 0))))
  213. (defun local-host (thing)
  214. (typecase thing
  215. (chunked-stream (let ((socket (getf (stream-plist thing) :socket)))
  216. (if socket (vector-to-ipaddr (socket-name socket))
  217. (progn (warn "Socket not in plist of ~S -- could not get local host" thing)
  218. 0))))
  219. (server-socket (vector-to-ipaddr #(127 0 0 1)))
  220. (t (progn (warn "Could not get local host for ~S" thing)
  221. 0))))
  222. (defun local-port (thing)
  223. (typecase thing
  224. (chunked-stream (let ((socket (getf (stream-plist thing) :socket)))
  225. (if socket (nth-value 1 (socket-name socket))
  226. (progn (warn "Socket not in plist of ~S -- could not get local port" thing)
  227. 0))))
  228. (server-socket (port thing))
  229. (t (progn (warn "Could not get local port for ~S" thing)
  230. 0))))
  231. ;; Now, throw chunking in the mix
  232. (defclass chunked-stream (de.dataheaven.chunked-stream-mixin::chunked-stream-mixin
  233. gray-stream::buffered-bivalent-stream)
  234. ((plist :initarg :plist :accessor stream-plist)))
  235. (defun make-bivalent-stream (lisp-stream &key plist)
  236. (make-instance 'chunked-stream :lisp-stream lisp-stream :plist plist))
  237. (defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p))
  238. (when oc-p
  239. (when output-chunking
  240. (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream))
  241. (setf (de.dataheaven.chunked-stream-mixin::output-chunking-p stream)
  242. output-chunking))
  243. (when output-chunking-eof
  244. (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream))
  245. (when ic-p
  246. (when input-chunking
  247. (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream))
  248. (setf (de.dataheaven.chunked-stream-mixin::input-chunking-p stream)
  249. input-chunking)))
  250. (provide 'acl-socket)