net.sockets/make-socket.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Socket creation.
   4 ;;;
   5
   6 (in-package :net.sockets)
   7
   8 (eval-when (:compile-toplevel :load-toplevel :execute)
   9   (defvar *socket-type-map*
  10     '(((:ipv4  :stream   :active  :default) . socket-stream-internet-active)
  11       ((:ipv6  :stream   :active  :default) . socket-stream-internet-active)
  12       ((:ipv4  :stream   :passive :default) . socket-stream-internet-passive)
  13       ((:ipv6  :stream   :passive :default) . socket-stream-internet-passive)
  14       ((:local :stream   :active  :default) . socket-stream-local-active)
  15       ((:local :stream   :passive :default) . socket-stream-local-passive)
  16       ((:local :datagram :active  :default) . socket-datagram-local-active)
  17       ((:ipv4  :datagram :active  :default) . socket-datagram-internet-active)
  18       ((:ipv6  :datagram :active  :default) . socket-datagram-internet-active)))
  19
  20   ;; FIXME: should match :default to whatever protocol is the default.
  21   (defun select-socket-class (address-family type connect protocol)
  22     (or (cdr (assoc (list address-family type connect protocol) *socket-type-map*
  23                     :test #'equal))
  24         (error "No socket class found !!"))))
  25
  26 (defun create-socket (family type connect external-format &key
  27                       fd input-buffer-size output-buffer-size)
  28   (make-instance (select-socket-class family type connect :default)
  29                  :address-family family :file-descriptor fd
  30                  :external-format external-format
  31                  :input-buffer-size input-buffer-size
  32                  :output-buffer-size output-buffer-size))
  33
  34 (define-compiler-macro create-socket (&whole form family type connect external-format
  35                                       &key fd input-buffer-size output-buffer-size)
  36   (cond
  37     ((and (constantp family) (constantp type) (constantp connect))
  38      `(make-instance ',(select-socket-class family type connect :default)
  39                      :address-family ,family :file-descriptor ,fd
  40                      :external-format ,external-format
  41                      :input-buffer-size ,input-buffer-size
  42                      :output-buffer-size ,output-buffer-size))
  43     (t form)))
  44
  45 (defmacro with-close-on-error ((var value) &body body)
  46   "Bind `VAR' to `VALUE' and execute `BODY' as implicit PROGN.
  47 If a non-local exit occurs during the execution of `BODY',
  48 call CLOSE with :ABORT T on `VAR'."
  49   `(let ((,var ,value))
  50      (unwind-protect-case () ,@body
  51        (:abort (close ,var :abort t)))))
  52
  53 (defmacro %create-internet-socket (family &rest args)
  54   `(case ,family
  55      (:ipv4 (create-socket :ipv4 ,@args))
  56      (:ipv6 (create-socket :ipv6 ,@args))))
  57
  58 (defmacro with-guard-against-non-list-args-and-destructuring-bind-errors
  59     (form args &body body)
  60   `(if (listp ,args)
  61        (handler-case (progn ,@body)
  62          (error (err) `(error ,err)))
  63        ,form))
  64
  65 (eval-when (:compile-toplevel :load-toplevel :execute)
  66   (defun make-first-level-name (family type connect)
  67     (format-symbol :net.sockets "%~A-~A-~A-~A-~A" :make family type connect :socket)))
  68
  69 (defmacro define-socket-creator ((socket-family socket-type socket-connect)
  70                                  (family ef key &rest args) &body body)
  71   (assert (eql '&key key))
  72   (flet ((maybe-quote-default-value (arg)
  73            (cond ((symbolp arg) arg)
  74                  ((consp arg)   (list (first arg) `(quote ,(second arg))))))
  75          (arg-name (arg)
  76            (cond ((symbolp arg) arg)
  77                  ((consp arg)   (first arg))))
  78          (quotify (form)
  79            `(list (quote ,(car form)) ,@(cdr form))))
  80     (let* ((arg-names (mapcar #'arg-name args))
  81            (first-level-function (make-first-level-name socket-family socket-type socket-connect))
  82            (second-level-function (format-symbol t "%~A" first-level-function))
  83            (first-level-body `(,second-level-function family ef ,@arg-names)))
  84       `(progn
  85          (declaim (inline ,second-level-function))
  86          (defun ,second-level-function (,family ,ef ,@arg-names) ,@body)
  87          (defun ,first-level-function (arguments family ef)
  88            (destructuring-bind (&key ,@args) arguments ,first-level-body))
  89          (define-compiler-macro ,first-level-function (&whole form arguments family ef)
  90            (with-guard-against-non-list-args-and-destructuring-bind-errors
  91                form arguments
  92              ;; Must quote default values in order for them not to be evaluated
  93              ;; in the compilation environment
  94              (destructuring-bind (&key ,@(mapcar #'maybe-quote-default-value args))
  95                  (cdr arguments)
  96                ,(quotify first-level-body))))))))
  97 \f
  98 ;;; Internet Stream Active Socket creation
  99
 100 (defun %%init-internet-stream-active-socket (socket keepalive nodelay reuse-address
 101                                              local-host local-port remote-host remote-port)
 102   (let ((local-port  (ensure-numerical-service local-port))
 103         (remote-port (ensure-numerical-service remote-port)))
 104     (setf (socket-option socket :no-sigpipe :if-does-not-exist nil) t)
 105     (when keepalive (setf (socket-option socket :keep-alive) t))
 106     (when nodelay (setf (socket-option socket :tcp-nodelay) t))
 107     (when local-host
 108       (bind-address socket (ensure-hostname local-host)
 109                     :port local-port
 110                     :reuse-address reuse-address))
 111     (when (plusp remote-port)
 112       (connect socket (ensure-hostname remote-host)
 113                :port remote-port)))
 114   (values socket))
 115
 116 (define-socket-creator (:internet :stream :active)
 117     (family ef &key keepalive nodelay (reuse-address t)
 118             local-host (local-port 0)
 119             (remote-host +any-host+) (remote-port 0)
 120             input-buffer-size output-buffer-size)
 121   (with-close-on-error (socket (%create-internet-socket family :stream :active ef
 122                                                         :input-buffer-size input-buffer-size
 123                                                         :output-buffer-size output-buffer-size))
 124     (%%init-internet-stream-active-socket socket keepalive nodelay reuse-address
 125                                           local-host local-port remote-host remote-port)))
 126 \f
 127 ;;; Internet Stream Passive Socket creation
 128
 129 (defun %%init-internet-stream-passive-socket (socket interface reuse-address
 130                                               local-host local-port backlog)
 131   (let ((local-port  (ensure-numerical-service local-port)))
 132     (when local-host
 133       (when interface
 134         (setf (socket-option socket :bind-to-device) interface))
 135       (bind-address socket (ensure-hostname local-host)
 136                     :port local-port
 137                     :reuse-address reuse-address)
 138       (listen-on socket :backlog backlog)))
 139   (values socket))
 140
 141 (define-socket-creator (:internet :stream :passive)
 142     (family ef &key interface (reuse-address t)
 143             (local-host +any-host+) (local-port 0)
 144             (backlog *default-backlog-size*))
 145   (with-close-on-error (socket (%create-internet-socket family :stream :passive ef))
 146     (%%init-internet-stream-passive-socket socket interface reuse-address
 147                                            local-host local-port backlog)))
 148 \f
 149 ;;; Local Stream Active Socket creation
 150
 151 (defun %%init-local-stream-active-socket (socket local-filename remote-filename)
 152   (setf (socket-option socket :no-sigpipe :if-does-not-exist nil) t)
 153   (when local-filename
 154     (bind-address socket (ensure-address local-filename :family :local)))
 155   (when remote-filename
 156     (connect socket (ensure-address remote-filename :family :local)))
 157   (values socket))
 158
 159 (define-socket-creator (:local :stream :active)
 160     (family ef &key local-filename remote-filename
 161             input-buffer-size output-buffer-size)
 162   (declare (ignore family))
 163   (with-close-on-error (socket (create-socket :local :stream :active ef
 164                                               :input-buffer-size input-buffer-size
 165                                               :output-buffer-size output-buffer-size))
 166     (%%init-local-stream-active-socket socket local-filename remote-filename)))
 167 \f
 168 ;;; Local Stream Passive Socket creation
 169
 170 (defun %%init-local-stream-passive-socket (socket local-filename reuse-address backlog)
 171   (when local-filename
 172     (bind-address socket (ensure-address local-filename :family :local)
 173                   :reuse-address reuse-address)
 174     (listen-on socket :backlog backlog))
 175   (values socket))
 176
 177 (define-socket-creator (:local :stream :passive)
 178     (family ef &key local-filename (reuse-address t)
 179             (backlog *default-backlog-size*))
 180   (declare (ignore family))
 181   (with-close-on-error (socket (create-socket :local :stream :passive ef))
 182     (%%init-local-stream-passive-socket socket local-filename reuse-address backlog)))
 183 \f
 184 ;;; Internet Datagram Socket creation
 185
 186 (defun %%init-internet-datagram-active-socket (socket broadcast interface reuse-address
 187                                                local-host local-port remote-host remote-port)
 188   (setf (socket-option socket :no-sigpipe :if-does-not-exist nil) t)
 189   (let ((local-port  (ensure-numerical-service local-port))
 190         (remote-port (ensure-numerical-service remote-port)))
 191     (when broadcast (setf (socket-option socket :broadcast) t))
 192     (when local-host
 193       (bind-address socket (ensure-hostname local-host)
 194                     :port local-port
 195                     :reuse-address reuse-address)
 196       (when interface
 197         (setf (socket-option socket :bind-to-device) interface)))
 198     (when (plusp remote-port)
 199       (connect socket (ensure-hostname remote-host)
 200                :port remote-port)))
 201   (values socket))
 202
 203 (define-socket-creator (:internet :datagram :active)
 204     (family ef &key broadcast interface (reuse-address t)
 205             local-host (local-port 0)
 206             (remote-host +any-host+) (remote-port 0))
 207   (with-close-on-error (socket (%create-internet-socket family :datagram :active ef))
 208     (%%init-internet-datagram-active-socket socket broadcast interface reuse-address
 209                                             local-host local-port remote-host remote-port)))
 210 \f
 211 ;;; Local Datagram Socket creation
 212
 213 (defun %%init-local-datagram-active-socket (socket local-filename remote-filename)
 214   (setf (socket-option socket :no-sigpipe :if-does-not-exist nil) t)
 215   (when local-filename
 216     (bind-address socket (ensure-address local-filename :family :local)))
 217   (when remote-filename
 218     (connect socket (ensure-address remote-filename :family :local)))
 219   (values socket))
 220
 221 (define-socket-creator (:local :datagram :active)
 222     (family ef &key local-filename remote-filename)
 223   (declare (ignore family))
 224   (with-close-on-error (socket (create-socket :local :datagram :active ef))
 225     (%%init-local-datagram-active-socket socket local-filename remote-filename)))
 226 \f
 227 ;;; MAKE-SOCKET
 228
 229 (defun make-socket (&rest args &key (address-family :internet) (type :stream)
 230                     (connect :active) (ipv6 *ipv6*)
 231                     (external-format :default) &allow-other-keys)
 232   "Creates a socket instance of the appropriate subclass of SOCKET."
 233   (check-type address-family (member :internet :local :ipv4 :ipv6) "one of :INTERNET, :LOCAL, :IPV4 or :IPV6")
 234   (check-type type (member :stream :datagram) "either :STREAM or :DATAGRAM")
 235   (check-type connect (member :active :passive) "either :ACTIVE or :PASSIVE")
 236   (let ((args (remove-from-plist args :address-family :type :connect :external-format :ipv6)))
 237     (when (eq :ipv4 address-family) (setf ipv6 nil))
 238     (let ((*ipv6* ipv6))
 239       (when (eq :internet address-family) (setf address-family +default-inet-address-family+))
 240       (multiple-value-case ((address-family type connect))
 241         (((:ipv4 :ipv6) :stream :active)
 242          (%make-internet-stream-active-socket args address-family external-format))
 243         (((:ipv4 :ipv6) :stream :passive)
 244          (%make-internet-stream-passive-socket args address-family external-format))
 245         ((:local :stream :active)
 246          (%make-local-stream-active-socket args :local external-format))
 247         ((:local :stream :passive)
 248          (%make-local-stream-passive-socket args :local external-format))
 249         (((:ipv4 :ipv6) :datagram)
 250          (%make-internet-datagram-active-socket args address-family external-format))
 251         ((:local :datagram)
 252          (%make-local-datagram-active-socket args :local external-format))))))
 253
 254 (define-compiler-macro make-socket (&whole form &rest args &key (address-family :internet) (type :stream)
 255                                     (connect :active) (ipv6 '*ipv6* ipv6p)
 256                                     (external-format :default) &allow-other-keys)
 257   (cond
 258     ((and (constantp address-family) (constantp type) (constantp connect))
 259      (check-type address-family (member :internet :local :ipv4 :ipv6) "one of :INTERNET, :LOCAL, :IPV4 or :IPV6")
 260      (check-type type (member :stream :datagram) "either :STREAM or :DATAGRAM")
 261      (check-type connect (member :active :passive) "either :ACTIVE or :PASSIVE")
 262      (let* ((family (if (member address-family '(:ipv4 :ipv6)) :internet address-family))
 263             (lower-function (make-first-level-name family type connect))
 264             (newargs (remove-from-plist args :address-family :type :connect :external-format :ipv6)))
 265        (case address-family
 266          (:internet (setf address-family '+default-inet-address-family+))
 267          (:ipv4     (setf ipv6 nil ipv6p t)))
 268        (let ((expansion `(,lower-function (list ,@newargs) ,address-family ,external-format)))
 269          (if ipv6p `(let ((*ipv6* ,ipv6)) ,expansion) expansion))))
 270     (t form)))
 271
 272 (defmacro with-open-socket ((var &rest args) &body body)
 273   "VAR is bound to a socket created by passing ARGS to
 274 MAKE-SOCKET and BODY is executed as implicit PROGN.  The socket
 275 is automatically closed upon exit."
 276   `(with-open-stream (,var (make-socket ,@args)) ,@body))
 277
 278 (defmacro with-accept-connection ((var passive-socket &rest args) &body body)
 279   "VAR is bound to a socket created by passing PASSIVE-SOCKET and ARGS to
 280 ACCEPT-CONNECTION and BODY is executed as implicit PROGN.  The socket
 281 is automatically closed upon exit."
 282   `(with-open-stream (,var (accept-connection ,passive-socket ,@args)) ,@body))
 283 \f
 284 ;;; MAKE-SOCKET-FROM-FD
 285
 286 ;;; FIXME: must come up with a way to find out
 287 ;;; whether a socket is active or passive
 288 (defun make-socket-from-fd (fd &key (connect :active) (external-format :default)
 289                             input-buffer-size output-buffer-size)
 290   "Creates an socket instance of the appropriate subclass of SOCKET using `FD'.
 291 The connection type of the socket must be specified(:ACTIVE or :PASSIVE).
 292 The address family and type of the socket is automatically discovered using OS functions. Buffer sizes
 293 for the new socket can also be specified using `INPUT-BUFFER-SIZE' and `OUTPUT-BUFFER-SIZE'."
 294   (flet ((%get-address-family (fd)
 295            (with-sockaddr-storage-and-socklen (ss size)
 296              (%getsockname fd ss size)
 297              (eswitch ((foreign-slot-value ss 'sockaddr-storage 'family) :test #'=)
 298                (af-inet  :ipv4)
 299                (af-inet6 :ipv6)
 300                (af-local :local))))
 301          (%get-type (fd)
 302            (eswitch ((get-socket-option-int fd sol-socket so-type) :test #'=)
 303              (sock-stream :stream)
 304              (sock-dgram  :datagram))))
 305     (create-socket (%get-address-family fd)
 306                    (%get-type fd)
 307                    connect external-format :fd fd
 308                    :input-buffer-size input-buffer-size
 309                    :output-buffer-size output-buffer-size)))
 310 \f
 311 ;;; MAKE-SOCKET-PAIR
 312
 313 (defun make-socket-pair (&key (type :stream) (protocol :default) (external-format :default)
 314                          input-buffer-size output-buffer-size)
 315   "Creates a pair of sockets connected to each other.
 316 The socket type can be either :STREAM or :DATAGRAM. Currently OSes can only create :LOCAL sockets this way.
 317 Buffer sizes for the new sockets can also be specified using `INPUT-BUFFER-SIZE' and `OUTPUT-BUFFER-SIZE'."
 318   (flet ((%make-socket-pair (fd)
 319            (make-socket-from-fd fd :external-format external-format
 320                                 :input-buffer-size input-buffer-size
 321                                 :output-buffer-size output-buffer-size)))
 322     (multiple-value-bind (fd1 fd2)
 323         (multiple-value-call #'%socketpair
 324           (translate-make-socket-keywords-to-constants :local type protocol))
 325       (values (%make-socket-pair fd1)
 326               (%make-socket-pair fd2)))))
 327 \f
 328 ;;; SEND/RECEIVE-FILE-DESCRIPTOR
 329
 330 (defun call-with-buffers-for-fd-passing (fn)
 331   (with-foreign-object (msg 'msghdr)
 332     (bzero msg size-of-msghdr)
 333     (with-foreign-pointer (buffer #.(%cmsg-space size-of-int) buffer-size)
 334       (bzero buffer buffer-size)
 335       (with-foreign-slots ((control controllen) msg msghdr)
 336         (setf control    buffer
 337               controllen buffer-size)
 338         (let ((cmsg (%cmsg-firsthdr msg)))
 339           (with-foreign-slots ((len level type) cmsg cmsghdr)
 340             (setf len (%cmsg-len size-of-int)
 341                   level sol-socket
 342                   type scm-rights)
 343             (funcall fn msg cmsg)))))))
 344
 345 (defmacro with-buffers-for-fd-passing ((msg-var cmsg-var) &body body)
 346   `(call-with-buffers-for-fd-passing (lambda (,msg-var ,cmsg-var) ,@body)))
 347
 348 (defmethod send-file-descriptor ((socket local-socket) file-descriptor)
 349   (with-buffers-for-fd-passing (msg cmsg)
 350     (let ((data (%cmsg-data cmsg)))
 351       (setf (mem-aref data :int) file-descriptor)
 352       (%sendmsg (fd-of socket) msg 0)
 353       (values))))
 354
 355 (defmethod receive-file-descriptor ((socket local-socket))
 356   (with-buffers-for-fd-passing (msg cmsg)
 357     (let ((data (%cmsg-data cmsg)))
 358       (%recvmsg (fd-of socket) msg 0)
 359       (mem-aref data :int))))