src/sockets/make-socket.lisp

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