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