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