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-2007, 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 xnor (x1 x2)
  27   (eq (not x1) (not x2)))
  28
  29 ;;; FIXME: protocol is sort of misinterpreted.
  30 ;;;
  31 ;;; CREATE-SOCKET is a a bit of a confusing name as it is too similar
  32 ;;; to MAKE-SOCKET.  I thought about different names and considered
  33 ;;; the option of moving this "factory" code could be moved into
  34 ;;; MAKE-INSTANCE methods.  However, AFAICT, MAKE-SOCKET can achieve
  35 ;;; the exact same effect as CREATE-SOCKET when some of the parameters
  36 ;;; are ommitted so I have opted to remove CREATE-SOCKET from the
  37 ;;; export list. --luis
  38 (defun create-socket (&key (family :internet) (type :stream) (connect :active)
  39                       (protocol :default) (ipv6 *ipv6*)
  40                       (external-format :default))
  41   ;; (check-type address-family (member :internet :local))
  42   (check-type type (member :stream :datagram))
  43   (check-type connect (member :active :passive))
  44   (check-type ipv6 (member nil t :ipv6))
  45   (when (or (null family) (eq family :internet))
  46     (setf family (if ipv6 :ipv6 :ipv4)))
  47   (let ((class (select-socket-type family type connect protocol)))
  48     (make-instance class
  49                    :family family
  50                    :external-format external-format)))
  51
  52 (defmacro %close-on-error ((obj) &body body)
  53   (with-unique-names (flag)
  54     `(let ((,flag t))
  55        (unwind-protect (multiple-value-prog1 (progn ,@body) (setf ,flag nil))
  56          (when (and ,obj ,flag) (close ,obj :abort t))))))
  57
  58 (defun convert-or-lookup-inet-address (address &optional (ipv6 *ipv6*))
  59   "If ADDRESS is an inet-address designator, it is converted, if
  60 necessary, to an INET-ADDRESS object and returned.  Otherwise it
  61 is assumed to be a host name which is then looked up in order to
  62 return its primary address as the first return value and the
  63 remaining address list as the second return value."
  64   (or (ignore-errors (ensure-address address :internet))
  65       (let ((addresses (host-addresses (lookup-host address :ipv6 ipv6))))
  66         (values (car addresses) (cdr addresses)))))
  67
  68 (declaim (inline %make-internet-stream-socket))
  69 (defun %make-internet-stream-socket (args connect ef)
  70   (let (socket address)
  71     (destructuring-bind (&key local-host local-port remote-host remote-port
  72                               backlog reuse-address keepalive nodelay family)
  73         args
  74       (ecase connect
  75         (:active
  76          (assert (xnor remote-host remote-port))
  77          (%close-on-error (socket)
  78            (setf socket (create-socket :family family :type :stream
  79                                        :connect :active :external-format ef))
  80            (when keepalive (set-socket-option socket :keep-alive :value t))
  81            (when nodelay (set-socket-option socket :tcp-nodelay :value t))
  82            (when local-host
  83              (setf address (convert-or-lookup-inet-address local-host))
  84              (bind-address socket address :port (or local-port 0)
  85                            :reuse-address reuse-address))
  86            (when remote-host
  87              (setf address (convert-or-lookup-inet-address remote-host))
  88              (connect socket address :port remote-port))))
  89         (:passive
  90          (%close-on-error (socket)
  91            (setf socket (create-socket :family family :type :stream
  92                                        :connect :passive :external-format ef))
  93            (when local-host
  94              (setf address (convert-or-lookup-inet-address local-host))
  95              (bind-address socket address :port (or local-port 0)
  96                            :reuse-address reuse-address)
  97              (socket-listen socket :backlog backlog))))))
  98     (values socket)))
  99
 100 (declaim (inline %make-local-stream-socket))
 101 (defun %make-local-stream-socket (args connect ef)
 102   (let (socket)
 103     (destructuring-bind (&key local-filename remote-filename backlog family)
 104         args
 105       (ecase connect
 106         (:active
 107          (assert remote-filename)
 108          (%close-on-error (socket)
 109            (setf socket (create-socket :family family :type :stream
 110                                        :connect :active :external-format ef))
 111            (when local-filename
 112              (bind-address socket (make-address local-filename)))
 113            (connect socket (make-address remote-filename))))
 114         (:passive
 115          (assert local-filename)
 116          (%close-on-error (socket)
 117            (setf socket (create-socket :family family :type :stream
 118                                        :connect :passive
 119                                        :external-format ef))
 120            (bind-address socket (make-address local-filename))
 121            (socket-listen socket :backlog backlog)))))
 122     (values socket)))
 123
 124 (declaim (inline %make-internet-datagram-socket))
 125 (defun %make-internet-datagram-socket (args ef)
 126   (let (socket address)
 127     (destructuring-bind (&key local-host local-port remote-host remote-port
 128                               reuse-address broadcast family)
 129         args
 130       (assert (xnor local-host local-port))
 131       (assert (xnor remote-host remote-port))
 132       (%close-on-error (socket)
 133         (setf socket (create-socket :family family :type :datagram
 134                                     :connect :active :external-format ef))
 135         (when broadcast (set-socket-option socket :broadcast :value t))
 136         (when local-host
 137           (setf address (convert-or-lookup-inet-address local-host))
 138           (bind-address socket address :port local-port
 139                         :reuse-address reuse-address))
 140         (when remote-host
 141           (setf address (convert-or-lookup-inet-address remote-host))
 142           (connect socket address :port remote-port))))
 143     (values socket)))
 144
 145 (declaim (inline %make-local-datagram-socket))
 146 (defun %make-local-datagram-socket (args ef)
 147   (let (socket address)
 148     (destructuring-bind (&key local-filename remote-filename family) args
 149       (%close-on-error (socket)
 150         (setf socket (create-socket :family family :type :datagram
 151                                     :connect :active :external-format ef))
 152         (when local-filename
 153           (bind-address socket (make-address address)))
 154         (when remote-filename
 155           (connect socket (make-address address)))))
 156     (values socket)))
 157
 158 ;;; Changed ADDRESS-FAMILY to FAMILY and accept :IPV4 and :IPV6 as
 159 ;;; arguments so we can create an IPv4 socket with
 160 ;;;   (make-socket :family :ipv4)
 161 ;;; instead of
 162 ;;;   (make-socket #|:family :internet|# :ipv6 nil)
 163 ;;; This is not compatible with Allegro's MAKE-SOCKET behaviour.
 164 ;;; Is the renaming and the acceptance of extra values a problem?
 165 ;;; (We need to be careful with *IPV6* for starters.)
 166 (defun make-socket (&rest args &key (family :internet) (type :stream)
 167                     (connect :active) (ipv6 *ipv6*) format eol
 168                     (external-format :default) scope-id &allow-other-keys)
 169   "Creates a socket instance of the appropriate subclass of SOCKET."
 170   (declare (ignore format eol scope-id))
 171   (check-type family (member :internet :local :ipv4 :ipv6))
 172   (check-type type (member :stream :datagram))
 173   (check-type connect (member :active :passive))
 174   (remf args :ipv6)
 175   (remf args :external-format)
 176   (remf args :type)
 177   (remf args :connect)
 178   (let ((*ipv6* (if (eq family :ipv4) nil ipv6))
 179         (address-family (if (or (eq family :ipv4) (eq family :ipv6))
 180                             :internet
 181                             family)))
 182     (cond
 183       ((and (eq address-family :internet) (eq type :stream))
 184        (%make-internet-stream-socket args connect external-format))
 185       ((and (eq address-family :local) (eq type :stream))
 186        (%make-local-stream-socket args connect external-format))
 187       ((and (eq address-family :internet) (eq type :datagram))
 188        (%make-internet-datagram-socket args external-format))
 189       ((and (eq address-family :local) (eq type :datagram))
 190        (%make-local-datagram-socket args external-format)))))
 191
 192 (defmacro with-socket ((var &rest args) &body body)
 193   "VAR is bound to a socket created by passing ARGS to
 194 MAKE-SOCKET and BODY is executed as implicit PROGN.  The socket
 195 is automatically closed upon exit."
 196   `(with-open-stream (,var (make-socket ,@args)) ,@body))