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