sockets/socket-options.lisp

   1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
   2
   3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   4 ;   Copyright (C) 2006,2007 by Stelian Ionescu                            ;
   5 ;                                                                         ;
   6 ;   This program is free software; you can redistribute it and/or modify  ;
   7 ;   it under the terms of the GNU General Public License as published by  ;
   8 ;   the Free Software Foundation; either version 2 of the License, or     ;
   9 ;   (at your option) any later version.                                   ;
  10 ;                                                                         ;
  11 ;   This program is distributed in the hope that it will be useful,       ;
  12 ;   but WITHOUT ANY WARRANTY; without even the implied warranty of        ;
  13 ;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         ;
  14 ;   GNU General Public License for more details.                          ;
  15 ;                                                                         ;
  16 ;   You should have received a copy of the GNU General Public License     ;
  17 ;   along with this program; if not, write to the                         ;
  18 ;   Free Software Foundation, Inc.,                                       ;
  19 ;   51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA              ;
  20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21
  22 ;; (declaim (optimize (speed 2) (safety 2) (space 1) (debug 2)))
  23 (declaim (optimize (speed 0) (safety 2) (space 0) (debug 2)))
  24
  25 (in-package :net.sockets)
  26
  27 ;; TODO: manage socket options errors
  28 (defun sockopt-error (retval level option action &optional val1 val2)
  29   (declare (type symbol action))
  30   (error "Sockopt error !"))
  31
  32 ;;
  33 ;; Set option helpers
  34 ;;
  35
  36 (defun set-socket-option-bool (fd level option value)
  37   (with-foreign-object (optval :int)
  38     (setf (mem-ref optval :int) (lisp->c-bool value))
  39     (et:setsockopt fd level option optval et:size-of-int)
  40     (values)))
  41
  42 (defun set-socket-option-int (fd level option value)
  43   (with-foreign-object (optval :int)
  44     (setf (mem-ref optval :int) value)
  45     (et:setsockopt fd level option optval et:size-of-int)
  46     (values)))
  47
  48 (defun set-socket-option-linger (fd level option onoff linger)
  49   (with-foreign-object (optval 'et:linger)
  50     (with-foreign-slots ((et:linger et:onoff) optval et:linger)
  51       (setf et:onoff (lisp->c-bool onoff)
  52             et:linger linger))
  53     (et:setsockopt fd level option optval et:size-of-linger)
  54     (values)))
  55
  56 (defun set-socket-option-timeval (fd level option sec usec)
  57   (with-foreign-object (optval 'et:timeval)
  58     (with-foreign-slots ((et:tv-sec et:tv-usec) optval et:timeval)
  59       (setf et:tv-sec sec
  60             et:tv-usec usec))
  61     (et:setsockopt fd level option optval et:size-of-timeval)
  62     (values)))
  63
  64 ;;
  65 ;; Get option helpers
  66 ;;
  67
  68 (defun get-socket-option-bool (fd level option)
  69   (with-foreign-objects ((optval :int)
  70                          (optlen :socklen))
  71     (setf (mem-ref optlen :socklen) et:size-of-int)
  72     (et:getsockopt fd level option optval optlen)
  73     (values (c->lisp-bool (mem-ref optval :int)))))
  74
  75 (defun get-socket-option-int (fd level option)
  76   (with-foreign-objects ((optval :int)
  77                          (optlen :socklen))
  78     (setf (mem-ref optlen :socklen) et:size-of-int)
  79     (et:getsockopt fd level option optval optlen)
  80     (values (mem-ref optval :int))))
  81
  82 (defun get-socket-option-linger (fd level option)
  83   (with-foreign-objects ((optval 'et:linger)
  84                          (optlen :socklen))
  85     (setf (mem-ref optlen :socklen) et:size-of-linger)
  86     (et:getsockopt fd level option optval optlen)
  87     (with-foreign-slots ((et:linger et:onoff) optval et:linger)
  88       (values (c->lisp-bool et:onoff) et:linger))))
  89
  90 (defun get-socket-option-timeval (fd level option)
  91   (with-foreign-objects ((optval 'et:timeval)
  92                          (optlen :socklen))
  93     (setf (mem-ref optlen :socklen) et:size-of-timeval)
  94     (et:getsockopt fd level option optval optlen)
  95     (with-foreign-slots ((et:tv-sec et:tv-usec) optval et:timeval)
  96       (values et:tv-sec et:tv-usec))))
  97
  98
  99 ;;
 100 ;; Option definitions
 101 ;;
 102
 103 (eval-when (:compile-toplevel :load-toplevel :execute)
 104   (defun make-sockopt-helper-name (action value-type)
 105     (iolib-utils:concat-symbol action
 106                                '-socket-option-
 107                                value-type))
 108
 109   (defparameter +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 (member os *features*)
 118           `(with-socket-error-filter
 119              (,helper-get (socket-fd socket) ,level ,optname))
 120           `(error 'option-not-available option-name))))
 121
 122 (defmacro define-set-sockopt (os eql-name args helper-set level optname)
 123   `(defmethod set-socket-option ((socket socket) (option-name (eql ,eql-name)) &key ,@args)
 124      ,@(if (member os *features*)
 125            `((with-socket-error-filter
 126                (,helper-set (socket-fd socket) ,level ,optname ,@args)))
 127            `((declare (ignore ,@args))
 128              (error 'option-not-available option-name)))))
 129
 130 (defmacro define-socket-option (name action optname level argtype os)
 131   (declare (type symbol action)
 132            (type symbol argtype)
 133            (type symbol os))
 134   (let ((eql-name (iolib-utils:ensure-keyword name))
 135         (args (second (assoc argtype +helper-args-map+)))
 136         (helper-get (make-sockopt-helper-name :get argtype))
 137         (helper-set (make-sockopt-helper-name :set argtype)))
 138     `(progn
 139        ,@(remove-if #'null
 140            (list
 141             (when (member action (list :get :get-and-set))
 142               `(define-get-sockopt ,os ,eql-name ,helper-get ,level ,optname))
 143             (when (member action (list :set :get-and-set))
 144               `(define-set-sockopt ,os ,eql-name ,args ,helper-set ,level ,optname)))))))
 145
 146 ;;;;;;;;;;;;;;;;;;;;;
 147 ;; Generic options ;;
 148 ;;;;;;;;;;;;;;;;;;;;;
 149 (define-socket-option accept-connections :get         et::so-acceptconn   et::sol-socket :bool    :unix)
 150 (define-socket-option broadcast          :get-and-set et::so-broadcast    et::sol-socket :bool    :unix)
 151 (define-socket-option debug              :get-and-set et::so-debug        et::sol-socket :bool    :unix)
 152 (define-socket-option dont-route         :get-and-set et::so-dontroute    et::sol-socket :bool    :unix)
 153 (define-socket-option error              :get         et::so-error        et::sol-socket :int     :unix)
 154 (define-socket-option keep-alive         :get-and-set et::so-keepalive    et::sol-socket :bool    :unix)
 155 (define-socket-option linger             :get-and-set et::so-linger       et::sol-socket :linger  :unix)
 156 (define-socket-option oob-inline         :get-and-set et::so-oobinline    et::sol-socket :bool    :unix)
 157 (define-socket-option receive-buffer     :get-and-set et::so-rcvbuf       et::sol-socket :int     :unix)
 158 (define-socket-option send-buffer        :get-and-set et::so-sndbuf       et::sol-socket :int     :unix)
 159 (define-socket-option receive-low-water  :get-and-set et::so-rcvlowat     et::sol-socket :int     :unix)
 160 (define-socket-option send-low-water     :get-and-set et::so-sndlowat     et::sol-socket :int     :unix)
 161 (define-socket-option receive-timeout    :get-and-set et::so-rcvtimeo     et::sol-socket :timeval :unix)
 162 (define-socket-option send-timeout       :get-and-set et::so-sndtimeo     et::sol-socket :timeval :unix)
 163 (define-socket-option reuse-address      :get-and-set et::so-reuseaddr    et::sol-socket :bool    :unix)
 164 (define-socket-option type               :get         et::so-type         et::sol-socket :int     :unix)
 165
 166 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 167 ;; Linux-specific options ;;
 168 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 169 (define-socket-option bsd-compatible     :set         et::so-bsdcompat    et::sol-socket :bool    :linux)
 170 (define-socket-option bind-to-device     :set         et::so-bindtodevice et::sol-socket :int     :linux)
 171 (define-socket-option priority           :get-and-set et::so-priority     et::sol-socket :int     :linux)
 172
 173 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 174 ;; FreeBSD-specific options ;;
 175 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 176 (define-socket-option reuse-port         :get-and-set et::so-reuseport    et::sol-socket :bool    :freebsd)
 177 (define-socket-option use-loopback       :get-and-set et::so-useloopback  et::sol-socket :bool    :freebsd)
 178 (define-socket-option no-sigpipe         :get-and-set et::so-nosigpipe    et::sol-socket :bool    :freebsd)
 179
 180
 181 ;;;;;;;;;;;;;;;;;;;;;;;;
 182 ;;;                  ;;;
 183 ;;; Still to be done ;;;
 184 ;;;                  ;;;
 185 ;;;;;;;;;;;;;;;;;;;;;;;;
 186
 187 ;; TODO: implement "struct ucred" helpers
 188
 189 ;; (define-socket-option pass-credentials   :get-and-set et::so-passcred     et::sol-socket :ucred   :freebsd)
 190 ;; (define-socket-option peer-credentials   :get         et::so-peercred     et::sol-socket :ucred   :freebsd)
 191
 192
 193 ;; TODO: implement "struct accept_filter_arg" helpers
 194
 195 ;; (define-socket-option accept-filter      :get-and-set et::so-acceptfilter et::sol-socket :accept-filter :freebsd)
 196
 197 ;; TODO: find out the types of these options
 198
 199 ;; (define-socket-option bintime            :get-and-set et::so-bintime      et::sol-socket :bool    :freebsd)
 200 ;; (define-socket-option label              :get-and-set et::so-label        et::sol-socket :bool    :freebsd)
 201 ;; (define-socket-option peerlabel          :get-and-set et::so-peerlabel    et::sol-socket :bool    :freebsd)
 202 ;; (define-socket-option listen-queue-limit :get-and-set et::so-listenqlimit et::sol-socket :int     :freebsd)
 203 ;; (define-socket-option listen-queue-length :get-and-set et::so-listenqlen  et::sol-socket :int     :freebsd)
 204 ;; (define-socket-option listen-incomplete-queue-length :get-and-set et::so-listenincqlen  et::sol-socket :int :freebsd)