net.sockets/socket-options.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Setter and getters for various socket options.
   4 ;;;
   5
   6 (in-package :net.sockets)
   7
   8 ;;;; Macrology
   9
  10 (eval-when (:compile-toplevel :load-toplevel :execute)
  11   (defvar *socket-option-types* (make-hash-table :test #'eq))
  12   (defvar *set-socket-options* (make-hash-table :test #'eq))
  13   (defun socktype-args (type)
  14     (first (gethash type *socket-option-types*)))
  15   (defun socktype-getter (type)
  16     (second (gethash type *socket-option-types*)))
  17   (defun socktype-setter (type)
  18     (third (gethash type *socket-option-types*))))
  19
  20 (defmacro define-socket-option-type (name args)
  21   (flet ((make-helper-name (action value-type)
  22            (format-symbol t "~A~A~A"
  23                           action '#:-socket-option- value-type)))
  24     `(eval-when (:compile-toplevel :load-toplevel :execute)
  25        (setf (gethash ,name *socket-option-types*)
  26              (list ',args
  27                    ',(make-helper-name :get name)
  28                    ',(make-helper-name :set name))))))
  29
  30 (defmacro define-socket-option-helper (helper args &body body)
  31   (destructuring-bind (action type) helper
  32     (assert (gethash type *socket-option-types*))
  33     (assert (= (length args)
  34                (+ 3 (ecase action
  35                       (:get 0)
  36                       (:set (length (socktype-args type)))))))
  37     (multiple-value-bind (forms decls) (parse-body body)
  38       `(defun ,(ecase action
  39                       (:get (socktype-getter type))
  40                       (:set (socktype-setter type)))
  41            ,args ,decls ,@forms))))
  42
  43 (defmacro define-get-sockopt (os name type level optname)
  44   `(defmethod socket-option ((socket socket) (option-name (eql ,name)))
  45      (declare (ignorable socket option-name))
  46      ,(if (or (eq :any os) (featurep os))
  47           (let ((getter (socktype-getter type)))
  48             `(,getter (fd-of socket) ,level ,optname))
  49           `(error 'socket-option-not-supported-error
  50                   :message ,(format nil "Unsupported socket option: ~S" name)))))
  51
  52 (defmacro define-set-sockopt (os name type level optname)
  53   (when (or (eq :any os) (featurep os))
  54     `(setf (gethash ,name *set-socket-options*)
  55            (list ,type ,level ,optname))))
  56
  57 (define-setf-expander socket-option (socket option-name &key (if-does-not-exist :error))
  58   (flet ((%make-arglist (type-args expanded-args)
  59            (mapcar (lambda (targ earg)
  60                      (if (consp targ)
  61                          `(or ,earg ,(cadr targ))
  62                          earg))
  63                    type-args expanded-args)))
  64     (if-let (data (gethash option-name *set-socket-options*))
  65             (destructuring-bind (type level optname) data
  66               (let ((glist (make-gensym-list (length (socktype-args type)))))
  67                 (values nil nil glist
  68                         `(,(socktype-setter type)
  69                            (fd-of ,socket) ,level ,optname
  70                            ,@(%make-arglist (socktype-args type) glist))
  71                         socket)))
  72             (values nil nil nil
  73                     (case if-does-not-exist
  74                       (:error
  75                        `(error 'socket-option-not-supported-error
  76                                :message ,(format nil "Unsupported socket option: ~S"
  77                                                  option-name)))
  78                       (nil nil))))))
  79
  80 (defmacro define-socket-option (name action optname level argtype os)
  81   (let ((eql-name (make-keyword name)))
  82     `(progn
  83        ,(when (member action (list :get :get-and-set))
  84           `(define-get-sockopt ,os ,eql-name ,argtype ,level ,optname))
  85        ,(when (member action (list :set :get-and-set))
  86           `(define-set-sockopt ,os ,eql-name ,argtype ,level ,optname)))))
  87
  88 (defmacro define-socket-options (action level os &body options)
  89   `(progn
  90      ,@(loop :for (name optname argtype) :in options :collect
  91              `(define-socket-option ,name ,action
  92                 ,optname ,level ,argtype ,os))))
  93 \f
  94 ;;;; Types
  95
  96 ;;; BOOL
  97
  98 (define-socket-option-type :bool (value))
  99
 100 (define-socket-option-helper (:get :bool) (fd level option)
 101   (with-foreign-object (optval :int)
 102     (with-socklen (optlen size-of-int)
 103       (%getsockopt fd level option optval optlen)
 104       (mem-aref optval :boolean))))
 105
 106 (define-socket-option-helper (:set :bool) (fd level option value)
 107   (with-foreign-object (optval :int)
 108     (setf (mem-aref optval :int) (lisp->c-bool value))
 109     (%setsockopt fd level option optval size-of-int)
 110     (values value)))
 111
 112 ;;; INT
 113
 114 (define-socket-option-type :int (value))
 115
 116 (define-socket-option-helper (:get :int) (fd level option)
 117   (with-foreign-object (optval :int)
 118     (with-socklen (optlen size-of-int)
 119       (%getsockopt fd level option optval optlen)
 120       (mem-aref optval :int))))
 121
 122 (define-socket-option-helper (:set :int) (fd level option value)
 123   (with-foreign-object (optval :int)
 124     (setf (mem-aref optval :int) value)
 125     (%setsockopt fd level option optval size-of-int)
 126     (values value)))
 127
 128 ;;; LINGER
 129
 130 (define-socket-option-type :linger (onoff (linger *default-linger-seconds*)))
 131
 132 (define-socket-option-helper (:get :linger) (fd level option)
 133   (with-foreign-object (optval 'linger)
 134     (with-socklen (optlen size-of-linger)
 135       (%getsockopt fd level option optval optlen)
 136       (with-foreign-slots ((linger onoff) optval linger)
 137         (values (not (zerop onoff)) linger)))))
 138
 139 (define-socket-option-helper (:set :linger) (fd level option new-onoff new-linger)
 140   (with-foreign-object (optval 'linger)
 141     (with-foreign-slots ((linger onoff) optval linger)
 142       (setf onoff (lisp->c-bool new-onoff)
 143             linger new-linger))
 144     (%setsockopt fd level option optval size-of-linger)
 145     (values new-onoff new-linger)))
 146
 147 ;;; TIMEVAL
 148
 149 (define-socket-option-type :timeval (sec))
 150
 151 (define-socket-option-helper (:get :timeval) (fd level option)
 152   (with-foreign-object (optval 'timeval)
 153     (with-socklen (optlen size-of-timeval)
 154       (%getsockopt fd level option optval optlen)
 155       (with-foreign-slots ((sec usec) optval timeval)
 156         (values sec usec)))))
 157
 158 (define-socket-option-helper (:set :timeval) (fd level option new-sec)
 159   (with-foreign-object (optval 'timeval)
 160     (with-foreign-slots ((sec usec) optval timeval)
 161       (setf (values sec usec) (decode-timeout new-sec)))
 162     (%setsockopt fd level option optval size-of-timeval)
 163     (values new-sec)))
 164
 165 ;;; IFREQ-NAME
 166
 167 (define-socket-option-type :ifreq-name (value))
 168
 169 #+linux
 170 (define-socket-option-helper (:set :ifreq-name) (fd level option interface)
 171   (with-foreign-object (optval 'ifreq)
 172     (nix:bzero optval size-of-ifreq)
 173     (with-foreign-slots ((name) optval ifreq)
 174       (with-foreign-string (ifname interface)
 175         (nix:memcpy name ifname (min (length interface) (1- ifnamsiz)))))
 176     (%setsockopt fd level option optval size-of-ifreq)
 177     (values interface)))
 178 \f
 179 ;;;; Option Definitions
 180
 181 ;;; Generic options
 182
 183 (define-socket-options :get sol-socket :any
 184   (accept-connections so-acceptconn :bool)
 185   (error              so-error      :int)
 186   (type               so-type       :int))
 187
 188 (define-socket-options :get-and-set sol-socket :any
 189   (broadcast         so-broadcast :bool)
 190   (debug             so-debug     :bool)
 191   (dont-route        so-dontroute :bool)
 192   (keep-alive        so-keepalive :bool)
 193   (linger            so-linger    :linger)
 194   (oob-inline        so-oobinline :bool)
 195   (receive-buffer    so-rcvbuf    :int)
 196   (send-buffer       so-sndbuf    :int)
 197   (receive-low-water so-rcvlowat  :int)
 198   (send-low-water    so-sndlowat  :int)
 199   (receive-timeout   so-rcvtimeo  :timeval)
 200   (send-timeout      so-sndtimeo  :timeval)
 201   (reuse-address     so-reuseaddr :bool))
 202
 203 ;;; Linux-specific Options
 204
 205 (define-socket-options :set sol-socket :linux
 206   (bind-to-device so-bindtodevice :ifreq-name))
 207
 208 (define-socket-option priority :get-and-set
 209   so-priority sol-socket :int :linux)
 210
 211 ;;; FreeBSD-specific options
 212
 213 (define-socket-options :get-and-set sol-socket :freebsd
 214   (reuse-port   so-reuseport   :bool)
 215   (use-loopback so-useloopback :bool)
 216   (no-sigpipe   so-nosigpipe   :bool))
 217
 218 ;;; TODO
 219
 220 ;; TODO: implement "struct ucred" helpers
 221
 222 ;; (define-socket-option pass-credentials   :get-and-set et:so-passcred     et:sol-socket :ucred   (:or :linux :freebsd))
 223 ;; (define-socket-option peer-credentials   :get         et:so-peercred     et:sol-socket :ucred   (:or :linux :freebsd))
 224
 225
 226 ;; TODO: implement "struct accept_filter_arg" helpers
 227
 228 ;; (define-socket-option accept-filter      :get-and-set et:so-acceptfilter et:sol-socket :accept-filter :freebsd)
 229
 230 ;; TODO: find out the types of these options
 231
 232 ;; (define-socket-option bintime            :get-and-set et:so-bintime      et:sol-socket :bool    :freebsd)
 233 ;; (define-socket-option label              :get-and-set et:so-label        et:sol-socket :bool    :freebsd)
 234 ;; (define-socket-option peerlabel          :get-and-set et:so-peerlabel    et:sol-socket :bool    :freebsd)
 235 ;; (define-socket-option listen-queue-limit :get-and-set et:so-listenqlimit et:sol-socket :int     :freebsd)
 236 ;; (define-socket-option listen-queue-length :get-and-set et:so-listenqlen  et:sol-socket :int     :freebsd)
 237 ;; (define-socket-option listen-incomplete-queue-length :get-and-set et:so-listenincqlen  et:sol-socket :int :freebsd)
 238
 239
 240 ;;; TCP Options
 241
 242 (define-socket-option tcp-nodelay :get-and-set
 243   tcp-nodelay ipproto-tcp :bool :any)
 244
 245 (define-socket-option tcp-maxseg :get-and-set
 246   tcp-maxseg ipproto-tcp :int (:or :linux :freebsd))
 247
 248 ;;; Linux-specific TCP Options
 249
 250 (define-socket-options :get-and-set ipproto-tcp :linux
 251   (tcp-cork         tcp-cork         :bool)
 252   (tcp-defer-accept tcp-defer-accept :int)
 253   (tcp-keepcnt      tcp-keepcnt      :int)
 254   (tcp-keepidle     tcp-keepidle     :int)
 255   (tcp-keepintvl    tcp-keepintvl    :int)
 256   (tcp-linger2      tcp-linger2      :int)
 257   (tcp-quickack     tcp-quickack     :bool)
 258   (tcp-syncnt       tcp-syncnt       :int)
 259   (tcp-window-clamp tcp-window-clamp :int))
 260
 261 ;; TODO: implement "struct tcp_info" helper
 262 ;; (define-socket-option tcp-info         :get         et::tcp-info         et:ipproto-tcp :tcp-info :linux)
 263
 264 ;;; FreeBSD-specific TCP Options
 265
 266 (define-socket-options :get-and-set ipproto-tcp :freebsd
 267   (tcp-noopt  tcp-noopt  :bool)
 268   (tcp-nopush tcp-nopush :bool))