net.sockets/socket-options.lisp

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