net.sockets/make-socket.lisp

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