PageRenderTime 45ms CodeModel.GetById 22ms RepoModel.GetById 0ms app.codeStats 1ms

/src/socket.lisp

https://github.com/galdor/llio
Lisp | 253 lines | 203 code | 50 blank | 0 comment | 3 complexity | 7d8913128e3b877354e367386acb8551 MD5 | raw file
Possible License(s): 0BSD
  1. (in-package :llio)
  2. (defcfun ("socket" %socket) :int
  3. (family address-family)
  4. (type socket-type)
  5. (protocol :int))
  6. (defcfun ("close" %close) :int
  7. (fd :int))
  8. (defcfun ("shutdown" %shutdown) :int
  9. (socket :int)
  10. (how shutdown-mode))
  11. (defcfun ("bind" %bind) :int
  12. (socket :int)
  13. (addr :pointer)
  14. (addrlen socklen-t))
  15. (defcfun ("listen" %listen) :int
  16. (socket :int)
  17. (backlog :int))
  18. (defcfun ("accept" %accept) :int
  19. (socket :int)
  20. (addr :pointer)
  21. (addrlen (:pointer socklen-t)))
  22. (defcfun ("connect" %connect) :int
  23. (socket :int)
  24. (addr :pointer)
  25. (addrlen socklen-t))
  26. (defcfun ("getsockname" %getsockname) :int
  27. (socket :int)
  28. (addr :pointer)
  29. (addrlen (:pointer socklen-t)))
  30. (defcfun ("getpeername" %getpeername) :int
  31. (socket :int)
  32. (addr :pointer)
  33. (addrlen (:pointer socklen-t)))
  34. (defcfun ("setsockopt" %setsockopt) :int
  35. (socket :int)
  36. (level :int)
  37. (option :int)
  38. (value :pointer)
  39. (valuelen socklen-t))
  40. (defcfun ("getsockopt" %getsockopt) :int
  41. (socket :int)
  42. (level :int)
  43. (option :int)
  44. (value :pointer)
  45. (valuelen (:pointer socklen-t)))
  46. (defcfun ("fcntl" %fcntl) :int
  47. (fd :int)
  48. (cmd fcntl-command)
  49. &rest)
  50. (defcfun ("read" %read) ssize-t
  51. (fd :int)
  52. (buf :pointer)
  53. (count size-t))
  54. (defcfun ("write" %write) ssize-t
  55. (fd :int)
  56. (buf :pointer)
  57. (count size-t))
  58. (defclass socket ()
  59. ((fd
  60. :accessor socket-fd
  61. :initarg :fd
  62. :initform -1
  63. :documentation "The file descriptor of the socket.")))
  64. (defmethod print-object ((socket socket) stream)
  65. (print-unreadable-object (socket stream :type t :identity t)
  66. (princ (socket-fd socket) stream)))
  67. (defun make-socket (family type &key (protocol 0))
  68. "Create a new socket."
  69. (let ((fd (check-return-code (%socket family type protocol))))
  70. (make-instance 'socket :fd fd)))
  71. (defun socket-close (socket)
  72. "Close a socket."
  73. (check-return-code (%close (socket-fd socket))))
  74. (defun socket-shutdown (socket mode)
  75. "Shutdown the connection associated to a socket."
  76. (check-return-code (%shutdown (socket-fd socket) mode)))
  77. (defmacro with-socket ((socket family type &rest args) &body body)
  78. `(let ((,socket (make-socket ,family ,type ,@args)))
  79. (unwind-protect
  80. (progn
  81. ,@body)
  82. (socket-close ,socket))))
  83. (defun socket-bind (socket addrinfo)
  84. "Bind a socket to an address."
  85. (check-return-code (%bind (socket-fd socket)
  86. (addrinfo-addr addrinfo)
  87. (addrinfo-addrlen addrinfo))))
  88. (defun socket-listen (socket backlog)
  89. "Listen for socket connections."
  90. (check-return-code (%listen (socket-fd socket) backlog)))
  91. (defun socket-accept (socket)
  92. "Accept a connection on a socket.."
  93. (let ((fd (check-return-code (%accept (socket-fd socket)
  94. (null-pointer)
  95. (null-pointer)))))
  96. (make-instance 'socket :fd fd)))
  97. (defun socket-connect (socket addrinfo)
  98. "Connect a socket to an address."
  99. (check-return-code (%connect (socket-fd socket)
  100. (addrinfo-addr addrinfo)
  101. (addrinfo-addrlen addrinfo))))
  102. (defun getsockname (socket)
  103. "Get the host and port of SOCKET."
  104. (with-foreign-objects ((addr 'sockaddr-storage)
  105. (addrlen 'socklen-t))
  106. (check-return-code (%getsockname (socket-fd socket) addr addrlen))
  107. (multiple-value-bind (host service)
  108. (getnameinfo addr (mem-ref addrlen 'socklen-t)
  109. :flags '(:ni-numerichost :ni-numericserv))
  110. (values host service))))
  111. (defun getpeername (socket)
  112. "Get the host and port of the peer SOCKET is connected to."
  113. (with-foreign-objects ((addr 'sockaddr-storage)
  114. (addrlen 'socklen-t))
  115. (check-return-code (%getpeername (socket-fd socket) addr addrlen))
  116. (multiple-value-bind (host service)
  117. (getnameinfo addr (mem-ref addrlen 'socklen-t)
  118. :flags '(:ni-numerichost :ni-numericserv))
  119. (values host service))))
  120. (defun socket-set-option (socket option type value)
  121. (check-return-code (%setsockopt (socket-fd socket) sol-socket
  122. (foreign-enum-value 'socket-option option)
  123. value (foreign-type-size type))))
  124. (defun socket-set-bool-option (socket option enable)
  125. (with-foreign-object (%value :int)
  126. (setf (mem-ref %value :int) (if enable 1 0))
  127. (socket-set-option socket option :int %value)))
  128. (defun socket-set-int-option (socket option value)
  129. (with-foreign-object (%value :int)
  130. (setf (mem-ref %value :int) value)
  131. (socket-set-option socket option :int %value)))
  132. (defun set-timeval-socket-option (socket option value)
  133. (with-foreign-object (%value 'timeval)
  134. (set-timeval %value value)
  135. (socket-set-option socket option :int %value)))
  136. (defun socket-set-option-debug (socket enable)
  137. (socket-set-bool-option socket :so-debug enable))
  138. (defun socket-set-option-broadcast (socket enable)
  139. (socket-set-bool-option socket :so-broadcast enable))
  140. (defun socket-set-option-reuseaddr (socket enable)
  141. (socket-set-bool-option socket :so-reuseaddr enable))
  142. (defun socket-set-option-keepalive (socket enable)
  143. (socket-set-bool-option socket :so-keepalive enable))
  144. (defun socket-set-option-linger (socket enable time)
  145. (with-foreign-object (value 'linger)
  146. (setf (foreign-slot-value value 'linger 'l-onoff) (if enable 1 0))
  147. (setf (foreign-slot-value value 'linger 'l-linger) time)
  148. (socket-set-option socket :so-linger 'linger value)))
  149. (defun socket-set-option-oobinline (socket enable)
  150. (socket-set-bool-option socket :so-oobinline enable))
  151. (defun socket-set-option-sndbuf (socket value)
  152. (socket-set-int-option socket :so-sndbuf value))
  153. (defun socket-set-option-rcvbuf (socket value)
  154. (socket-set-int-option socket :so-rcvbuf value))
  155. (defun socket-set-option-dontroute (socket enable)
  156. (socket-set-bool-option socket :so-dontroute enable))
  157. (defun socket-set-option-rcvlowat (socket value)
  158. (socket-set-int-option socket :so-rcvlowat value))
  159. (defun socket-set-option-rcvtimeo (socket value)
  160. (set-timeval-socket-option socket :so-rcvtimeo value))
  161. (defun socket-set-option-sndlowat (socket value)
  162. (socket-set-int-option socket :so-sndlowat value))
  163. (defun socket-set-option-sndtimeo (socket value)
  164. (set-timeval-socket-option socket :so-sndtimeo value))
  165. (defun socket-get-option (socket option type value)
  166. (with-foreign-object (%size 'socklen-t)
  167. (setf (mem-ref %size 'socklen-t) (foreign-type-size type))
  168. (check-return-code (%getsockopt (socket-fd socket) sol-socket
  169. (foreign-enum-value 'socket-option option)
  170. value %size))))
  171. (defun socket-get-int-option (socket option)
  172. (with-foreign-object (%value :int)
  173. (socket-get-option socket option :int %value)
  174. (mem-ref %value :int)))
  175. (defun socket-get-error (socket)
  176. (socket-get-int-option socket :so-error))
  177. (defun socket-set-non-blocking (socket)
  178. (with-slots (fd) socket
  179. (let* ((flag (check-return-code (%fcntl fd :f-getfl)))
  180. (status (foreign-bitfield-symbols 'file-flags flag))
  181. (value (foreign-bitfield-value 'file-flags
  182. (cons :o-nonblock status))))
  183. (check-return-code (%fcntl fd :f-setfl :int value)))))
  184. (defun socket-read (socket count buffer)
  185. "Read a up to COUNT bytes from SOCKET, append them to BUFFER, then return
  186. the number of bytes read."
  187. (with-foreign-object (%vector :uchar count)
  188. (let ((nb-read (check-return-code
  189. (%read (socket-fd socket) %vector count))))
  190. (when (> nb-read 0)
  191. (let ((vector (make-array nb-read :element-type '(unsigned-byte 8))))
  192. (loop for i from 0 below nb-read do
  193. (setf (aref vector i) (mem-ref %vector :uchar i)))
  194. (buffer-append buffer vector)))
  195. nb-read)))
  196. (defun socket-write (socket count buffer)
  197. "Write up to COUNT bytes from BUFFER to SOCKET, then return the number of
  198. bytes written."
  199. (with-foreign-object (%vector :uchar count)
  200. (with-slots (data) buffer
  201. (loop for i from 0 below count do
  202. (setf (mem-ref %vector :uchar i) (aref data i)))
  203. (check-return-code (%write (socket-fd socket) %vector count)))))