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