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