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 ;;;; Get Helpers
  79
  80 (defun get-socket-option-bool (fd level option)
  81   (with-foreign-object (optval :int)
  82     (with-socklen (optlen size-of-int)
  83       (getsockopt fd level option optval optlen)
  84       (mem-ref optval :boolean))))
  85
  86 (defun get-socket-option-int (fd level option)
  87   (with-foreign-object (optval :int)
  88     (with-socklen (optlen size-of-int)
  89       (getsockopt fd level option optval optlen)
  90       (mem-ref optval :int))))
  91
  92 (defun get-socket-option-linger (fd level option)
  93   (with-foreign-object (optval 'linger)
  94     (with-socklen (optlen size-of-linger)
  95       (getsockopt fd level option optval optlen)
  96       (with-foreign-slots ((linger onoff) optval linger)
  97         (values (not (zerop onoff)) linger)))))
  98
  99 (defun get-socket-option-timeval (fd level option)
 100   (with-foreign-object (optval 'nix::timeval)
 101     (with-socklen (optlen nix::size-of-timeval)
 102       (getsockopt fd level option optval optlen)
 103       (with-foreign-slots ((nix::sec nix::usec) optval nix::timeval)
 104         (values nix::sec nix::usec)))))
 105
 106 ;;;; Option Definitions
 107
 108 (eval-when (:compile-toplevel :load-toplevel :execute)
 109   (defvar +helper-args-map+
 110     '((:bool (value))
 111       (:int (value))
 112       (:linger (onoff linger))
 113       (:timeval (sec usec)))))
 114
 115 (defmacro define-get-sockopt (os eql-name helper-get level optname)
 116   `(defmethod get-socket-option ((socket socket) (option-name (eql ,eql-name)))
 117      ,(if (or (eq os :any) (featurep os))
 118           `(,helper-get (socket-fd socket) ,level ,optname)
 119           `(error 'option-not-available option-name))))
 120
 121 (defmacro define-set-sockopt (os eql-name args helper-set level optname)
 122   `(defmethod set-socket-option
 123        ((socket socket) (option-name (eql ,eql-name)) &key ,@args)
 124      ,@(if (or (eq os :any) (featurep os))
 125            `((,helper-set (socket-fd socket) ,level ,optname ,@args))
 126            `((declare (ignore ,@args))
 127              (error 'option-not-available option-name)))))
 128
 129 (defmacro define-socket-option (name action optname level argtype os)
 130   (declare (type symbol action)
 131            (type symbol argtype)
 132            (type (or symbol list) os))
 133   (flet ((make-helper-name (action value-type)
 134            (format-symbol t "~A~A~A"
 135                           action '#:-socket-option- value-type)))
 136     (let ((eql-name (make-keyword name))
 137           (args (second (assoc argtype +helper-args-map+)))
 138           (helper-get (make-helper-name :get argtype))
 139           (helper-set (make-helper-name :set argtype)))
 140       `(progn
 141          ,@(remove-if
 142             #'null
 143             (list
 144              (when (member action (list :get :get-and-set))
 145                `(define-get-sockopt ,os ,eql-name ,helper-get ,level ,optname))
 146              (when (member action (list :set :get-and-set))
 147                `(define-set-sockopt ,os ,eql-name ,args ,helper-set ,level
 148                                     ,optname))))))))
 149
 150 (defmacro define-socket-options (action level os &body options)
 151   `(progn
 152      ,@(loop :for (name optname argtype) :in options :collect
 153              `(define-socket-option ,name ,action
 154                 ,optname ,level ,argtype ,os))))
 155
 156 ;;;; Generic options
 157
 158 (define-socket-options :get sol-socket :any
 159   (accept-connections so-acceptconn :bool)
 160   (error              so-error      :int)
 161   (type               so-type       :int))
 162
 163 (define-socket-options :get-and-set sol-socket :any
 164   (broadcast         so-broadcast :bool)
 165   (debug             so-debug     :bool)
 166   (dont-route        so-dontroute :bool)
 167   (keep-alive        so-keepalive :bool)
 168   (linger            so-linger    :linger)
 169   (oob-inline        so-oobinline :bool)
 170   (receive-buffer    so-rcvbuf    :int)
 171   (send-buffer       so-sndbuf    :int)
 172   (receive-low-water so-rcvlowat  :int)
 173   (send-low-water    so-sndlowat  :int)
 174   (receive-timeout   so-rcvtimeo  :timeval)
 175   (send-timeout      so-sndtimeo  :timeval)
 176   (reuse-address     so-reuseaddr :bool))
 177
 178 ;;;; Linux-specific Options
 179
 180 (define-socket-options :set sol-socket :linux
 181   (bsd-compatible so-bsdcompat    :bool)
 182   (bind-to-device so-bindtodevice :int))
 183
 184 (define-socket-option priority :get-and-set
 185   so-priority sol-socket :int :linux)
 186
 187 ;;;; FreeBSD-specific options
 188
 189 (define-socket-options :get-and-set sol-socket :freebsd
 190   (reuse-port   so-reuseport   :bool)
 191   (use-loopback so-useloopback :bool)
 192   (no-sigpipe   so-nosigpipe   :bool))
 193
 194 ;;;; TODO
 195
 196 ;; TODO: implement "struct ucred" helpers
 197
 198 ;; (define-socket-option pass-credentials   :get-and-set et:so-passcred     et:sol-socket :ucred   (:or :linux :freebsd))
 199 ;; (define-socket-option peer-credentials   :get         et:so-peercred     et:sol-socket :ucred   (:or :linux :freebsd))
 200
 201
 202 ;; TODO: implement "struct accept_filter_arg" helpers
 203
 204 ;; (define-socket-option accept-filter      :get-and-set et:so-acceptfilter et:sol-socket :accept-filter :freebsd)
 205
 206 ;; TODO: find out the types of these options
 207
 208 ;; (define-socket-option bintime            :get-and-set et:so-bintime      et:sol-socket :bool    :freebsd)
 209 ;; (define-socket-option label              :get-and-set et:so-label        et:sol-socket :bool    :freebsd)
 210 ;; (define-socket-option peerlabel          :get-and-set et:so-peerlabel    et:sol-socket :bool    :freebsd)
 211 ;; (define-socket-option listen-queue-limit :get-and-set et:so-listenqlimit et:sol-socket :int     :freebsd)
 212 ;; (define-socket-option listen-queue-length :get-and-set et:so-listenqlen  et:sol-socket :int     :freebsd)
 213 ;; (define-socket-option listen-incomplete-queue-length :get-and-set et:so-listenincqlen  et:sol-socket :int :freebsd)
 214
 215
 216 ;;;; TCP Options
 217
 218 (define-socket-option tcp-nodelay :get-and-set
 219   tcp-nodelay ipproto-tcp :bool :any)
 220
 221 (define-socket-option tcp-maxseg :get-and-set
 222   tcp-maxseg ipproto-tcp :int (:or :linux :freebsd))
 223
 224 ;;;; Linux-specific TCP Options
 225
 226 (define-socket-options :get-and-set ipproto-tcp :linux
 227   (tcp-cork         tcp-cork         :bool)
 228   (tcp-defer-accept tcp-defer-accept :int)
 229   (tcp-keepcnt      tcp-keepcnt      :int)
 230   (tcp-keepidle     tcp-keepidle     :int)
 231   (tcp-keepintvl    tcp-keepintvl    :int)
 232   (tcp-linger2      tcp-linger2      :int)
 233   (tcp-quickack     tcp-quickack     :bool)
 234   (tcp-syncnt       tcp-syncnt       :int)
 235   (tcp-window-clamp tcp-window-clamp :int))
 236
 237 ;; TODO: implement "struct tcp_info" helper
 238 ;; (define-socket-option tcp-info         :get         et::tcp-info         et:ipproto-tcp :tcp-info :linux)
 239
 240 ;;;; FreeBSD-specific TCP Options
 241
 242 (define-socket-options :get-and-set ipproto-tcp :freebsd
 243   (tcp-noopt  tcp-noopt  :bool)
 244   (tcp-nopush tcp-nopush :bool))