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 fd ibs obs)
  27   (if (or ibs obs)
  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 ibs
  32                      :output-buffer-size obs)
  33       (make-instance (select-socket-class family type connect :default)
  34                      :family family :file-descriptor fd
  35                      :external-format external-format)))
  36
  37 (defmacro with-close-on-error ((var value) &body body)
  38   "Bind `VAR' to `VALUE', execute `BODY' as implicit PROGN and return `VAR'.
  39 If a non-local exit occurs during the execution of `BODY' call CLOSE with :ABORT T on `VAR'."
  40   (with-gensyms (errorp)
  41     `(let ((,var ,value) (,errorp t))
  42        (unwind-protect
  43             (multiple-value-prog1 (locally ,@body ,var) (setf ,errorp nil))
  44          (when (and ,var ,errorp) (close ,var :abort t))))))
  45
  46 (defmacro with-guard-again-non-list-args-and-destructuring-bind-errors
  47     (form args &body body)
  48   `(if (listp ,args)
  49        (handler-case (progn ,@body)
  50          (error (err) `(error ,err)))
  51        ,form))
  52 \f
  53 ;;; Internet Stream Active Socket creation
  54
  55 (defun %%make-internet-stream-active-socket (family ef keepalive nodelay reuse-address
  56                                              local-host local-port remote-host remote-port
  57                                              input-buffer-size output-buffer-size)
  58   (let ((local-port  (ensure-numerical-service local-port))
  59         (remote-port (ensure-numerical-service remote-port)))
  60     (with-close-on-error (socket (create-socket family :stream :active ef
  61                                                 :ibs input-buffer-size
  62                                                 :obs output-buffer-size))
  63       (when keepalive (setf (socket-option socket :keep-alive) t))
  64       (when nodelay (setf (socket-option socket :tcp-nodelay) t))
  65       (when local-host
  66         (bind-address socket (ensure-hostname local-host)
  67                       :port local-port
  68                       :reuse-address reuse-address))
  69       (when (plusp remote-port)
  70         (connect socket (ensure-hostname remote-host)
  71                  :port remote-port)))))
  72
  73 (defun %make-internet-stream-active-socket (args family ef)
  74   (destructuring-bind (&key keepalive nodelay (reuse-address t)
  75                             local-host (local-port 0)
  76                             (remote-host +any-host+) (remote-port 0)
  77                             input-buffer-size output-buffer-size)
  78       args
  79     (%%make-internet-stream-active-socket family ef keepalive nodelay reuse-address
  80                                           local-host local-port remote-host remote-port
  81                                           input-buffer-size output-buffer-size)))
  82
  83 (define-compiler-macro %make-internet-stream-active-socket (&whole form args family ef)
  84   (with-guard-again-non-list-args-and-destructuring-bind-errors
  85       form args
  86     (destructuring-bind (&key keepalive nodelay (reuse-address t)
  87                               local-host (local-port 0)
  88                               (remote-host +any-host+) (remote-port 0)
  89                               input-buffer-size output-buffer-size)
  90         (cdr args)
  91       `(%%make-internet-stream-active-socket ,family ,ef ,keepalive ,nodelay ,reuse-address
  92                                              ,local-host ,local-port ,remote-host ,remote-port
  93                                              ,input-buffer-size ,output-buffer-size))))
  94 \f
  95 ;;; Internet Stream Passive Socket creation
  96
  97 (defun %%make-internet-stream-passive-socket (family ef interface reuse-address
  98                                               local-host local-port backlog)
  99   (let ((local-port  (ensure-numerical-service local-port)))
 100     (with-close-on-error (socket (create-socket family :stream :passive ef))
 101       (when local-host
 102         (when interface
 103           (setf (socket-option socket :bind-to-device) interface))
 104         (bind-address socket (ensure-hostname local-host)
 105                       :port local-port
 106                       :reuse-address reuse-address)
 107         (listen-on socket :backlog backlog)))))
 108
 109 (defun %make-internet-stream-passive-socket (args family ef)
 110   (destructuring-bind (&key interface (reuse-address t)
 111                             (local-host +any-host+) (local-port 0)
 112                             (backlog *default-backlog-size*))
 113       args
 114     (%%make-internet-stream-passive-socket family ef interface reuse-address
 115                                            local-host local-port backlog)))
 116
 117 (define-compiler-macro %make-internet-stream-passive-socket (&whole form args family ef)
 118   (with-guard-again-non-list-args-and-destructuring-bind-errors
 119       form args
 120     (destructuring-bind (&key interface (reuse-address t)
 121                               (local-host +any-host+) (local-port 0)
 122                               (backlog *default-backlog-size*))
 123         (cdr args)
 124       `(%%make-internet-stream-passive-socket ,family ,ef ,interface ,reuse-address
 125                                               ,local-host ,local-port ,backlog))))
 126 \f
 127 ;;; Local Stream Active Socket creation
 128
 129 (defun %%make-local-stream-active-socket (family ef local-filename remote-filename
 130                                           input-buffer-size output-buffer-size)
 131   (with-close-on-error (socket (create-socket family :stream :active ef
 132                                               :ibs input-buffer-size
 133                                               :obs output-buffer-size))
 134     (when local-filename
 135       (bind-address socket (ensure-address local-filename :family :local)))
 136     (when remote-filename
 137       (connect socket (ensure-address remote-filename :family :local)))))
 138
 139 (defun %make-local-stream-active-socket (args family ef)
 140   (destructuring-bind (&key local-filename remote-filename
 141                             input-buffer-size output-buffer-size)
 142       args
 143     (%%make-local-stream-active-socket family ef local-filename remote-filename
 144                                        input-buffer-size output-buffer-size)))
 145
 146 (define-compiler-macro %make-local-stream-active-socket (&whole form args family ef)
 147   (with-guard-again-non-list-args-and-destructuring-bind-errors
 148       form args
 149     (destructuring-bind (&key local-filename remote-filename
 150                               input-buffer-size output-buffer-size)
 151         (cdr args)
 152       `(%%make-local-stream-active-socket ,family ,ef ,local-filename ,remote-filename
 153                                           ,input-buffer-size ,output-buffer-size))))
 154 \f
 155 ;;; Local Stream Passive Socket creation
 156
 157 (defun %%make-local-stream-passive-socket (family ef local-filename reuse-address backlog)
 158   (with-close-on-error (socket (create-socket family :stream :passive ef))
 159     (when local-filename
 160       (bind-address socket (ensure-address local-filename :family :local)
 161                     :reuse-address reuse-address)
 162       (listen-on socket :backlog backlog))))
 163
 164 (defun %make-local-stream-passive-socket (args family ef)
 165   (destructuring-bind (&key local-filename (reuse-address t)
 166                             (backlog *default-backlog-size*))
 167       args
 168     (%%make-local-stream-passive-socket family ef local-filename reuse-address backlog)))
 169
 170 (define-compiler-macro %make-local-stream-passive-socket (&whole form args family ef)
 171   (with-guard-again-non-list-args-and-destructuring-bind-errors
 172       form args
 173     (destructuring-bind (&key local-filename (reuse-address t)
 174                               (backlog *default-backlog-size*))
 175         (cdr args)
 176       `(%%make-local-stream-passive-socket ,family ,ef ,local-filename ,reuse-address ,backlog))))
 177 \f
 178 ;;; Internet Datagram Socket creation
 179
 180 (defun %%make-internet-datagram-socket (family ef broadcast interface reuse-address
 181                                         local-host local-port remote-host remote-port)
 182   (let ((local-port  (ensure-numerical-service local-port))
 183         (remote-port (ensure-numerical-service remote-port)))
 184     (with-close-on-error (socket (create-socket family :datagram :active ef))
 185       (when broadcast (setf (socket-option socket :broadcast) t))
 186       (when local-host
 187         (bind-address socket (ensure-hostname local-host)
 188                       :port local-port
 189                       :reuse-address reuse-address)
 190         (when interface
 191           (setf (socket-option socket :bind-to-device) interface)))
 192       (when (plusp remote-port)
 193         (connect socket (ensure-hostname remote-host)
 194                  :port remote-port)))))
 195
 196 (defun %make-internet-datagram-socket (args family ef)
 197   (destructuring-bind (&key broadcast interface (reuse-address t)
 198                             local-host (local-port 0)
 199                             (remote-host +any-host+) (remote-port 0))
 200       args
 201     (%%make-internet-datagram-socket family ef broadcast interface reuse-address
 202                                      local-host local-port remote-host remote-port)))
 203
 204 (define-compiler-macro %make-internet-datagram-socket (&whole form args family ef)
 205   (with-guard-again-non-list-args-and-destructuring-bind-errors
 206       form args
 207     (destructuring-bind (&key broadcast interface (reuse-address t)
 208                               local-host (local-port 0)
 209                               (remote-host +any-host+) (remote-port 0))
 210         (cdr args)
 211       `(%%make-internet-datagram-socket ,family ,ef ,broadcast ,interface ,reuse-address
 212                                         ,local-host ,local-port ,remote-host ,remote-port))))
 213 \f
 214 ;;; Local Datagram Socket creation
 215
 216 (defun %%make-local-datagram-socket (family ef local-filename remote-filename)
 217   (with-close-on-error (socket (create-socket family :datagram :active ef))
 218     (when local-filename
 219       (bind-address socket (ensure-address local-filename :family :local)))
 220     (when remote-filename
 221       (connect socket (ensure-address remote-filename :family :local)))))
 222
 223 (defun %make-local-datagram-socket (args family ef)
 224   (destructuring-bind (&key local-filename remote-filename)
 225       args
 226     (%%make-local-datagram-socket family ef local-filename remote-filename)))
 227
 228 (define-compiler-macro %make-local-datagram-socket (&whole form args family ef)
 229   (with-guard-again-non-list-args-and-destructuring-bind-errors
 230       form args
 231     (destructuring-bind (&key local-filename remote-filename)
 232         (cdr args)
 233       `(%%make-local-datagram-socket ,family ,ef ,local-filename ,remote-filename))))
 234 \f
 235 ;;; MAKE-SOCKET
 236
 237 (defun make-socket (&rest args &key (family :internet) (type :stream)
 238                     (connect :active) (ipv6 *ipv6*)
 239                     (external-format :default) &allow-other-keys)
 240   "Creates a socket instance of the appropriate subclass of SOCKET."
 241   (check-type family (member :internet :local :ipv4 :ipv6) "one of :INTERNET, :LOCAL, :IPV4 or :IPV6")
 242   (check-type type (member :stream :datagram) "either :STREAM or :DATAGRAM")
 243   (check-type connect (member :active :passive) "either :ACTIVE or :PASSIVE")
 244   (let ((args (remove-from-plist args :family :type :connect :external-format :ipv6)))
 245     (when (eq :ipv4 family) (setf ipv6 nil))
 246     (let ((*ipv6* ipv6))
 247       (when (eq :internet family) (setf family +default-inet-family+))
 248       (multiple-value-case ((family type connect))
 249         (((:ipv4 :ipv6) :stream :active)
 250          (%make-internet-stream-active-socket args family external-format))
 251         (((:ipv4 :ipv6) :stream :passive)
 252          (%make-internet-stream-passive-socket args family external-format))
 253         ((:local :stream :active)
 254          (%make-local-stream-active-socket args :local external-format))
 255         ((:local :stream :passive)
 256          (%make-local-stream-passive-socket args :local external-format))
 257         (((:ipv4 :ipv6) :datagram)
 258          (%make-internet-datagram-socket args family external-format))
 259         ((:local :datagram)
 260          (%make-local-datagram-socket args :local external-format))))))
 261
 262 (define-compiler-macro make-socket (&whole form &rest args &key (family :internet) (type :stream)
 263                                     (connect :active) (ipv6 '*ipv6* ipv6p)
 264                                     (external-format :default) &allow-other-keys)
 265   (cond
 266     ((and (constantp family) (constantp type) (constantp connect))
 267      (check-type family (member :internet :local :ipv4 :ipv6) "one of :INTERNET, :LOCAL, :IPV4 or :IPV6")
 268      (check-type type (member :stream :datagram) "either :STREAM or :DATAGRAM")
 269      (check-type connect (member :active :passive) "either :ACTIVE or :PASSIVE")
 270      (let ((lower-function
 271             (multiple-value-case ((family type connect))
 272               (((:ipv4 :ipv6 :internet) :stream :active) '%make-internet-stream-active-socket)
 273               (((:ipv4 :ipv6 :internet) :stream :passive) '%make-internet-stream-passive-socket)
 274               ((:local :stream :active) '%make-local-stream-active-socket)
 275               ((:local :stream :passive) '%make-local-stream-passive-socket)
 276               (((:ipv4 :ipv6 :internet) :datagram) '%make-internet-datagram-socket)
 277               ((:local :datagram) '%make-local-datagram-socket)))
 278            (newargs (remove-from-plist args :family :type :connect :external-format :ipv6)))
 279        (multiple-value-case (family)
 280          (:internet (setf family '+default-inet-family+))
 281          (:ipv4     (setf ipv6 nil)))
 282        (let ((expansion `(,lower-function (list ,@newargs) ,family ,external-format)))
 283          (if (or ipv6p (eq :ipv4 family))
 284              `(let ((*ipv6* ,ipv6)) ,expansion)
 285              expansion))))
 286     (t form)))
 287
 288 (defmacro with-open-socket ((var &rest args) &body body)
 289   "VAR is bound to a socket created by passing ARGS to
 290 MAKE-SOCKET and BODY is executed as implicit PROGN.  The socket
 291 is automatically closed upon exit."
 292   `(with-open-stream (,var (make-socket ,@args)) ,@body))
 293
 294 (defmacro with-accept-connection ((var passive-socket &rest args) &body body)
 295   "VAR is bound to a socket created by passing PASSIVE-SOCKET and ARGS to
 296 ACCEPT-CONNECTION and BODY is executed as implicit PROGN.  The socket
 297 is automatically closed upon exit."
 298   `(with-open-stream (,var (accept-connection ,passive-socket ,@args)) ,@body))
 299 \f
 300 ;;; MAKE-SOCKET-STREAM
 301
 302 (defun get-address-family (fd)
 303   (with-sockaddr-storage (ss)
 304     (with-socklen (size size-of-sockaddr-storage)
 305       (%getsockname fd ss size)
 306       (foreign-slot-value ss 'sockaddr-storage 'family))))
 307
 308 (defun make-socket-stream (fd &key (external-format :default) (errorp t))
 309   "Creates an active stream socket instance of the appropriate subclass of SOCKET using `FD'.
 310 The address family of the sockets is automatically discovered using OS functions. If `FD' is
 311 an invalid socket descriptor and `ERRORP' is not NIL a condition subtype of POSIX-ERROR
 312 is signaled, otherwise two values are returned: NIL and the specific condition object."
 313   (flet ((%make-socket-stream ()
 314            (let ((family (switch ((get-address-family fd) :test #'=)
 315                            (af-inet :ipv4)
 316                            (af-inet6 :ipv6)
 317                            (af-local :local))))
 318              (create-socket family :stream :active external-format :fd fd))))
 319     (if errorp
 320         (%make-socket-stream)
 321         (ignore-some-conditions (posix-error)
 322           (%make-socket-stream)))))