sockets/make-socket.lisp

   1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
   2
   3 ;;   Copyright (C) 2006, 2007 Stelian Ionescu
   4 ;;
   5 ;;   This code is free software; you can redistribute it and/or
   6 ;;   modify it under the terms of the version 2.1 of
   7 ;;   the GNU Lesser General Public License as published by
   8 ;;   the Free Software Foundation, as clarified by the
   9 ;;   preamble found here:
  10 ;;       http://opensource.franz.com/preamble.html
  11 ;;
  12 ;;   This program is distributed in the hope that it will be useful,
  13 ;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;   GNU General Public License for more details.
  16 ;;
  17 ;;   You should have received a copy of the GNU Lesser General
  18 ;;   Public License along with this library; if not, write to the
  19 ;;   Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  20 ;;   Boston, MA 02110-1301, USA
  21
  22 (in-package :net.sockets)
  23
  24 (defun create-socket (&key
  25                       (address-family :internet)
  26                       (type :stream)
  27                       (connect :active)
  28                       (protocol :default)
  29                       (ipv6 *ipv6*)
  30                       (external-format :default))
  31   (check-type address-family (member :internet :local))
  32   (check-type type (member :stream :datagram))
  33   (check-type connect (member :active :passive))
  34   (check-type ipv6 (member nil t :ipv6))
  35   (when (eq address-family :internet)
  36     (setf address-family (if ipv6 :ipv6 :ipv4)))
  37   (let ((socket-class
  38          (select-socket-type address-family type connect protocol)))
  39     (make-instance socket-class :family address-family
  40                    :external-format external-format)))
  41
  42 (defmacro %close-on-error ((obj) &body body)
  43   (with-gensyms ($flag$)
  44     `(let ((,$flag$ t))
  45        (unwind-protect (multiple-value-prog1 (progn ,@body) (setf ,$flag$ nil))
  46          (when (and ,obj ,$flag$) (close ,obj :abort t))))))
  47
  48 (declaim (inline %make-internet-stream-socket))
  49 (defun %make-internet-stream-socket (args connect ipv6 ef)
  50   (let (socket address)
  51     (destructuring-bind (&key local-host local-port remote-host remote-port
  52                               backlog reuse-address keepalive nodelay &allow-other-keys) args
  53       (ecase connect
  54         (:active
  55          (assert (xnor local-host local-port))
  56          (assert (xnor remote-host remote-port))
  57          (%close-on-error (socket)
  58            (setf socket (create-socket :address-family :internet :type :stream
  59                                        :connect :active :ipv6 ipv6
  60                                        :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              (setf address (convert-or-lookup-inet-address local-host ipv6))
  65              (bind-address socket address :port local-port
  66                            :reuse-address reuse-address))
  67            (when remote-host
  68              (setf address (convert-or-lookup-inet-address remote-host ipv6))
  69              (connect socket address :port remote-port))))
  70         (:passive
  71          (assert (xnor local-host local-port))
  72          (%close-on-error (socket)
  73            (setf socket (create-socket :address-family :internet :type :stream
  74                                        :connect :passive :ipv6 ipv6
  75                                        :external-format ef))
  76            (when local-host
  77              (setf address (convert-or-lookup-inet-address local-host ipv6))
  78              (bind-address socket address :port local-port
  79                            :reuse-address reuse-address)
  80              (socket-listen socket :backlog backlog))))))
  81     (values socket)))
  82
  83 (declaim (inline %make-local-stream-socket))
  84 (defun %make-local-stream-socket (args connect ef)
  85   (let (socket)
  86     (destructuring-bind (&key local-filename remote-filename backlog &allow-other-keys) args
  87       (ecase connect
  88         (:active
  89          (assert remote-filename)
  90          (%close-on-error (socket)
  91            (setf socket (create-socket :address-family :local :type :stream
  92                                        :connect :active :external-format ef))
  93            (when local-filename (bind-address socket (make-address local-filename)))
  94            (connect socket (make-address remote-filename))))
  95         (:passive
  96          (assert local-filename)
  97          (%close-on-error (socket)
  98            (setf socket (create-socket :address-family :local :type :stream
  99                                        :connect :passive
 100                                        :external-format ef))
 101            (bind-address socket (make-address local-filename))
 102            (socket-listen socket :backlog backlog)))))
 103     (values socket)))
 104
 105 (declaim (inline %make-internet-datagram-socket))
 106 (defun %make-internet-datagram-socket (args ipv6 ef)
 107   (let (socket address)
 108     (destructuring-bind (&key local-host local-port remote-host remote-port
 109                               reuse-address broadcast &allow-other-keys) args
 110       (assert (xnor local-host local-port))
 111       (assert (xnor remote-host remote-port))
 112       (%close-on-error (socket)
 113         (setf socket (create-socket :address-family :internet :type :datagram
 114                                     :connect :active :ipv6 ipv6
 115                                     :external-format ef))
 116         (when broadcast (set-socket-option socket :broadcast :value t))
 117         (when local-host
 118           (setf address (convert-or-lookup-inet-address local-host ipv6))
 119           (bind-address socket address :port local-port
 120                         :reuse-address reuse-address))
 121         (when remote-host
 122           (setf address (convert-or-lookup-inet-address remote-host ipv6))
 123           (connect socket address :port remote-port))))
 124     (values socket)))
 125
 126 (declaim (inline %make-local-datagram-socket))
 127 (defun %make-local-datagram-socket (args ef)
 128   (let (socket address)
 129     (destructuring-bind (&key local-filename remote-filename &allow-other-keys) args
 130       (%close-on-error (socket)
 131         (setf socket (create-socket :address-family :local :type :datagram
 132                                     :connect :active :external-format ef))
 133         (when local-filename
 134           (bind-address socket (make-address address)))
 135         (when remote-filename
 136           (connect socket (make-address address)))))
 137     (values socket)))
 138
 139 (defun make-socket (&rest args &key address-family type connect (ipv6 *ipv6*)
 140                     format eol (external-format :default) scope-id &allow-other-keys)
 141   (declare (ignore format eol scope-id))
 142   (check-type address-family (member :internet :local))
 143   (check-type type (member :stream :datagram))
 144   (check-type connect (member :active :passive))
 145   (check-type ipv6 (member nil t :ipv6))
 146   (cond
 147     ((and (eq address-family :internet) (eq type :stream))
 148      (%make-internet-stream-socket args connect ipv6 external-format))
 149     ((and (eq address-family :local) (eq type :stream))
 150      (%make-local-stream-socket args connect external-format))
 151     ((and (eq address-family :internet) (eq type :datagram))
 152      (%make-internet-datagram-socket args ipv6 external-format))
 153     ((and (eq address-family :local) (eq type :datagram))
 154      (%make-local-datagram-socket args external-format))))
 155
 156 (defmacro with-socket ((var &rest args) &body body)
 157   "`VAR' is bound to a socket created by passing `ARGS' to MAKE-SOCKET
 158 and `BODY' is executed as implicit PROGN. The socket is automatically closed upon exit."
 159   `(with-open-stream (,var (make-socket ,@args)) ,@body))