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