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