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-2007, 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 ;;; TODO: manage socket options errors
  27 (defun sockopt-error (retval level option action &optional val1 val2)
  28   (declare (ignore retval level option action val1 val2))
  29   (error "Sockopt error !"))
  30
  31 ;;;; SETF
  32
  33 ;;; This interface looks nice but doesn't work so well for the linger
  34 ;;; and timeout options.  Figure out a good solution.  Possible ones
  35 ;;; include:
  36 ;;;
  37 ;;;    * don't worry, tell the user to use GET/SET-SOCKET-OPTION
  38 ;;;    * socket-linger-option and socket-timeval-option accessors
  39 ;;;    * use separate accessors for each and every option, like
  40 ;;;      SB-BSD-SOCKETS.
  41
  42 (defun socket-option (socket option-name)
  43   (get-socket-option socket option-name))
  44
  45 (defun (setf socket-option) (value socket option-name)
  46   (set-socket-option socket option-name :value value))
  47
  48 ;;;; Set Helpers
  49
  50 (defun set-socket-option-bool (fd level option value)
  51   (with-foreign-object (optval :int)
  52     (setf (mem-ref optval :int) (lisp->c-bool value))
  53     (setsockopt fd level option optval size-of-int)
  54     (values)))
  55
  56 (defun set-socket-option-int (fd level option value)
  57   (with-foreign-object (optval :int)
  58     (setf (mem-ref optval :int) value)
  59     (setsockopt fd level option optval size-of-int)
  60     (values)))
  61
  62 (defun set-socket-option-linger (fd level option new-onoff new-linger)
  63   (with-foreign-object (optval 'linger)
  64     (with-foreign-slots ((linger onoff) optval linger)
  65       (setf onoff (lisp->c-bool new-onoff)
  66             linger new-linger))
  67     (setsockopt fd level option optval size-of-linger)
  68     (values)))
  69
  70 (defun set-socket-option-timeval (fd level option sec usec)
  71   (with-foreign-object (optval 'nix::timeval)
  72     (with-foreign-slots ((nix::sec nix::usec) optval nix::timeval)
  73       (setf nix::sec sec
  74             nix::usec usec))
  75     (setsockopt fd level option optval nix::size-of-timeval)
  76     (values)))
  77
  78 #+linux
  79 (defun set-socket-option-ifreq-name (fd level option interface)
  80   (with-foreign-object (optval 'ifreq)
  81     (nix:bzero optval size-of-ifreq)
  82     (with-foreign-slots ((name) optval ifreq)
  83       (with-foreign-string (ifname interface)
  84         (nix:memcpy name ifname (min (length interface) (1- ifnamsiz)))))
  85     (setsockopt fd level option optval size-of-ifreq)
  86     (values)))
  87
  88 ;;;; Get Helpers
  89
  90 (defun get-socket-option-bool (fd level option)
  91   (with-foreign-object (optval :int)
  92     (with-socklen (optlen size-of-int)
  93       (getsockopt fd level option optval optlen)
  94       (mem-ref optval :boolean))))
  95
  96 (defun get-socket-option-int (fd level option)
  97   (with-foreign-object (optval :int)
  98     (with-socklen (optlen size-of-int)
  99       (getsockopt fd level option optval optlen)
 100       (mem-ref optval :int))))
 101
 102 (defun get-socket-option-linger (fd level option)
 103   (with-foreign-object (optval 'linger)
 104     (with-socklen (optlen size-of-linger)
 105       (getsockopt fd level option optval optlen)
 106       (with-foreign-slots ((linger onoff) optval linger)
 107         (values (not (zerop onoff)) linger)))))
 108
 109 (defun get-socket-option-timeval (fd level option)
 110   (with-foreign-object (optval 'nix::timeval)
 111     (with-socklen (optlen nix::size-of-timeval)
 112       (getsockopt fd level option optval optlen)
 113       (with-foreign-slots ((nix::sec nix::usec) optval nix::timeval)
 114         (values nix::sec nix::usec)))))
 115
 116 ;;;; Option Definitions
 117
 118 (eval-when (:compile-toplevel :load-toplevel :execute)
 119   (defvar +helper-args-map+
 120     '((:bool (value))
 121       (:int (value))
 122       (:linger (onoff linger))
 123       (:timeval (sec (usec 0)))
 124       (:ifreq-name (value)))))
 125
 126 (defmacro define-get-sockopt (os eql-name helper-get level optname)
 127   `(defmethod get-socket-option ((socket socket) (option-name (eql ,eql-name)))
 128      ,(if (or (eq os :any) (featurep os))
 129           `(,helper-get (socket-fd socket) ,level ,optname)
 130           `(error 'option-not-available option-name))))
 131
 132 (defmacro define-set-sockopt (os eql-name args helper-set level optname)
 133   `(defmethod set-socket-option
 134        ((socket socket) (option-name (eql ,eql-name)) &key ,@args)
 135      ,@(if (or (eq os :any) (featurep os))
 136            `((,helper-set (socket-fd socket) ,level ,optname
 137                           ,@(mapcar #'(lambda (c) (if (consp c) (car c) c)) args)))
 138            `((declare (ignore ,@args))
 139              (error 'option-not-available option-name)))))
 140
 141 (defmacro define-socket-option (name action optname level argtype os)
 142   (declare (type symbol action)
 143            (type symbol argtype)
 144            (type (or symbol list) os))
 145   (flet ((make-helper-name (action value-type)
 146            (format-symbol t "~A~A~A"
 147                           action '#:-socket-option- value-type)))
 148     (let ((eql-name (make-keyword name))
 149           (args (second (assoc argtype +helper-args-map+)))
 150           (helper-get (make-helper-name :get argtype))
 151           (helper-set (make-helper-name :set argtype)))
 152       `(progn
 153          ,@(remove-if
 154             #'null
 155             (list
 156              (when (member action (list :get :get-and-set))
 157                `(define-get-sockopt ,os ,eql-name ,helper-get ,level ,optname))
 158              (when (member action (list :set :get-and-set))
 159                `(define-set-sockopt ,os ,eql-name ,args ,helper-set ,level
 160                                     ,optname))))))))
 161
 162 (defmacro define-socket-options (action level os &body options)
 163   `(progn
 164      ,@(loop :for (name optname argtype) :in options :collect
 165              `(define-socket-option ,name ,action
 166                 ,optname ,level ,argtype ,os))))
 167
 168 ;;;; Generic options
 169
 170 (define-socket-options :get sol-socket :any
 171   (accept-connections so-acceptconn :bool)
 172   (error              so-error      :int)
 173   (type               so-type       :int))
 174
 175 (define-socket-options :get-and-set sol-socket :any
 176   (broadcast         so-broadcast :bool)
 177   (debug             so-debug     :bool)
 178   (dont-route        so-dontroute :bool)
 179   (keep-alive        so-keepalive :bool)
 180   (linger            so-linger    :linger)
 181   (oob-inline        so-oobinline :bool)
 182   (receive-buffer    so-rcvbuf    :int)
 183   (send-buffer       so-sndbuf    :int)
 184   (receive-low-water so-rcvlowat  :int)
 185   (send-low-water    so-sndlowat  :int)
 186   (receive-timeout   so-rcvtimeo  :timeval)
 187   (send-timeout      so-sndtimeo  :timeval)
 188   (reuse-address     so-reuseaddr :bool))
 189
 190 ;;;; Linux-specific Options
 191
 192 (define-socket-options :set sol-socket :linux
 193   (bsd-compatible so-bsdcompat    :bool)
 194   (bind-to-device so-bindtodevice :ifreq-name))
 195
 196 (define-socket-option priority :get-and-set
 197   so-priority sol-socket :int :linux)
 198
 199 ;;;; FreeBSD-specific options
 200
 201 (define-socket-options :get-and-set sol-socket :freebsd
 202   (reuse-port   so-reuseport   :bool)
 203   (use-loopback so-useloopback :bool)
 204   (no-sigpipe   so-nosigpipe   :bool))
 205
 206 ;;;; TODO
 207
 208 ;; TODO: implement "struct ucred" helpers
 209
 210 ;; (define-socket-option pass-credentials   :get-and-set et:so-passcred     et:sol-socket :ucred   (:or :linux :freebsd))
 211 ;; (define-socket-option peer-credentials   :get         et:so-peercred     et:sol-socket :ucred   (:or :linux :freebsd))
 212
 213
 214 ;; TODO: implement "struct accept_filter_arg" helpers
 215
 216 ;; (define-socket-option accept-filter      :get-and-set et:so-acceptfilter et:sol-socket :accept-filter :freebsd)
 217
 218 ;; TODO: find out the types of these options
 219
 220 ;; (define-socket-option bintime            :get-and-set et:so-bintime      et:sol-socket :bool    :freebsd)
 221 ;; (define-socket-option label              :get-and-set et:so-label        et:sol-socket :bool    :freebsd)
 222 ;; (define-socket-option peerlabel          :get-and-set et:so-peerlabel    et:sol-socket :bool    :freebsd)
 223 ;; (define-socket-option listen-queue-limit :get-and-set et:so-listenqlimit et:sol-socket :int     :freebsd)
 224 ;; (define-socket-option listen-queue-length :get-and-set et:so-listenqlen  et:sol-socket :int     :freebsd)
 225 ;; (define-socket-option listen-incomplete-queue-length :get-and-set et:so-listenincqlen  et:sol-socket :int :freebsd)
 226
 227
 228 ;;;; TCP Options
 229
 230 (define-socket-option tcp-nodelay :get-and-set
 231   tcp-nodelay ipproto-tcp :bool :any)
 232
 233 (define-socket-option tcp-maxseg :get-and-set
 234   tcp-maxseg ipproto-tcp :int (:or :linux :freebsd))
 235
 236 ;;;; Linux-specific TCP Options
 237
 238 (define-socket-options :get-and-set ipproto-tcp :linux
 239   (tcp-cork         tcp-cork         :bool)
 240   (tcp-defer-accept tcp-defer-accept :int)
 241   (tcp-keepcnt      tcp-keepcnt      :int)
 242   (tcp-keepidle     tcp-keepidle     :int)
 243   (tcp-keepintvl    tcp-keepintvl    :int)
 244   (tcp-linger2      tcp-linger2      :int)
 245   (tcp-quickack     tcp-quickack     :bool)
 246   (tcp-syncnt       tcp-syncnt       :int)
 247   (tcp-window-clamp tcp-window-clamp :int))
 248
 249 ;; TODO: implement "struct tcp_info" helper
 250 ;; (define-socket-option tcp-info         :get         et::tcp-info         et:ipproto-tcp :tcp-info :linux)
 251
 252 ;;;; FreeBSD-specific TCP Options
 253
 254 (define-socket-options :get-and-set ipproto-tcp :freebsd
 255   (tcp-noopt  tcp-noopt  :bool)
 256   (tcp-nopush tcp-nopush :bool))