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