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