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