PageRenderTime 4ms CodeModel.GetById 6ms app.highlight 22ms RepoModel.GetById 1ms app.codeStats 0ms

/src/sockets/make-socket.lisp

https://bitbucket.org/sionescu/iolib
Lisp | 423 lines | 355 code | 48 blank | 20 comment | 0 complexity | a52fda4edeac8f322ad7d5c04996f9e6 MD5 | raw file
  1;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
  2;;;
  3;;; --- Socket creation.
  4;;;
  5
  6(in-package :iolib/sockets)
  7
  8(eval-when (:compile-toplevel :load-toplevel :execute)
  9  (defparameter *socket-type-map*
 10    '(((:ipv4  :stream   :active)  . socket-stream-internet-active)
 11      ((:ipv6  :stream   :active)  . socket-stream-internet-active)
 12      ((:ipv4  :stream   :passive) . socket-stream-internet-passive)
 13      ((:ipv6  :stream   :passive) . socket-stream-internet-passive)
 14      ((:local :stream   :active)  . socket-stream-local-active)
 15      ((:local :stream   :passive) . socket-stream-local-passive)
 16      ((:local :datagram nil)      . socket-datagram-local)
 17      ((:ipv4  :datagram nil)      . socket-datagram-internet)
 18      ((:ipv6  :datagram nil)      . socket-datagram-internet)
 19      ((:ipv4  :raw      nil)      . socket-raw-internet)
 20      #+linux
 21      ((:netlink :raw    nil)      . socket-raw-netlink)))
 22
 23  (defun select-socket-class (address-family type connect)
 24    (or (loop :for ((sock-family sock-type sock-connect) . class)
 25                :in *socket-type-map*
 26              :when (and (eql sock-family address-family)
 27                         (eql sock-type type)
 28                         (if sock-connect (eql sock-connect connect) t))
 29              :return class)
 30        (error "No socket class found !!"))))
 31
 32(defun create-socket (family type protocol
 33                      &rest args &key connect fd &allow-other-keys)
 34  (apply #'make-instance (select-socket-class family type connect)
 35         :address-family family
 36         :protocol protocol
 37         :file-descriptor fd
 38         (remove-from-plist args :connect)))
 39
 40(define-compiler-macro create-socket (&whole form &environment env
 41                                      family type protocol
 42                                      &rest args &key connect fd &allow-other-keys)
 43  (cond
 44    ((and (constantp family env) (constantp type env) (constantp connect env))
 45     `(make-instance ',(select-socket-class family type connect)
 46                     :file-descriptor ,fd
 47                     :address-family ,family
 48                     :protocol ,protocol
 49                     ,@(remove-from-plist args :connect)))
 50    (t form)))
 51
 52(defmacro with-close-on-error ((var value) &body body)
 53  "Bind `VAR' to `VALUE' and execute `BODY' as implicit PROGN.
 54If a non-local exit occurs during the execution of `BODY',
 55call CLOSE with :ABORT T on `VAR'."
 56  `(let ((,var ,value))
 57     (unwind-protect-case () ,@body
 58       (:abort (close ,var :abort t)))))
 59
 60(defmacro %create-internet-socket (family &rest args)
 61  `(case ,family
 62     (:ipv4 (create-socket :ipv4 ,@args))
 63     (:ipv6 (create-socket :ipv6 ,@args))))
 64
 65(eval-when (:compile-toplevel :load-toplevel :execute)
 66  (defun make-first-level-name (family type connect)
 67    (if (eql :stream type)
 68        (format-symbol :iolib/sockets "%~A/~A-~A-~A" :make-socket family type connect)
 69        (format-symbol :iolib/sockets "%~A/~A-~A" :make-socket family type))))
 70
 71(defmacro define-socket-creator ((socket-family socket-type &optional socket-connect)
 72                                 (family protocol key &rest parameters) &body body)
 73  (assert (eql '&key key))
 74  (flet ((maybe-quote-default-value (arg)
 75           (cond ((symbolp arg) arg)
 76                 ((consp arg)   (list (first arg) `(quote ,(second arg))))))
 77         (arg-name (arg)
 78           (car (ensure-list arg)))
 79         (quotify (form)
 80           `(list (quote ,(car form)) ,@(cdr form))))
 81    (let* ((parameter-names (mapcar #'arg-name parameters))
 82           (first-level-function (make-first-level-name socket-family socket-type socket-connect))
 83           (second-level-function (format-symbol t "%~A" first-level-function)))
 84      (flet ((make-first-level-body (family protocol)
 85               `(,second-level-function ,family ,protocol ,@parameter-names)))
 86        `(progn
 87           (declaim (inline ,second-level-function))
 88           (defun ,second-level-function (,family ,protocol ,@parameter-names) ,@body)
 89           (defun ,first-level-function (arguments family protocol)
 90             (destructuring-bind (&key ,@parameters)
 91                 arguments
 92               ,(make-first-level-body family protocol)))
 93           (define-compiler-macro ,first-level-function (&whole form arguments family protocol)
 94             ;; Must quote default values in order for them not to be evaluated
 95             ;; in the compilation environment
 96             (if (listp arguments)
 97                 (destructuring-bind (&key ,@(mapcar #'maybe-quote-default-value parameters))
 98                     (cdr arguments)
 99                   ,(quotify (make-first-level-body family protocol)))
100                 form)))))))
101
102
103;;; Internet Stream Active Socket creation
104
105(defun %%init-socket/internet-stream-active (socket keepalive nodelay reuse-address
106                                             local-host local-port remote-host remote-port)
107  (setf (socket-option socket :no-sigpipe :if-does-not-exist nil) t)
108  (when keepalive (setf (socket-option socket :keep-alive) t))
109  (when nodelay (setf (socket-option socket :tcp-nodelay) t))
110  (when local-host
111    (bind-address socket (ensure-hostname local-host)
112                  :port local-port
113                  :reuse-address reuse-address))
114  (when remote-host
115    (connect socket (ensure-hostname remote-host)
116             :port remote-port))
117  (values socket))
118
119(define-socket-creator (:internet :stream :active)
120    (family protocol &key external-format
121                          keepalive nodelay (reuse-address t)
122                          local-host local-port remote-host remote-port
123                          input-buffer-size output-buffer-size)
124  (with-close-on-error (socket (%create-internet-socket family :stream protocol
125                                                        :connect :active 
126                                                        :external-format external-format
127                                                        :input-buffer-size input-buffer-size
128                                                        :output-buffer-size output-buffer-size))
129    (%%init-socket/internet-stream-active socket keepalive nodelay reuse-address
130                                          local-host (or local-port 0) remote-host remote-port)))
131
132
133;;; Internet Stream Passive Socket creation
134
135(defun %%init-socket/internet-stream-passive (socket interface reuse-address
136                                              local-host local-port backlog)
137  (when local-host
138    (when interface
139      (setf (socket-option socket :bind-to-device) interface))
140    (bind-address socket (ensure-hostname local-host)
141                  :port local-port
142                  :reuse-address reuse-address)
143    (listen-on socket :backlog backlog))
144  (values socket))
145
146(define-socket-creator (:internet :stream :passive)
147    (family protocol &key external-format
148                          interface (reuse-address t)
149                          local-host local-port backlog)
150  (with-close-on-error (socket (%create-internet-socket family :stream protocol
151                                                        :connect :passive
152                                                        :external-format external-format))
153    (%%init-socket/internet-stream-passive socket interface reuse-address
154                                           local-host (or local-port 0)
155                                           (or backlog *default-backlog-size*))))
156
157
158;;; Local Stream Active Socket creation
159
160(defun %%init-socket/local-stream-active (socket local-filename remote-filename)
161  (setf (socket-option socket :no-sigpipe :if-does-not-exist nil) t)
162  (when local-filename
163    (bind-address socket (ensure-address local-filename :family :local)))
164  (when remote-filename
165    (connect socket (ensure-address remote-filename :family :local)))
166  (values socket))
167
168(define-socket-creator (:local :stream :active)
169    (family protocol &key external-format local-filename remote-filename
170                          input-buffer-size output-buffer-size)
171  (with-close-on-error (socket (create-socket family :stream protocol
172                                              :connect :active
173                                              :external-format external-format
174                                              :input-buffer-size input-buffer-size
175                                              :output-buffer-size output-buffer-size))
176    (%%init-socket/local-stream-active socket local-filename remote-filename)))
177
178
179;;; Local Stream Passive Socket creation
180
181(defun %%init-socket/local-stream-passive (socket local-filename reuse-address backlog)
182  (when local-filename
183    (bind-address socket (ensure-address local-filename :family :local)
184                  :reuse-address reuse-address)
185    (listen-on socket :backlog backlog))
186  (values socket))
187
188(define-socket-creator (:local :stream :passive)
189    (family protocol &key external-format local-filename (reuse-address t) backlog)
190  (with-close-on-error (socket (create-socket family :stream protocol
191                                              :connect :passive
192                                              :external-format external-format))
193    (%%init-socket/local-stream-passive socket local-filename reuse-address
194                                        (or backlog *default-backlog-size*))))
195
196
197;;; Internet Datagram Socket creation
198
199(defun %%init-socket/internet-datagram (socket broadcast interface reuse-address
200                                        local-host local-port remote-host remote-port)
201  (setf (socket-option socket :no-sigpipe :if-does-not-exist nil) t)
202  (when broadcast (setf (socket-option socket :broadcast) t))
203  (when local-host
204    (bind-address socket (ensure-hostname local-host)
205                  :port local-port
206                  :reuse-address reuse-address)
207    (when interface
208      (setf (socket-option socket :bind-to-device) interface)))
209  (when remote-host
210    (connect socket (ensure-hostname remote-host)
211             :port remote-port))
212  (values socket))
213
214(define-socket-creator (:internet :datagram)
215    (family protocol &key broadcast interface (reuse-address t)
216                          local-host local-port remote-host remote-port)
217  (with-close-on-error (socket (%create-internet-socket family :datagram protocol))
218    (%%init-socket/internet-datagram socket broadcast interface reuse-address
219                                     local-host (or local-port 0)
220                                     remote-host (or remote-port 0))))
221
222
223;;; Local Datagram Socket creation
224
225(defun %%init-socket/local-datagram (socket local-filename remote-filename)
226  (setf (socket-option socket :no-sigpipe :if-does-not-exist nil) t)
227  (when local-filename
228    (bind-address socket (ensure-address local-filename :family :local)))
229  (when remote-filename
230    (connect socket (ensure-address remote-filename :family :local)))
231  (values socket))
232
233(define-socket-creator (:local :datagram)
234    (family protocol &key local-filename remote-filename)
235  (with-close-on-error (socket (create-socket family :datagram protocol))
236    (%%init-socket/local-datagram socket local-filename remote-filename)))
237
238
239;;; Raw Socket creation
240
241(defun %%init-socket/internet-raw (socket include-headers)
242  (setf (socket-option socket :no-sigpipe :if-does-not-exist nil) t)
243  (setf (socket-option socket :ip-header-include) include-headers)
244  (values socket))
245
246(define-socket-creator (:internet :raw)
247    (family protocol &key include-headers)
248  (with-close-on-error (socket (create-socket family :raw protocol))
249    (%%init-socket/internet-raw socket include-headers)))
250
251
252;;; Netlink Socket creation
253
254#+linux
255(defun %%init-socket/netlink-raw (socket local-port multicast-groups)
256  (when local-port
257    (bind-address socket
258                  (make-instance 'netlink-address
259                                 :multicast-groups multicast-groups)
260                  :port local-port))
261  (values socket))
262
263#+linux
264(define-socket-creator (:netlink :raw)
265    (family protocol &key (local-port 0) (multicast-groups 0))
266  (with-close-on-error (socket (create-socket family :raw protocol))
267    (%%init-socket/netlink-raw socket local-port multicast-groups)))
268
269#-linux
270(define-socket-creator (:netlink :raw)
271    (family protocol &key local-port multicast-groups)
272  (declare (ignore family protocol local-port multicast-groups))
273  (error 'socket-address-family-not-supported-error))
274
275
276;;; MAKE-SOCKET
277
278(defmethod make-socket (&rest args &key (address-family :internet) (type :stream) (protocol :default)
279                        (connect :active) (ipv6 *ipv6*) &allow-other-keys)
280  (when (eql :file address-family) (setf address-family :local))
281  (check-type address-family (member :internet :local :ipv4 :ipv6 :netlink)
282              "one of :INTERNET, :LOCAL(or :FILE), :IPV4, :IPV6 or :NETLINK")
283  (check-type type (member :stream :datagram :raw) "either :STREAM, :DATAGRAM or :RAW")
284  (check-type connect (member :active :passive) "either :ACTIVE or :PASSIVE")
285  (let ((args (remove-from-plist args :address-family :type :protocol :connect :ipv6)))
286    (when (eql :ipv4 address-family) (setf ipv6 nil))
287    (let ((*ipv6* ipv6))
288      (when (eql :internet address-family) (setf address-family +default-inet-address-family+))
289      (multiple-value-case ((address-family type connect))
290        ((:ipv4 :stream :active)
291         (%make-socket/internet-stream-active   args :ipv4  :default))
292        ((:ipv6 :stream :active)
293         (%make-socket/internet-stream-active   args :ipv6  :default))
294        ((:ipv4 :stream :passive)
295         (%make-socket/internet-stream-passive  args :ipv4  :default))
296        ((:ipv6 :stream :passive)
297         (%make-socket/internet-stream-passive  args :ipv6  :default))
298        ((:local :stream :active)
299         (%make-socket/local-stream-active      args :local :default))
300        ((:local :stream :passive)
301         (%make-socket/local-stream-passive     args :local :default))
302        ((:ipv4 :datagram)
303         (%make-socket/internet-datagram        args :ipv4  :default))
304        ((:ipv6 :datagram)
305         (%make-socket/internet-datagram        args :ipv6  :default))
306        ((:local :datagram)
307         (%make-socket/local-datagram           args :local :default))
308        ((:ipv4 :raw)
309         (%make-socket/internet-raw             args :ipv4  protocol))
310        ((:netlink :raw)
311         (%make-socket/netlink-raw              args :netlink protocol))))))
312
313(define-compiler-macro make-socket (&whole form &environment env &rest args
314                                    &key (address-family :internet) (type :stream) (protocol :default)
315                                    (connect :active) (ipv6 '*ipv6* ipv6p) &allow-other-keys)
316  (when (eql :file address-family) (setf address-family :local))
317  (cond
318    ((and (constantp address-family env) (constantp type env) (constantp connect env))
319     (check-type address-family (member :internet :local :ipv4 :ipv6 :netlink)
320                 "one of :INTERNET, :LOCAL(or :FILE), :IPV4, :IPV6 or :NETLINK")
321     (check-type type (member :stream :datagram :raw) "either :STREAM, :DATAGRAM or :RAW")
322     (check-type connect (member :active :passive) "either :ACTIVE or :PASSIVE")
323     (let* ((family (if (member address-family '(:ipv4 :ipv6)) :internet address-family))
324            (lower-function (make-first-level-name family type connect))
325            (args (remove-from-plist args :address-family :type :protocol :connect :ipv6)))
326       (case address-family
327         (:internet (setf address-family '+default-inet-address-family+))
328         (:ipv4     (setf ipv6 nil ipv6p t)))
329       (let ((expansion `(,lower-function (list ,@args) ,address-family ,protocol)))
330         (if ipv6p `(let ((*ipv6* ,ipv6)) ,expansion) expansion))))
331    (t form)))
332
333(defmacro with-open-socket ((var &rest args) &body body)
334  "Bind VAR to a socket created by passing ARGS to MAKE-SOCKET and execute BODY as implicit PROGN.
335The socket is automatically closed upon exit."
336  `(with-open-stream (,var (make-socket ,@args)) ,@body))
337
338(defmacro with-accept-connection ((var passive-socket &rest args) &body body)
339  "Bind VAR to a socket created by passing PASSIVE-SOCKET and ARGS to ACCEPT-CONNECTION and execute BODY as implicit PROGN.
340The socket is automatically closed upon exit."
341  `(with-open-stream (,var (accept-connection ,passive-socket ,@args)) ,@body))
342
343
344;;; MAKE-SOCKET-FROM-FD
345
346;;; FIXME: must come up with a way to find out
347;;; whether a socket is active or passive
348(defmethod make-socket-from-fd ((fd integer) &key (dup t) (connect :active) (external-format :default)
349                                input-buffer-size output-buffer-size)
350  (flet ((%get-address-family (fd)
351           (with-sockaddr-storage-and-socklen (ss size)
352             (%getsockname fd ss size)
353             (eswitch ((foreign-slot-value ss 'sockaddr-storage 'family) :test #'=)
354               (af-inet  :ipv4)
355               (af-inet6 :ipv6)
356               (af-local :local)
357               #+linux
358               (af-netlink :netlink))))
359         (%get-type (fd)
360           (eswitch ((get-socket-option-int fd sol-socket so-type) :test #'=)
361             (sock-stream :stream)
362             (sock-dgram  :datagram)
363             (sock-raw    :raw))))
364    (create-socket (%get-address-family fd)
365                   (%get-type fd)
366                   :default
367                   :connect connect
368                   :fd fd
369                   :dup dup
370                   :external-format external-format
371                   :input-buffer-size input-buffer-size
372                   :output-buffer-size output-buffer-size)))
373
374
375;;; MAKE-SOCKET-PAIR
376
377(defmethod make-socket-pair (&key (type :stream) (protocol :default) (external-format :default)
378                             input-buffer-size output-buffer-size)
379  (flet ((%make-socket-pair (fd)
380           (make-socket-from-fd fd :dup nil
381                                :external-format external-format
382                                :input-buffer-size input-buffer-size
383                                :output-buffer-size output-buffer-size)))
384    (multiple-value-bind (fd1 fd2)
385        (multiple-value-call #'%socketpair
386          (translate-make-socket-keywords-to-constants :local type protocol))
387      (values (%make-socket-pair fd1)
388              (%make-socket-pair fd2)))))
389
390
391;;; SEND/RECEIVE-FILE-DESCRIPTOR
392
393(defun call-with-buffers-for-fd-passing (fn)
394  (with-foreign-object (msg 'msghdr)
395    (isys:bzero msg (isys:sizeof 'msghdr))
396    (with-foreign-pointer (buffer #.(isys:cmsg.space (isys:sizeof :int))
397                           buffer-size)
398      (isys:bzero buffer buffer-size)
399      (with-foreign-slots ((control controllen) msg msghdr)
400        (setf control    buffer
401              controllen buffer-size)
402        (let ((cmsg (isys:cmsg.firsthdr msg)))
403          (with-foreign-slots ((len level type) cmsg cmsghdr)
404            (setf len (isys:cmsg.len (isys:sizeof :int))
405                  level sol-socket
406                  type scm-rights)
407            (funcall fn msg cmsg)))))))
408
409(defmacro with-buffers-for-fd-passing ((msg-var cmsg-var) &body body)
410  `(call-with-buffers-for-fd-passing (lambda (,msg-var ,cmsg-var) ,@body)))
411
412(defmethod send-file-descriptor ((socket local-socket) file-descriptor)
413  (with-buffers-for-fd-passing (msg cmsg)
414    (let ((data (isys:cmsg.data cmsg)))
415      (setf (mem-aref data :int) file-descriptor)
416      (%sendmsg (fd-of socket) msg 0)
417      (values))))
418
419(defmethod receive-file-descriptor ((socket local-socket))
420  (with-buffers-for-fd-passing (msg cmsg)
421    (let ((data (isys:cmsg.data cmsg)))
422      (%recvmsg (fd-of socket) msg 0)
423      (mem-aref data :int))))