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