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