net.sockets/make-socket.lisp

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