src/sockets/make-socket.lisp

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