1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
3 ;;; socket-options.lisp --- Setter and getters for various socket options.
5 ;;; Copyright (C) 2006-2007, Stelian Ionescu <sionescu@common-lisp.net>
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
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.
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 ;;; TODO: manage socket options errors
27 (defun sockopt-error (retval level option action
&optional val1 val2
)
28 (declare (ignore retval level option action val1 val2
))
29 (error "Sockopt error !"))
33 ;;; This interface looks nice but doesn't work so well for the linger
34 ;;; and timeout options. Figure out a good solution. Possible ones
37 ;;; * don't worry, tell the user to use GET/SET-SOCKET-OPTION
38 ;;; * socket-linger-option and socket-timeval-option accessors
39 ;;; * use separate accessors for each and every option, like
42 (defun socket-option (socket option-name
)
43 (get-socket-option socket option-name
))
45 (defun (setf socket-option
) (value socket option-name
)
46 (set-socket-option socket option-name
:value value
))
50 (defun set-socket-option-bool (fd level option value
)
51 (with-foreign-object (optval :int
)
52 (setf (mem-ref optval
:int
) (lisp->c-bool value
))
53 (nix:setsockopt fd level option optval nix
::size-of-int
)
56 (defun set-socket-option-int (fd level option value
)
57 (with-foreign-object (optval :int
)
58 (setf (mem-ref optval
:int
) value
)
59 (nix:setsockopt fd level option optval nix
::size-of-int
)
62 (defun set-socket-option-linger (fd level option onoff linger
)
63 (with-foreign-object (optval 'nix
::linger
)
65 ((nix::linger nix
::onoff
) optval nix
::linger
)
66 (setf nix
::onoff
(lisp->c-bool onoff
)
68 (nix:setsockopt fd level option optval nix
::size-of-linger
)
71 (defun set-socket-option-timeval (fd level option sec usec
)
72 (with-foreign-object (optval 'nix
::timeval
)
74 ((nix::sec nix
::usec
) optval nix
::timeval
)
77 (nix:setsockopt fd level option optval nix
::size-of-timeval
)
82 (defun get-socket-option-bool (fd level option
)
83 (with-foreign-object (optval :int
)
84 (with-socklen (optlen nix
::size-of-int
)
85 (nix:getsockopt fd level option optval optlen
)
86 (values (c->lisp-bool
(mem-ref optval
:int
))))))
88 (defun get-socket-option-int (fd level option
)
89 (with-foreign-object (optval :int
)
90 (with-socklen (optlen nix
::size-of-int
)
91 (nix:getsockopt fd level option optval optlen
)
92 (values (mem-ref optval
:int
)))))
94 (defun get-socket-option-linger (fd level option
)
95 (with-foreign-object (optval 'nix
::linger
)
96 (with-socklen (optlen nix
::size-of-linger
)
97 (nix:getsockopt fd level option optval optlen
)
98 (with-foreign-slots ((nix::linger nix
::onoff
) optval nix
::linger
)
99 (values (c->lisp-bool nix
::onoff
) nix
::linger
)))))
101 (defun get-socket-option-timeval (fd level option
)
102 (with-foreign-object (optval 'nix
::timeval
)
103 (with-socklen (optlen nix
::size-of-timeval
)
104 (nix:getsockopt fd level option optval optlen
)
105 (with-foreign-slots ((nix::sec nix
::usec
) optval nix
::timeval
)
106 (values nix
::sec nix
::usec
)))))
108 ;;;; Option Definitions
110 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
111 (defvar +helper-args-map
+
114 (:linger
(onoff linger
))
115 (:timeval
(sec usec
)))))
117 (defmacro define-get-sockopt
(os eql-name helper-get level optname
)
118 `(defmethod get-socket-option ((socket socket
) (option-name (eql ,eql-name
)))
119 ,(if (alexandria:featurep os
)
120 `(with-socket-error-filter
121 (,helper-get
(socket-fd socket
) ,level
,optname
))
122 `(error 'option-not-available option-name
))))
124 (defmacro define-set-sockopt
(os eql-name args helper-set level optname
)
125 `(defmethod set-socket-option
126 ((socket socket
) (option-name (eql ,eql-name
)) &key
,@args
)
127 ,@(if (alexandria:featurep os
)
128 `((with-socket-error-filter
129 (,helper-set
(socket-fd socket
) ,level
,optname
,@args
)))
130 `((declare (ignore ,@args
))
131 (error 'option-not-available option-name
)))))
133 (defmacro define-socket-option
(name action optname level argtype os
)
134 (declare (type symbol action
)
135 (type symbol argtype
)
136 (type (or symbol list
) os
))
137 (flet ((make-helper-name (action value-type
)
138 (alexandria:format-symbol t
"~A~A~A"
139 action
'#:-socket-option- value-type
)))
140 (let ((eql-name (alexandria:make-keyword name
))
141 (args (second (assoc argtype
+helper-args-map
+)))
142 (helper-get (make-helper-name :get argtype
))
143 (helper-set (make-helper-name :set argtype
)))
148 (when (member action
(list :get
:get-and-set
))
149 `(define-get-sockopt ,os
,eql-name
,helper-get
,level
,optname
))
150 (when (member action
(list :set
:get-and-set
))
151 `(define-set-sockopt ,os
,eql-name
,args
,helper-set
,level
154 (defmacro define-socket-options
(action level os
&body options
)
156 ,@(loop :for
(name optname argtype
) :in options
:collect
157 `(define-socket-option ,name
,action
158 ,optname
,level
,argtype
,os
))))
162 (define-socket-options :get nix
::sol-socket
:unix
163 (accept-connections nix
::so-acceptconn
:bool
)
164 (error nix
::so-error
:int
)
165 (type nix
::so-type
:int
))
167 (define-socket-options :get-and-set nix
::sol-socket
:unix
168 (broadcast nix
::so-broadcast
:bool
)
169 (debug nix
::so-debug
:bool
)
170 (dont-route nix
::so-dontroute
:bool
)
171 (keep-alive nix
::so-keepalive
:bool
)
172 (linger nix
::so-linger
:linger
)
173 (oob-inline nix
::so-oobinline
:bool
)
174 (receive-buffer nix
::so-rcvbuf
:int
)
175 (send-buffer nix
::so-sndbuf
:int
)
176 (receive-low-water nix
::so-rcvlowat
:int
)
177 (send-low-water nix
::so-sndlowat
:int
)
178 (receive-timeout nix
::so-rcvtimeo
:timeval
)
179 (send-timeout nix
::so-sndtimeo
:timeval
)
180 (reuse-address nix
::so-reuseaddr
:bool
))
182 ;;;; Linux-specific Options
184 (define-socket-options :set nix
::sol-socket
:linux
185 (bsd-compatible nix
::so-bsdcompat
:bool
)
186 (bind-to-device nix
::so-bindtodevice
:int
))
188 (define-socket-option priority
:get-and-set
189 nix
::so-priority nix
::sol-socket
:int
:linux
)
191 ;;;; FreeBSD-specific options
193 (define-socket-options :get-and-set nix
::sol-socket
:freebsd
194 (reuse-port nix
::so-reuseport
:bool
)
195 (use-loopback nix
::so-useloopback
:bool
)
196 (no-sigpipe nix
::so-nosigpipe
:bool
))
200 ;; TODO: implement "struct ucred" helpers
202 ;; (define-socket-option pass-credentials :get-and-set et:so-passcred et:sol-socket :ucred (:or :linux :freebsd))
203 ;; (define-socket-option peer-credentials :get et:so-peercred et:sol-socket :ucred (:or :linux :freebsd))
206 ;; TODO: implement "struct accept_filter_arg" helpers
208 ;; (define-socket-option accept-filter :get-and-set et:so-acceptfilter et:sol-socket :accept-filter :freebsd)
210 ;; TODO: find out the types of these options
212 ;; (define-socket-option bintime :get-and-set et:so-bintime et:sol-socket :bool :freebsd)
213 ;; (define-socket-option label :get-and-set et:so-label et:sol-socket :bool :freebsd)
214 ;; (define-socket-option peerlabel :get-and-set et:so-peerlabel et:sol-socket :bool :freebsd)
215 ;; (define-socket-option listen-queue-limit :get-and-set et:so-listenqlimit et:sol-socket :int :freebsd)
216 ;; (define-socket-option listen-queue-length :get-and-set et:so-listenqlen et:sol-socket :int :freebsd)
217 ;; (define-socket-option listen-incomplete-queue-length :get-and-set et:so-listenincqlen et:sol-socket :int :freebsd)
222 (define-socket-option tcp-nodelay
:get-and-set
223 nix
::tcp-nodelay nix
::ipproto-tcp
:bool
:unix
)
225 (define-socket-option tcp-maxseg
:get-and-set
226 nix
::tcp-maxseg nix
::ipproto-tcp
:int
(:or
:linux
:freebsd
))
228 ;;;; Linux-specific TCP Options
230 (define-socket-options :get-and-set nix
::ipproto-tcp
:linux
231 (tcp-cork nix
::tcp-cork
:bool
)
232 (tcp-defer-accept nix
::tcp-defer-accept
:int
)
233 (tcp-keepcnt nix
::tcp-keepcnt
:int
)
234 (tcp-keepidle nix
::tcp-keepidle
:int
)
235 (tcp-keepintvl nix
::tcp-keepintvl
:int
)
236 (tcp-linger2 nix
::tcp-linger2
:int
)
237 (tcp-quickack nix
::tcp-quickack
:bool
)
238 (tcp-syncnt nix
::tcp-syncnt
:int
)
239 (tcp-window-clamp nix
::tcp-window-clamp
:int
))
241 ;; TODO: implement "struct tcp_info" helper
242 ;; (define-socket-option tcp-info :get et::tcp-info et:ipproto-tcp :tcp-info :linux)
244 ;;;; FreeBSD-specific TCP Options
246 (define-socket-options :get-and-set nix
::ipproto-tcp
:freebsd
247 (tcp-noopt nix
::tcp-noopt
:bool
)
248 (tcp-nopush nix
::tcp-nopush
:bool
))