sockets/socket-options.lisp

   1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
   2
   3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   4 ;   Copyright (C) 2006 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     (setf (foreign-slot-value optval 'et:linger 'et:onoff) (lisp->c-bool onoff))
  51     (setf (foreign-slot-value optval 'et:linger 'et:linger) linger)
  52     (et:setsockopt fd level option optval #.(foreign-type-size 'et:linger))
  53     (values)))
  54
  55 (defun set-socket-option-timeval (fd level option sec usec)
  56   (with-foreign-object (optval 'et:timeval)
  57     (setf (foreign-slot-value optval 'et:timeval 'et:tv-sec) sec)
  58     (setf (foreign-slot-value optval 'et:timeval 'et:tv-usec) usec)
  59     (et:setsockopt fd level option optval #.(foreign-type-size 'et:timeval))
  60     (values)))
  61
  62 ;;
  63 ;; Get option helpers
  64 ;;
  65
  66 (defun get-socket-option-bool (fd level option)
  67   (with-foreign-objects ((optval :int)
  68                          (optlen :socklen))
  69     (setf (mem-ref optlen :int) et:size-of-int)
  70     (et:getsockopt fd level option optval optlen)
  71     (values (c->lisp-bool optval))))
  72
  73 (defun get-socket-option-int (fd level option)
  74   (with-foreign-objects ((optval :int)
  75                          (optlen :socklen))
  76     (setf (mem-ref optlen :int) et:size-of-int)
  77     (et:getsockopt fd level option optval optlen)
  78     (values optval)))
  79
  80 (defun get-socket-option-linger (fd level option)
  81   (with-foreign-objects ((optval 'et:linger)
  82                          (optlen :socklen))
  83     (setf (mem-ref optlen :int) #.(foreign-type-size 'et:linger))
  84     (et:getsockopt fd level option optval optlen)
  85     (values (c->lisp-bool (foreign-slot-value optval 'et:linger 'et:onoff))
  86             (foreign-slot-value optval 'et:linger 'et:linger))))
  87
  88 (defun get-socket-option-timeval (fd level option)
  89   (with-foreign-objects ((optval 'et:timeval)
  90                          (optlen :socklen))
  91     (setf (mem-ref optlen :int) #.(foreign-type-size 'et:timeval))
  92     (et:getsockopt fd level option optval optlen)
  93     (values (foreign-slot-value optval 'et:timeval 'et:tv-sec)
  94             (foreign-slot-value optval 'et:timeval 'et:tv-usec))))
  95
  96
  97 ;;
  98 ;; Option definitions
  99 ;;
 100
 101 (eval-when (:compile-toplevel :load-toplevel :execute)
 102   (defun make-sockopt-helper-name (action value-type)
 103     (iolib-utils:concat-symbol action
 104                                '-socket-option-
 105                                value-type))
 106
 107   (defparameter +helper-args-map+
 108     '((:bool (value))
 109       (:int (value))
 110       (:linger (onoff linger))
 111       (:timeval (sec usec)))))
 112
 113 (defmacro define-get-sockopt (os eql-name helper-get level optname)
 114   `(defmethod get-socket-option ((socket socket) (option-name (eql ,eql-name)))
 115      ,(if (member os *features*)
 116           `(with-socket-error-filter
 117              (,helper-get (socket-fd socket) ,level ,optname))
 118           `(error 'option-not-available option-name))))
 119
 120 (defmacro define-set-sockopt (os eql-name args helper-set level optname)
 121   `(defmethod set-socket-option ((socket socket) (option-name (eql ,eql-name)) &key ,@args)
 122      ,@(if (member os *features*)
 123            `((with-socket-error-filter
 124                (,helper-set (socket-fd socket) ,level ,optname ,@args)))
 125            `((declare (ignore ,@args))
 126              (error 'option-not-available option-name)))))
 127
 128 (defmacro define-socket-option (name action optname level argtype os)
 129   (declare (type symbol action)
 130            (type symbol argtype)
 131            (type symbol os))
 132   (let ((eql-name (iolib-utils:ensure-keyword name))
 133         (args (second (assoc argtype +helper-args-map+)))
 134         (helper-get (make-sockopt-helper-name :get argtype))
 135         (helper-set (make-sockopt-helper-name :set argtype)))
 136     `(progn
 137        ,@(remove-if #'null
 138            (list
 139             (when (member action (list :get :get-and-set))
 140               `(define-get-sockopt ,os ,eql-name ,helper-get ,level ,optname))
 141             (when (member action (list :set :get-and-set))
 142               `(define-set-sockopt ,os ,eql-name ,args ,helper-set ,level ,optname)))))))
 143
 144 ;;;;;;;;;;;;;;;;;;;;;
 145 ;; Generic options ;;
 146 ;;;;;;;;;;;;;;;;;;;;;
 147 (define-socket-option accept-connections :get         et::so-acceptconn   et::sol-socket :bool    :unix)
 148 (define-socket-option broadcast          :get-and-set et::so-broadcast    et::sol-socket :bool    :unix)
 149 (define-socket-option debug              :get-and-set et::so-debug        et::sol-socket :bool    :unix)
 150 (define-socket-option dont-route         :get-and-set et::so-dontroute    et::sol-socket :bool    :unix)
 151 (define-socket-option error              :get         et::so-error        et::sol-socket :int     :unix)
 152 (define-socket-option keep-alive         :get-and-set et::so-keepalive    et::sol-socket :bool    :unix)
 153 (define-socket-option linger             :get-and-set et::so-linger       et::sol-socket :linger  :unix)
 154 (define-socket-option oob-inline         :get-and-set et::so-oobinline    et::sol-socket :bool    :unix)
 155 (define-socket-option receive-buffer     :get-and-set et::so-rcvbuf       et::sol-socket :int     :unix)
 156 (define-socket-option send-buffer        :get-and-set et::so-sndbuf       et::sol-socket :int     :unix)
 157 (define-socket-option receive-low-water  :get-and-set et::so-rcvlowat     et::sol-socket :int     :unix)
 158 (define-socket-option send-low-water     :get-and-set et::so-sndlowat     et::sol-socket :int     :unix)
 159 (define-socket-option receive-timeout    :get-and-set et::so-rcvtimeo     et::sol-socket :timeval :unix)
 160 (define-socket-option send-timeout       :get-and-set et::so-sndtimeo     et::sol-socket :timeval :unix)
 161 (define-socket-option reuse-address      :get-and-set et::so-reuseaddr    et::sol-socket :bool    :unix)
 162 (define-socket-option type               :get         et::so-type         et::sol-socket :int     :unix)
 163
 164 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 165 ;; Linux-specific options ;;
 166 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 167 (define-socket-option bsd-compatible     :set         et::so-bsdcompat    et::sol-socket :bool    :linux)
 168 (define-socket-option bind-to-device     :set         et::so-bindtodevice et::sol-socket :int     :linux)
 169 (define-socket-option priority           :get-and-set et::so-priority     et::sol-socket :int     :linux)
 170
 171 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 172 ;; FreeBSD-specific options ;;
 173 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 174 (define-socket-option reuse-port         :get-and-set et::so-reuseport    et::sol-socket :bool    :freebsd)
 175 (define-socket-option use-loopback       :get-and-set et::so-useloopback  et::sol-socket :bool    :freebsd)
 176 (define-socket-option no-sigpipe         :get-and-set et::so-nosigpipe    et::sol-socket :bool    :freebsd)
 177
 178
 179 ;;;;;;;;;;;;;;;;;;;;;;;;
 180 ;;;                  ;;;
 181 ;;; Still to be done ;;;
 182 ;;;                  ;;;
 183 ;;;;;;;;;;;;;;;;;;;;;;;;
 184
 185 ;; TODO: implement "struct ucred" helpers
 186
 187 ;; (define-socket-option pass-credentials   :get-and-set et::so-passcred     et::sol-socket :ucred   :freebsd)
 188 ;; (define-socket-option peer-credentials   :get         et::so-peercred     et::sol-socket :ucred   :freebsd)
 189
 190
 191 ;; TODO: implement "struct accept_filter_arg" helpers
 192
 193 ;; (define-socket-option accept-filter      :get-and-set et::so-acceptfilter et::sol-socket :accept-filter :freebsd)
 194
 195 ;; TODO: find out the types of these options
 196
 197 ;; (define-socket-option bintime            :get-and-set et::so-bintime      et::sol-socket :bool    :freebsd)
 198 ;; (define-socket-option label              :get-and-set et::so-label        et::sol-socket :bool    :freebsd)
 199 ;; (define-socket-option peerlabel          :get-and-set et::so-peerlabel    et::sol-socket :bool    :freebsd)
 200 ;; (define-socket-option listen-queue-limit :get-and-set et::so-listenqlimit et::sol-socket :int     :freebsd)
 201 ;; (define-socket-option listen-queue-length :get-and-set et::so-listenqlen  et::sol-socket :int     :freebsd)
 202 ;; (define-socket-option listen-incomplete-queue-length :get-and-set et::so-listenincqlen  et::sol-socket :int :freebsd)