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 (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 \f
 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 \f
 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 \f
 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 \f
 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 \f
 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 \f
 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 \f
 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 \f
 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 \f
 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.
 335 The 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.
 340 The socket is automatically closed upon exit."
 341   `(with-open-stream (,var (accept-connection ,passive-socket ,@args)) ,@body))
 342 \f
 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 '(:struct sockaddr-storage) 'family)
 354                        :test #'=)
 355                (af-inet  :ipv4)
 356                (af-inet6 :ipv6)
 357                (af-local :local)
 358                #+linux
 359                (af-netlink :netlink))))
 360          (%get-type (fd)
 361            (eswitch ((get-socket-option-int fd sol-socket so-type) :test #'=)
 362              (sock-stream :stream)
 363              (sock-dgram  :datagram)
 364              (sock-raw    :raw))))
 365     (create-socket (%get-address-family fd)
 366                    (%get-type fd)
 367                    :default
 368                    :connect connect
 369                    :fd fd
 370                    :dup dup
 371                    :external-format external-format
 372                    :input-buffer-size input-buffer-size
 373                    :output-buffer-size output-buffer-size)))
 374 \f
 375
 376 ;;; MAKE-SOCKET-PAIR
 377
 378 (defmethod make-socket-pair (&key (type :stream) (protocol :default) (external-format :default)
 379                              input-buffer-size output-buffer-size)
 380   (flet ((%make-socket-pair (fd)
 381            (make-socket-from-fd fd :dup nil
 382                                 :external-format external-format
 383                                 :input-buffer-size input-buffer-size
 384                                 :output-buffer-size output-buffer-size)))
 385     (multiple-value-bind (fd1 fd2)
 386         (multiple-value-call #'%socketpair
 387           (translate-make-socket-keywords-to-constants :local type protocol))
 388       (values (%make-socket-pair fd1)
 389               (%make-socket-pair fd2)))))
 390 \f
 391
 392 ;;; SEND/RECEIVE-FILE-DESCRIPTOR
 393
 394 (defun call-with-buffers-for-fd-passing (fn)
 395   (with-foreign-object (msg '(:struct msghdr))
 396     (isys:bzero msg (isys:sizeof '(:struct msghdr)))
 397     (with-foreign-pointer (buffer #.(isys:cmsg.space (isys:sizeof :int))
 398                            buffer-size)
 399       (isys:bzero buffer buffer-size)
 400       (with-foreign-slots ((control controllen) msg (:struct msghdr))
 401         (setf control    buffer
 402               controllen buffer-size)
 403         (let ((cmsg (isys:cmsg.firsthdr msg)))
 404           (with-foreign-slots ((len level type) cmsg (:struct cmsghdr))
 405             (setf len (isys:cmsg.len (isys:sizeof :int))
 406                   level sol-socket
 407                   type scm-rights)
 408             (funcall fn msg cmsg)))))))
 409
 410 (defmacro with-buffers-for-fd-passing ((msg-var cmsg-var) &body body)
 411   `(call-with-buffers-for-fd-passing (lambda (,msg-var ,cmsg-var) ,@body)))
 412
 413 (defmethod send-file-descriptor ((socket local-socket) file-descriptor)
 414   (with-buffers-for-fd-passing (msg cmsg)
 415     (let ((data (isys:cmsg.data cmsg)))
 416       (setf (mem-aref data :int) file-descriptor)
 417       (%sendmsg (fd-of socket) msg 0)
 418       (values))))
 419
 420 (defmethod receive-file-descriptor ((socket local-socket))
 421   (with-buffers-for-fd-passing (msg cmsg)
 422     (let ((data (isys:cmsg.data cmsg)))
 423       (%recvmsg (fd-of socket) msg 0)
 424       (mem-aref data :int))))