1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
3 ;;; --- Setter and getters for various socket options.
6 (in-package :net.sockets
)
10 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
11 (defvar *socket-option-types
* (make-hash-table :test
#'eq
))
12 (defvar *set-socket-options
* (make-hash-table :test
#'eq
))
13 (defun socktype-args (type)
14 (first (gethash type
*socket-option-types
*)))
15 (defun socktype-getter (type)
16 (second (gethash type
*socket-option-types
*)))
17 (defun socktype-setter (type)
18 (third (gethash type
*socket-option-types
*))))
20 (defmacro define-socket-option-type
(name args
)
21 (flet ((make-helper-name (action value-type
)
22 (format-symbol t
"~A~A~A"
23 action
'#:-socket-option- value-type
)))
24 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
25 (setf (gethash ,name
*socket-option-types
*)
27 ',(make-helper-name :get name
)
28 ',(make-helper-name :set name
))))))
30 (defmacro define-socket-option-helper
(helper args
&body body
)
31 (destructuring-bind (action type
) helper
32 (assert (gethash type
*socket-option-types
*))
33 (assert (= (length args
)
36 (:set
(length (socktype-args type
)))))))
37 (multiple-value-bind (forms decls
) (parse-body body
)
38 `(defun ,(ecase action
39 (:get
(socktype-getter type
))
40 (:set
(socktype-setter type
)))
41 ,args
,decls
,@forms
))))
43 (defmacro define-get-sockopt
(os name type level optname
)
44 `(defmethod socket-option ((socket socket
) (option-name (eql ,name
)))
45 (declare (ignorable socket option-name
))
46 ,(if (or (eq :any os
) (featurep os
))
47 (let ((getter (socktype-getter type
)))
48 `(,getter
(fd-of socket
) ,level
,optname
))
49 `(error 'socket-option-not-supported-error
50 :message
,(format nil
"Unsupported socket option: ~S" name
)))))
52 (defmacro define-set-sockopt
(os name type level optname
)
53 (when (or (eq :any os
) (featurep os
))
54 `(setf (gethash ,name
*set-socket-options
*)
55 (list ,type
,level
,optname
))))
57 (define-setf-expander socket-option
(socket option-name
&key
(if-does-not-exist :error
))
58 (flet ((%make-arglist
(type-args expanded-args
)
59 (mapcar (lambda (targ earg
)
61 `(or ,earg
,(cadr targ
))
63 type-args expanded-args
)))
64 (if-let (data (gethash option-name
*set-socket-options
*))
65 (destructuring-bind (type level optname
) data
66 (let ((glist (make-gensym-list (length (socktype-args type
)))))
68 `(,(socktype-setter type
)
69 (fd-of ,socket
) ,level
,optname
70 ,@(%make-arglist
(socktype-args type
) glist
))
73 (case if-does-not-exist
75 `(error 'socket-option-not-supported-error
76 :message
,(format nil
"Unsupported socket option: ~S"
80 (defmacro define-socket-option
(name action optname level argtype os
)
81 (let ((eql-name (make-keyword name
)))
83 ,(when (member action
(list :get
:get-and-set
))
84 `(define-get-sockopt ,os
,eql-name
,argtype
,level
,optname
))
85 ,(when (member action
(list :set
:get-and-set
))
86 `(define-set-sockopt ,os
,eql-name
,argtype
,level
,optname
)))))
88 (defmacro define-socket-options
(action level os
&body options
)
90 ,@(loop :for
(name optname argtype
) :in options
:collect
91 `(define-socket-option ,name
,action
92 ,optname
,level
,argtype
,os
))))
98 (define-socket-option-type :bool
(value))
100 (define-socket-option-helper (:get
:bool
) (fd level option
)
101 (with-foreign-object (optval :int
)
102 (with-socklen (optlen size-of-int
)
103 (%getsockopt fd level option optval optlen
)
104 (mem-aref optval
:boolean
))))
106 (define-socket-option-helper (:set
:bool
) (fd level option value
)
107 (with-foreign-object (optval :int
)
108 (setf (mem-aref optval
:int
) (lisp->c-bool value
))
109 (%setsockopt fd level option optval size-of-int
)
114 (define-socket-option-type :int
(value))
116 (define-socket-option-helper (:get
:int
) (fd level option
)
117 (with-foreign-object (optval :int
)
118 (with-socklen (optlen size-of-int
)
119 (%getsockopt fd level option optval optlen
)
120 (mem-aref optval
:int
))))
122 (define-socket-option-helper (:set
:int
) (fd level option value
)
123 (with-foreign-object (optval :int
)
124 (setf (mem-aref optval
:int
) value
)
125 (%setsockopt fd level option optval size-of-int
)
130 (define-socket-option-type :linger
(onoff (linger *default-linger-seconds
*)))
132 (define-socket-option-helper (:get
:linger
) (fd level option
)
133 (with-foreign-object (optval 'linger
)
134 (with-socklen (optlen size-of-linger
)
135 (%getsockopt fd level option optval optlen
)
136 (with-foreign-slots ((linger onoff
) optval linger
)
137 (values (not (zerop onoff
)) linger
)))))
139 (define-socket-option-helper (:set
:linger
) (fd level option new-onoff new-linger
)
140 (with-foreign-object (optval 'linger
)
141 (with-foreign-slots ((linger onoff
) optval linger
)
142 (setf onoff
(lisp->c-bool new-onoff
)
144 (%setsockopt fd level option optval size-of-linger
)
145 (values new-onoff new-linger
)))
149 (define-socket-option-type :timeval
(sec))
151 (define-socket-option-helper (:get
:timeval
) (fd level option
)
152 (with-foreign-object (optval 'timeval
)
153 (with-socklen (optlen size-of-timeval
)
154 (%getsockopt fd level option optval optlen
)
155 (with-foreign-slots ((sec usec
) optval timeval
)
156 (values sec usec
)))))
158 (define-socket-option-helper (:set
:timeval
) (fd level option new-sec
)
159 (with-foreign-object (optval 'timeval
)
160 (with-foreign-slots ((sec usec
) optval timeval
)
161 (setf (values sec usec
) (decode-timeout new-sec
)))
162 (%setsockopt fd level option optval size-of-timeval
)
167 (define-socket-option-type :ifreq-name
(value))
170 (define-socket-option-helper (:set
:ifreq-name
) (fd level option interface
)
171 (with-foreign-object (optval 'ifreq
)
172 (nix:bzero optval size-of-ifreq
)
173 (with-foreign-slots ((name) optval ifreq
)
174 (with-foreign-string (ifname interface
)
175 (nix:memcpy name ifname
(min (length interface
) (1- ifnamsiz
)))))
176 (%setsockopt fd level option optval size-of-ifreq
)
179 ;;;; Option Definitions
183 (define-socket-options :get sol-socket
:any
184 (accept-connections so-acceptconn
:bool
)
185 (error so-error
:int
)
188 (define-socket-options :get-and-set sol-socket
:any
189 (broadcast so-broadcast
:bool
)
190 (debug so-debug
:bool
)
191 (dont-route so-dontroute
:bool
)
192 (keep-alive so-keepalive
:bool
)
193 (linger so-linger
:linger
)
194 (oob-inline so-oobinline
:bool
)
195 (receive-buffer so-rcvbuf
:int
)
196 (send-buffer so-sndbuf
:int
)
197 (receive-low-water so-rcvlowat
:int
)
198 (send-low-water so-sndlowat
:int
)
199 (receive-timeout so-rcvtimeo
:timeval
)
200 (send-timeout so-sndtimeo
:timeval
)
201 (reuse-address so-reuseaddr
:bool
))
203 ;;; Linux-specific Options
205 (define-socket-options :set sol-socket
:linux
206 (bind-to-device so-bindtodevice
:ifreq-name
))
208 (define-socket-option priority
:get-and-set
209 so-priority sol-socket
:int
:linux
)
211 ;;; FreeBSD-specific options
213 (define-socket-options :get-and-set sol-socket
:freebsd
214 (reuse-port so-reuseport
:bool
)
215 (use-loopback so-useloopback
:bool
)
216 (no-sigpipe so-nosigpipe
:bool
))
220 ;; TODO: implement "struct ucred" helpers
222 ;; (define-socket-option pass-credentials :get-and-set et:so-passcred et:sol-socket :ucred (:or :linux :freebsd))
223 ;; (define-socket-option peer-credentials :get et:so-peercred et:sol-socket :ucred (:or :linux :freebsd))
226 ;; TODO: implement "struct accept_filter_arg" helpers
228 ;; (define-socket-option accept-filter :get-and-set et:so-acceptfilter et:sol-socket :accept-filter :freebsd)
230 ;; TODO: find out the types of these options
232 ;; (define-socket-option bintime :get-and-set et:so-bintime et:sol-socket :bool :freebsd)
233 ;; (define-socket-option label :get-and-set et:so-label et:sol-socket :bool :freebsd)
234 ;; (define-socket-option peerlabel :get-and-set et:so-peerlabel et:sol-socket :bool :freebsd)
235 ;; (define-socket-option listen-queue-limit :get-and-set et:so-listenqlimit et:sol-socket :int :freebsd)
236 ;; (define-socket-option listen-queue-length :get-and-set et:so-listenqlen et:sol-socket :int :freebsd)
237 ;; (define-socket-option listen-incomplete-queue-length :get-and-set et:so-listenincqlen et:sol-socket :int :freebsd)
242 (define-socket-option tcp-nodelay
:get-and-set
243 tcp-nodelay ipproto-tcp
:bool
:any
)
245 (define-socket-option tcp-maxseg
:get-and-set
246 tcp-maxseg ipproto-tcp
:int
(:or
:linux
:freebsd
))
248 ;;; Linux-specific TCP Options
250 (define-socket-options :get-and-set ipproto-tcp
:linux
251 (tcp-cork tcp-cork
:bool
)
252 (tcp-defer-accept tcp-defer-accept
:int
)
253 (tcp-keepcnt tcp-keepcnt
:int
)
254 (tcp-keepidle tcp-keepidle
:int
)
255 (tcp-keepintvl tcp-keepintvl
:int
)
256 (tcp-linger2 tcp-linger2
:int
)
257 (tcp-quickack tcp-quickack
:bool
)
258 (tcp-syncnt tcp-syncnt
:int
)
259 (tcp-window-clamp tcp-window-clamp
:int
))
261 ;; TODO: implement "struct tcp_info" helper
262 ;; (define-socket-option tcp-info :get et::tcp-info et:ipproto-tcp :tcp-info :linux)
264 ;;; FreeBSD-specific TCP Options
266 (define-socket-options :get-and-set ipproto-tcp
:freebsd
267 (tcp-noopt tcp-noopt
:bool
)
268 (tcp-nopush tcp-nopush
:bool
))