Small improvement in compiler macro for MAKE-SOCKET.
[iolib.git] / sockets / socket-options.lisp
blob236cfead65a708764b6d628d6a08facd20454393
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-2008, 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
24 (in-package :net.sockets)
26 ;;;; Macrology
28 (eval-when (:compile-toplevel :load-toplevel :execute)
29 (defvar *socket-option-types* (make-hash-table :test #'eq))
30 (defvar *set-socket-options* (make-hash-table :test #'eq))
31 (defun socktype-args (type)
32 (first (gethash type *socket-option-types*)))
33 (defun socktype-getter (type)
34 (second (gethash type *socket-option-types*)))
35 (defun socktype-setter (type)
36 (third (gethash type *socket-option-types*))))
38 (defmacro define-socket-option-type (name args)
39 (flet ((make-helper-name (action value-type)
40 (format-symbol t "~A~A~A"
41 action '#:-socket-option- value-type)))
42 `(eval-when (:compile-toplevel :load-toplevel :execute)
43 (setf (gethash ,name *socket-option-types*)
44 (list ',args
45 ',(make-helper-name :get name)
46 ',(make-helper-name :set name))))))
48 (defmacro define-socket-option-helper (helper args &body body)
49 (destructuring-bind (action type) helper
50 (assert (gethash type *socket-option-types*))
51 (assert (= (length args)
52 (+ 3 (ecase action
53 (:get 0)
54 (:set (length (socktype-args type)))))))
55 (multiple-value-bind (forms decls) (parse-body body)
56 `(defun ,(ecase action
57 (:get (socktype-getter type))
58 (:set (socktype-setter type)))
59 ,args ,decls ,@forms))))
61 (defmacro define-get-sockopt (os name type level optname)
62 `(defmethod socket-option ((socket socket) (option-name (eql ,name)))
63 (declare (ignorable socket option-name))
64 ,(if (or (eq os :any) (featurep os))
65 (let ((getter (socktype-getter type)))
66 `(,getter (socket-fd socket) ,level ,optname))
67 `(error 'socket-option-not-supported-error
68 :message ,(format nil "Unsupported socket option: ~S" name)))))
70 (defmacro define-set-sockopt (os name type level optname)
71 (when (or (eq os :any) (featurep os))
72 `(setf (gethash ,name *set-socket-options*)
73 (list ,type ,level ,optname))))
75 (define-setf-expander socket-option (socket option-name)
76 (flet ((%make-arglist (type-args expanded-args)
77 (mapcar #'(lambda (targ earg)
78 (if (consp targ)
79 `(or ,earg ,(cadr targ))
80 earg))
81 type-args expanded-args)))
82 (if-let ((data (gethash option-name *set-socket-options*)))
83 (destructuring-bind (type level optname) data
84 (let ((glist (make-gensym-list (length (socktype-args type)))))
85 (values
86 nil
87 nil
88 glist
89 `(,(socktype-setter type)
90 (socket-fd ,socket) ,level ,optname
91 ,@(%make-arglist (socktype-args type) glist))
92 socket)))
93 `(error 'socket-option-not-supported-error
94 :message ,(format nil "Unsupported socket option: ~S"
95 option-name)))))
97 (defmacro define-socket-option (name action optname level argtype os)
98 (let ((eql-name (make-keyword name)))
99 `(progn
100 ,(when (member action (list :get :get-and-set))
101 `(define-get-sockopt ,os ,eql-name ,argtype ,level ,optname))
102 ,(when (member action (list :set :get-and-set))
103 `(define-set-sockopt ,os ,eql-name ,argtype ,level ,optname)))))
105 (defmacro define-socket-options (action level os &body options)
106 `(progn
107 ,@(loop :for (name optname argtype) :in options :collect
108 `(define-socket-option ,name ,action
109 ,optname ,level ,argtype ,os))))
111 ;;;; Types
113 ;;; BOOL
115 (define-socket-option-type :bool (value))
117 (define-socket-option-helper (:get :bool) (fd level option)
118 (with-foreign-object (optval :int)
119 (with-socklen (optlen size-of-int)
120 (%getsockopt fd level option optval optlen)
121 (mem-ref optval :boolean))))
123 (define-socket-option-helper (:set :bool) (fd level option value)
124 (with-foreign-object (optval :int)
125 (setf (mem-ref optval :int) (lisp->c-bool value))
126 (%setsockopt fd level option optval size-of-int)
127 (values)))
129 ;;; INT
131 (define-socket-option-type :int (value))
133 (define-socket-option-helper (:get :int) (fd level option)
134 (with-foreign-object (optval :int)
135 (with-socklen (optlen size-of-int)
136 (%getsockopt fd level option optval optlen)
137 (mem-ref optval :int))))
139 (define-socket-option-helper (:set :int) (fd level option value)
140 (with-foreign-object (optval :int)
141 (setf (mem-ref optval :int) value)
142 (%setsockopt fd level option optval size-of-int)
143 (values)))
145 ;;; LINGER
147 (define-socket-option-type :linger (onoff (linger *default-linger-seconds*)))
149 (define-socket-option-helper (:get :linger) (fd level option)
150 (with-foreign-object (optval 'linger)
151 (with-socklen (optlen size-of-linger)
152 (%getsockopt fd level option optval optlen)
153 (with-foreign-slots ((linger onoff) optval linger)
154 (values (not (zerop onoff)) linger)))))
156 (define-socket-option-helper (:set :linger) (fd level option new-onoff new-linger)
157 (with-foreign-object (optval 'linger)
158 (with-foreign-slots ((linger onoff) optval linger)
159 (setf onoff (lisp->c-bool new-onoff)
160 linger new-linger))
161 (%setsockopt fd level option optval size-of-linger)
162 (values)))
164 ;;; TIMEVAL
166 (define-socket-option-type :timeval (sec (usec 0)))
168 (define-socket-option-helper (:get :timeval) (fd level option)
169 (with-foreign-object (optval 'nix::timeval)
170 (with-socklen (optlen nix::size-of-timeval)
171 (%getsockopt fd level option optval optlen)
172 (with-foreign-slots ((nix::sec nix::usec) optval nix::timeval)
173 (values nix::sec nix::usec)))))
175 (define-socket-option-helper (:set :timeval) (fd level option sec usec)
176 (with-foreign-object (optval 'nix::timeval)
177 (with-foreign-slots ((nix::sec nix::usec) optval nix::timeval)
178 (setf nix::sec sec
179 nix::usec usec))
180 (%setsockopt fd level option optval nix::size-of-timeval)
181 (values)))
183 ;;; IFREQ-NAME
185 (define-socket-option-type :ifreq-name (value))
187 #+linux
188 (define-socket-option-helper (:set :ifreq-name) (fd level option interface)
189 (with-foreign-object (optval 'ifreq)
190 (nix:bzero optval size-of-ifreq)
191 (with-foreign-slots ((name) optval ifreq)
192 (with-foreign-string (ifname interface)
193 (nix:memcpy name ifname (min (length interface) (1- ifnamsiz)))))
194 (%setsockopt fd level option optval size-of-ifreq)
195 (values)))
197 ;;;; Option Definitions
199 ;;; Generic options
201 (define-socket-options :get sol-socket :any
202 (accept-connections so-acceptconn :bool)
203 (error so-error :int)
204 (type so-type :int))
206 (define-socket-options :get-and-set sol-socket :any
207 (broadcast so-broadcast :bool)
208 (debug so-debug :bool)
209 (dont-route so-dontroute :bool)
210 (keep-alive so-keepalive :bool)
211 (linger so-linger :linger)
212 (oob-inline so-oobinline :bool)
213 (receive-buffer so-rcvbuf :int)
214 (send-buffer so-sndbuf :int)
215 (receive-low-water so-rcvlowat :int)
216 (send-low-water so-sndlowat :int)
217 (receive-timeout so-rcvtimeo :timeval)
218 (send-timeout so-sndtimeo :timeval)
219 (reuse-address so-reuseaddr :bool))
221 ;;; Linux-specific Options
223 (define-socket-options :set sol-socket :linux
224 (bsd-compatible so-bsdcompat :bool)
225 (bind-to-device so-bindtodevice :ifreq-name))
227 (define-socket-option priority :get-and-set
228 so-priority sol-socket :int :linux)
230 ;;; FreeBSD-specific options
232 (define-socket-options :get-and-set sol-socket :freebsd
233 (reuse-port so-reuseport :bool)
234 (use-loopback so-useloopback :bool)
235 (no-sigpipe so-nosigpipe :bool))
237 ;;; TODO
239 ;; TODO: implement "struct ucred" helpers
241 ;; (define-socket-option pass-credentials :get-and-set et:so-passcred et:sol-socket :ucred (:or :linux :freebsd))
242 ;; (define-socket-option peer-credentials :get et:so-peercred et:sol-socket :ucred (:or :linux :freebsd))
245 ;; TODO: implement "struct accept_filter_arg" helpers
247 ;; (define-socket-option accept-filter :get-and-set et:so-acceptfilter et:sol-socket :accept-filter :freebsd)
249 ;; TODO: find out the types of these options
251 ;; (define-socket-option bintime :get-and-set et:so-bintime et:sol-socket :bool :freebsd)
252 ;; (define-socket-option label :get-and-set et:so-label et:sol-socket :bool :freebsd)
253 ;; (define-socket-option peerlabel :get-and-set et:so-peerlabel et:sol-socket :bool :freebsd)
254 ;; (define-socket-option listen-queue-limit :get-and-set et:so-listenqlimit et:sol-socket :int :freebsd)
255 ;; (define-socket-option listen-queue-length :get-and-set et:so-listenqlen et:sol-socket :int :freebsd)
256 ;; (define-socket-option listen-incomplete-queue-length :get-and-set et:so-listenincqlen et:sol-socket :int :freebsd)
259 ;;; TCP Options
261 (define-socket-option tcp-nodelay :get-and-set
262 tcp-nodelay ipproto-tcp :bool :any)
264 (define-socket-option tcp-maxseg :get-and-set
265 tcp-maxseg ipproto-tcp :int (:or :linux :freebsd))
267 ;;; Linux-specific TCP Options
269 (define-socket-options :get-and-set ipproto-tcp :linux
270 (tcp-cork tcp-cork :bool)
271 (tcp-defer-accept tcp-defer-accept :int)
272 (tcp-keepcnt tcp-keepcnt :int)
273 (tcp-keepidle tcp-keepidle :int)
274 (tcp-keepintvl tcp-keepintvl :int)
275 (tcp-linger2 tcp-linger2 :int)
276 (tcp-quickack tcp-quickack :bool)
277 (tcp-syncnt tcp-syncnt :int)
278 (tcp-window-clamp tcp-window-clamp :int))
280 ;; TODO: implement "struct tcp_info" helper
281 ;; (define-socket-option tcp-info :get et::tcp-info et:ipproto-tcp :tcp-info :linux)
283 ;;; FreeBSD-specific TCP Options
285 (define-socket-options :get-and-set ipproto-tcp :freebsd
286 (tcp-noopt tcp-noopt :bool)
287 (tcp-nopush tcp-nopush :bool))