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   (alexandria: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 (declaim (inline %make-internet-stream-socket))
  59 (defun %make-internet-stream-socket (args connect ef)
  60   (let (socket address)
  61     (destructuring-bind (&key local-host local-port remote-host remote-port
  62                               backlog reuse-address keepalive nodelay family)
  63         args
  64       (ecase connect
  65         (:active
  66          (assert (xnor local-host local-port))
  67          (assert (xnor remote-host remote-port))
  68          (%close-on-error (socket)
  69            (setf socket (create-socket :family family :type :stream
  70                                        :connect :active :external-format ef))
  71            (when keepalive (set-socket-option socket :keep-alive :value t))
  72            (when nodelay (set-socket-option socket :tcp-nodelay :value t))
  73            (when local-host
  74              (setf address (convert-or-lookup-inet-address local-host))
  75              (bind-address socket address :port local-port
  76                            :reuse-address reuse-address))
  77            (when remote-host
  78              (setf address (convert-or-lookup-inet-address remote-host))
  79              (connect socket address :port remote-port))))
  80         (:passive
  81          (assert (xnor local-host local-port))
  82          (%close-on-error (socket)
  83            (setf socket (create-socket :family family :type :stream
  84                                        :connect :passive :external-format ef))
  85            (when local-host
  86              (setf address (convert-or-lookup-inet-address local-host))
  87              (bind-address socket address :port local-port
  88                            :reuse-address reuse-address)
  89              (socket-listen socket :backlog backlog))))))
  90     (values socket)))
  91
  92 (declaim (inline %make-local-stream-socket))
  93 (defun %make-local-stream-socket (args connect ef)
  94   (let (socket)
  95     (destructuring-bind (&key local-filename remote-filename backlog family)
  96         args
  97       (ecase connect
  98         (:active
  99          (assert remote-filename)
 100          (%close-on-error (socket)
 101            (setf socket (create-socket :family family :type :stream
 102                                        :connect :active :external-format ef))
 103            (when local-filename
 104              (bind-address socket (make-address local-filename)))
 105            (connect socket (make-address remote-filename))))
 106         (:passive
 107          (assert local-filename)
 108          (%close-on-error (socket)
 109            (setf socket (create-socket :family family :type :stream
 110                                        :connect :passive
 111                                        :external-format ef))
 112            (bind-address socket (make-address local-filename))
 113            (socket-listen socket :backlog backlog)))))
 114     (values socket)))
 115
 116 (declaim (inline %make-internet-datagram-socket))
 117 (defun %make-internet-datagram-socket (args ef)
 118   (let (socket address)
 119     (destructuring-bind (&key local-host local-port remote-host remote-port
 120                               reuse-address broadcast family)
 121         args
 122       (assert (xnor local-host local-port))
 123       (assert (xnor remote-host remote-port))
 124       (%close-on-error (socket)
 125         (setf socket (create-socket :family family :type :datagram
 126                                     :connect :active :external-format ef))
 127         (when broadcast (set-socket-option socket :broadcast :value t))
 128         (when local-host
 129           (setf address (convert-or-lookup-inet-address local-host))
 130           (bind-address socket address :port local-port
 131                         :reuse-address reuse-address))
 132         (when remote-host
 133           (setf address (convert-or-lookup-inet-address remote-host))
 134           (connect socket address :port remote-port))))
 135     (values socket)))
 136
 137 (declaim (inline %make-local-datagram-socket))
 138 (defun %make-local-datagram-socket (args ef)
 139   (let (socket address)
 140     (destructuring-bind (&key local-filename remote-filename family) args
 141       (%close-on-error (socket)
 142         (setf socket (create-socket :family family :type :datagram
 143                                     :connect :active :external-format ef))
 144         (when local-filename
 145           (bind-address socket (make-address address)))
 146         (when remote-filename
 147           (connect socket (make-address address)))))
 148     (values socket)))
 149
 150 ;;; Changed ADDRESS-FAMILY to FAMILY and accept :IPV4 and :IPV6 as
 151 ;;; arguments so we can create an IPv4 socket with
 152 ;;;   (make-socket :family :ipv4)
 153 ;;; instead of
 154 ;;;   (make-socket #|:family :internet|# :ipv6 nil)
 155 ;;; This is not compatible with Allegro's MAKE-SOCKET behaviour.
 156 ;;; Is the renaming and the acceptance of extra values a problem?
 157 ;;; (We need to be careful with *IPV6* for starters.)
 158 (defun make-socket (&rest args &key (family :internet) (type :stream)
 159                     (connect :active) (ipv6 *ipv6*) format eol
 160                     (external-format :default) scope-id &allow-other-keys)
 161   "Creates a socket instance of the appropriate subclass of SOCKET."
 162   (declare (ignore format eol scope-id))
 163   (check-type family (member :internet :local :ipv4 :ipv6))
 164   (check-type type (member :stream :datagram))
 165   (check-type connect (member :active :passive))
 166   (remf args :ipv6)
 167   (remf args :external-format)
 168   (remf args :type)
 169   (remf args :connect)
 170   (let ((*ipv6* (if (eq family :ipv4) nil ipv6))
 171         (address-family (if (or (eq family :ipv4) (eq family :ipv6))
 172                             :internet
 173                             family)))
 174     (cond
 175       ((and (eq address-family :internet) (eq type :stream))
 176        (%make-internet-stream-socket args connect external-format))
 177       ((and (eq address-family :local) (eq type :stream))
 178        (%make-local-stream-socket args connect external-format))
 179       ((and (eq address-family :internet) (eq type :datagram))
 180        (%make-internet-datagram-socket args external-format))
 181       ((and (eq address-family :local) (eq type :datagram))
 182        (%make-local-datagram-socket args external-format)))))
 183
 184 (defmacro with-socket ((var &rest args) &body body)
 185   "VAR is bound to a socket created by passing ARGS to
 186 MAKE-SOCKET and BODY is executed as implicit PROGN.  The socket
 187 is automatically closed upon exit."
 188   `(with-open-stream (,var (make-socket ,@args)) ,@body))