PageRenderTime 4ms CodeModel.GetById 2ms app.highlight 19ms RepoModel.GetById 1ms app.codeStats 0ms

/socket-options.scm

https://bitbucket.org/ursetto/rfc2553
Scheme | 394 lines | 238 code | 52 blank | 104 comment | 0 complexity | 6d45be6bdaa5e8b90104a4018e654782 MD5 | raw file
  1;;; Local macros
  2
  3;;(require-library srfi-13) ;;?
  4(import-for-syntax srfi-13)
  5
  6;; ;; (local 'ip/multicast-ttl) => '_ip_multicast_ttl
  7;; (define-for-syntax (local s)
  8;;   (string->symbol
  9;;    (string-append "_" (string-translate (symbol->string s) "/-" #\_))))
 10;; (local 'ip/multicast-ttl) => 'IP_MULTICAST_TTL
 11(define-for-syntax (local sym)
 12  (string->symbol
 13   (string-translate (string-upcase (symbol->string sym)) "/-" #\_)))
 14;; (c-name 'ip/multicast-ttl) => "IP_MULTICAST_TTL"
 15(define-for-syntax (c-name sym)
 16  (string-translate (string-upcase (symbol->string sym)) "/-" #\_))
 17
 18;; (define-socket-int so/reuseaddr) =>
 19;;    (begin (define-foreign-variable SO_REUSEADDR "SO_REUSEADDR")
 20;;           (define so/reuseaddr (if (= SO_REUSEADDR -1) #f SO_REUSEADDR)))
 21(define-syntax define-socket-int
 22  (er-macro-transformer
 23   (lambda (e r c)
 24     (let ((sym (cadr e))
 25           (str (cddr e)))
 26       (let ((str (if (pair? str) (car str) (c-name sym)))
 27             (lname (local sym)))
 28         `(,(r 'begin)
 29           (,(r 'define-foreign-variable) ,lname ,(r 'int) ,str)
 30           (,(r 'define) ,sym ,lname)))))))
 31
 32(define-syntax define-socket-ints
 33  (er-macro-transformer
 34   (lambda (e r c)
 35     `(,(r 'begin)
 36       ,@(map (lambda (sym)
 37                (if (pair? sym)
 38                    `(,(r 'define-socket-int) ,(car sym) ,(cadr sym))
 39                    `(,(r 'define-socket-int) ,sym)))
 40              (cdr e))))))
 41
 42;; (define-optional-socket-int so/reuseaddr)
 43;;  => (cond-expand (SO_REUSEADDR
 44;;                   (define-foreign-variable SO_REUSEADDR int "SO_REUSEADDR")
 45;;                   (define so/reuseaddr SO_REUSEADDR))
 46;;                  (else
 47;;                   (define so/reuseaddr #f))))
 48(define-syntax define-optional-socket-int
 49  (er-macro-transformer
 50   (lambda (e r c)
 51     (let ((sym (cadr e))
 52           (str (cddr e)))
 53       (let ((str (if (pair? str) (->string (car str)) (c-name sym)))
 54             (lname (local sym)))
 55         (let ((feat (string->symbol str)))
 56           `(,(r 'cond-expand)
 57             (,feat 
 58              (,(r 'define-foreign-variable) ,lname ,(r 'int) ,str)
 59              (,(r 'define) ,sym ,lname))
 60             (,(r 'else)
 61              (,(r 'define) ,sym #f)))))))))
 62
 63(define-syntax define-optional-socket-ints
 64  (er-macro-transformer
 65   (lambda (e r c)
 66     `(,(r 'begin)
 67       ,@(map (lambda (sym)
 68                (if (pair? sym)
 69                    `(,(r 'define-optional-socket-int) ,(car sym) ,(cadr sym))
 70                    `(,(r 'define-optional-socket-int) ,sym)))
 71              (cdr e))))))
 72
 73;; (define-socket-option ipv6-v6-only? ipproto/ipv6 ipv6/v6only set-boolean-option get-boolean-option) =>
 74;; (begin
 75;;   (define ipv6-v6-only?
 76;;     (if (or (= _ipproto_ipv6 -1) (= _ipv6_v6only -1))
 77;;       (getter-with-setter
 78;;         (lambda (s)
 79;;           (unsupported-error 'ipv6-v6-only? "socket option or level unsupported"))
 80;;         (lambda (s v)
 81;;           (unsupported-error 'ipv6-v6-only? "socket option or level unsupported")))
 82;;       (getter-with-setter
 83;;         (lambda (s) (get-boolean-option s _ipproto_ipv6 _ipv6_v6only))
 84;;         (lambda (s v) (set-boolean-option s _ipproto_ipv6 _ipv6_v6only v))))))
 85
 86;; When option or level undefined, define the procedure to simply
 87;; return a nice error.  We could pass an invalid option or level
 88;; (such as -1) through to get/setsockopt, but this is more meaningful
 89;; and safer.  (Note this does use the foreign-vars instead of
 90;; the constants, so it needs to test for -1 instead of #f.)
 91
 92(define (unsupported-socket-option name)
 93  ;; Deduplicates code in define-socket-option.  More savings could
 94  ;; be achieved by not printing "name".
 95  (unsupported-error name "socket option unavailable on this platform"))
 96
 97(define-syntax define-socket-option
 98  (er-macro-transformer
 99   (lambda (e r c)
100     (let ((name (cadr e))
101           (level (caddr e))
102           (optname (cadddr e))
103           (set (car (cddddr e)))
104           (get (cadr (cddddr e))))
105       `(,(r 'define) ,name
106         (,(r 'getter-with-setter)
107          (,(r 'lambda) (s) (,get ',name s ,(local level) ,(local optname)))
108          (,(r 'lambda) (s v) (,set ',name s ,(local level) ,(local optname) v))))))))
109
110(define-syntax define-boolean-option
111  (syntax-rules ()
112    ((_ name level optname)
113     (define-socket-option name level optname set-boolean-option get-boolean-option))))
114
115(define-syntax define-integer-option
116  (syntax-rules ()
117    ((_ name level optname)
118     (define-socket-option name level optname set-integer-option get-integer-option))))
119
120;; Like define-socket-option, but performs a feature test on the level and optname,
121;; choosing whether option is supported at compile time instead of runtime.
122;; Assumes foreign variables have been declared by define-optional-socket-ints.
123(define-syntax define-optional-socket-option
124  (er-macro-transformer
125   (lambda (e r c)
126     (define (feature-name x) (string->symbol (c-name x)))
127     (let ((name (cadr e))
128           (level (caddr e))
129           (optname (cadddr e))
130           (set (car (cddddr e)))
131           (get (cadr (cddddr e)))
132           (%unsup (gensym)))
133       `(,(r 'define) ,name
134         (,(r 'cond-expand)
135          ((,(r 'and) ,(feature-name level) ,(feature-name optname))
136           (,(r 'getter-with-setter)
137            (,(r 'lambda) (s) (,get ',name s ,(local level) ,(local optname)))
138            (,(r 'lambda) (s v) (,set ',name s ,(local level) ,(local optname) v))))
139          (,(r 'else)
140           (,(r 'let) ((,%unsup
141                        (,(r 'lambda) _
142                         (,(r 'unsupported-socket-option) ',name))))
143            (,(r 'getter-with-setter) ,%unsup ,%unsup)))))))))
144
145(define-syntax define-optional-boolean-option
146  (syntax-rules ()
147    ((_ name level optname)
148     (define-optional-socket-option name level optname
149       set-boolean-option get-boolean-option))))
150
151(define-syntax define-optional-integer-option
152  (syntax-rules ()
153    ((_ name level optname)
154     (define-optional-socket-option name level optname
155       set-integer-option get-integer-option))))
156
157;;; FFI
158
159(define setsockopt (foreign-lambda int "setsockopt" int int int scheme-pointer int))
160(define getsockopt (foreign-lambda int "typecorrect_getsockopt" int int int scheme-pointer c-pointer))
161
162(define setsockopt/int
163  (foreign-lambda* int ((int sock) (int level) (int name) (int val))
164                   "return(setsockopt(sock, level, name, (const void *)&val, sizeof(val)));"))
165(define getsockopt/int
166  (foreign-lambda* int ((int sock) (int level) (int name) ((c-pointer int) ret))
167                   "socklen_t sz = sizeof(*ret);"
168                   "return(typecorrect_getsockopt(sock, level, name, ret, &sz));"))
169
170;;; getters and setters
171
172(define-inline (check-boolean where x)
173  (unless (boolean? x)
174    (type-error where "bad argument type: not a boolean" x)))
175(define-inline (check-error where err)
176  (let ((no errno))
177    (when (fx= -1 err)
178      (if (or (fx= no _enoprotoopt)  ;; False + on  Win for e.g. sock/dgram when stream expected
179              (fx= no _einval))      ;; Maybe incorrect level; but false + on dgram when stream expected
180          (unsupported-error where (strerror no))
181          (begin
182            (##sys#update-errno)
183            (##sys#signal-hook #:network-error where (strerror no)))))))
184
185(define (set-integer-option where s level name val)
186  (##sys#check-exact val where)
187  (let ((s (if (socket? s) (socket-fileno s) s)))
188    (let ((err (setsockopt/int s level name val)))
189      (check-error where err)
190      (void))))
191
192(define (set-boolean-option where s level name val)
193  (check-boolean where val)
194  (set-integer-option where s level name (if val 1 0)))
195(define (get-boolean-option where s level name)
196  (not (= 0 (get-integer-option where s level name))))
197
198(define (get-integer-option where s level name)
199  (let ((s (if (socket? s) (socket-fileno s) s)))
200    (let-location ((val int))
201      (let ((err (getsockopt/int s level name (location val))))
202        (check-error where err)
203        val))))
204
205(define (set-readonly-option where s level name val)
206  (network-error where "socket option is read-only"))
207
208;;; generic lowlevel interface
209
210;; This interface is likely to change or go away completely.  Complex manipulation
211;; might be easier done in C.
212
213;; (set-socket-option S ipproto/tcp tcp/nodelay 1)
214;; (set-socket-option S ipproto/tcp tcp/nodelay (make-string 4 #\x0))
215;; (set-socket-option S sol/socket so/rcvlowat (u32vector->blob/shared (u32vector #x01020304)))
216;; (get-socket-option S ipproto/tcp tcp/nodelay)
217
218;; complex example
219
220#|
221(define (make-linger-storage)
222  (make-blob (foreign-value "sizeof(struct linger)" int)))
223(define (encode-linger-option state time)
224  (let ((blob (make-linger-storage)))
225    ((foreign-lambda* void ((scheme-pointer ptr) (int onoff) (int linger))
226                      "struct linger *p = ptr;"
227                      "p->l_onoff = onoff; p->l_linger = linger;")
228     blob state time)
229    blob))
230(define (decode-linger-option blob)
231  ; sanity checking recommended here
232  (list ((foreign-lambda* int ((scheme-pointer p)) "return(((struct linger *)p)->l_onoff);") blob)
233        ((foreign-lambda* int ((scheme-pointer p)) "return(((struct linger *)p)->l_linger);") blob)))
234
235;; (set-socket-option S sol/socket so/linger (encode-linger-option 1 100))
236;; (decode-linger-option (get-socket-option S sol/socket so/linger (make-linger-storage)))
237|#
238
239(define (set-socket-option s level name val)
240  (cond ((not level)
241         (unsupported-error 'set-socket-option "socket option level not supported"))
242        ((not name)
243         (unsupported-error 'set-socket-option "socket option not supported"))
244        (else
245         (let ((s (if (socket? s) (socket-fileno s) s)))
246           (cond ((boolean? val)
247                  (set-boolean-option 'set-socket-option s level name val))
248                 ((fixnum? val)
249                  (set-integer-option 'set-socket-option s level name val))
250                 ((blob? val)
251                  (check-error 'set-socket-option
252                               (setsockopt s level name val (blob-size val))))
253                 ((string? val)
254                  (check-error 'set-socket-option
255                               (setsockopt s level name val (string-length val))))
256                 (else
257                  (##sys#signal-hook #:type-error
258                                     'set-socket-option
259                                     "bad option value" val)))))))
260
261;; Get socket option on socket S at socket level LEVEL with option name NAME.
262;; If len is #f (the default) it assumes the option is an integer value.
263;; Otherwise allocates temporary space of LEN bytes and copies the result into
264;; a fresh blob of the length returned by the getsockopt() call; returns the blob.
265;; If you know the correct length ahead of time, no copy is done.
266;; (get-socket-option s sol/socket so/reuseaddr 1024) => #${04000000}
267;; (get-socket-option s sol/socket so/reuseaddr)      => 4
268(define (get-socket-option s level name #!optional len)
269  (cond ((not level)
270         (unsupported-error 'get-socket-option "socket option level not supported"))
271        ((not name)
272         (unsupported-error 'get-socket-option "socket option not supported"))
273        ((not len)
274         (get-integer-option 'get-socket-option s level name))
275        (else
276         (let ((buf (make-blob len)))
277           (let-location ((sz int len))
278             (let ((s (if (socket? s) (socket-fileno s) s)))
279               ;; FIXME: Report unsupported error correctly
280               (check-error 'get-socket-option (getsockopt s level name buf (location sz))))
281             (if (= sz len)
282                 buf
283                 (let ((retbuf (make-blob sz)))
284                   ((foreign-lambda void C_memcpy scheme-pointer scheme-pointer int)
285                    retbuf buf sz)
286                   retbuf)))))))
287
288;;; socket integers
289
290;; Optional socket ints must be defined as foreign features.
291(define-optional-socket-ints
292  so/useloopback so/reuseport so/timestamp so/exclusiveaddruse
293
294  tcp/maxseg tcp/nopush tcp/noopt tcp/keepalive
295
296  ip/mtu ip/mtu-discover
297  ip/pktinfo ip/recverr ip/recvtos ip/recvttl ip/router-alert 
298  ip/recvopts ip/recvretopts ip/retopts ip/recvdstaddr
299
300  ;; NB There's probably a subset of IPv6 options these that we can require
301  ;; when IPv6 is enabled (i.e. error out on if undefined).
302  ipv6/v6only ipv6/addrform ipv6/mtu
303  ipv6/mtu-discover ipv6/multicast-hops ipv6/multicast-if ipv6/multicast-loop ipv6/pktinfo 
304  ipv6/rthdr ipv6/authhdr ipv6/dstopts ipv6/hopopts ipv6/flowinfo ipv6/hoplimit
305  ipv6/recverr ipv6/router-alert ipv6/unicast-hops ipv6/nexthop
306  ipv6/port-range ipv6/join-group ipv6/leave-group ipv6/checksum
307  ;; ipv6/add-membership ipv6/drop-membership   ;; OBSOLETE synonyms for JOIN/LEAVE_GROUP
308  ;; ipv6/options ipv6/recvopts ipv6/recvretopts ipv6/retopts ipv6/recvdstaddr ;; DEPRECATED
309
310  ipproto/ipv6)
311
312(define-socket-ints
313;; socket options
314  so/reuseaddr so/debug so/acceptconn so/keepalive so/dontroute
315  so/broadcast so/linger so/oobinline so/sndbuf so/rcvbuf
316  so/sndlowat so/rcvlowat so/sndtimeo so/rcvtimeo so/error so/type
317
318;; tcp options
319  tcp/nodelay
320
321;; ip options
322  ip/options ip/hdrincl ip/tos ip/ttl
323  ip/multicast-if ip/multicast-ttl ip/multicast-loop
324  ip/add-membership ip/drop-membership
325
326;; ipv6 options
327  
328;; socket levels
329  sol/socket ipproto/ip ipproto/icmp
330; ipproto/tcp ipproto/udp            ;; already provided in socket.scm
331)
332
333;;; socket-level options
334
335(cond-expand
336 ((and windows SO_EXCLUSIVEADDRUSE)
337  ;; Windows semantics of so/reuseaddr are basically nonsense,
338  ;; so use so/exclusiveaddruse for correct semantics.  However,
339  ;; this may fail without admin privs on WinXP<SP3 and Win2k<SP4,
340  ;; so on failure fall back to so/reuseaddr (better than nothing).
341  ;; Also, so/exclusiveaddruse may not be available, so we explicitly feature
342  ;; test for it; define-socket-option expects the foreign var to be defined,
343  ;; and define-optional-socket-option won't fall back to so/reuseaddr.
344  (define (set-reuse-option where s level name val)
345    (handle-exceptions exn
346        (set-boolean-option where s level so/reuseaddr val)
347      (set-boolean-option where s level name val)))
348  (define (get-reuse-option where s level name)
349    (handle-exceptions exn
350        (get-boolean-option where s level so/reuseaddr)
351      (get-boolean-option where s level name)))
352
353  (define-socket-option so-reuse-address? sol/socket so/exclusiveaddruse
354                        set-reuse-option get-reuse-option))
355 (else
356  (define-boolean-option so-reuse-address? sol/socket so/reuseaddr)))
357
358(define-boolean-option so-debug? sol/socket so/debug)
359(define-socket-option  so-accept-connections? sol/socket so/acceptconn set-readonly-option get-boolean-option)
360(define-boolean-option so-keep-alive? sol/socket so/keepalive)
361(define-boolean-option so-dont-route? sol/socket so/dontroute)
362(define-boolean-option so-broadcast? sol/socket so/broadcast)
363;(define-socket-option so-linger sol/socket so/linger set-linger-option get-linger-option)
364(define-boolean-option so-oob-inline? sol/socket so/oobinline)
365(define-integer-option so-send-buffer sol/socket so/sndbuf)
366(define-integer-option so-receive-buffer sol/socket so/rcvbuf)
367(define-integer-option so-send-low-water sol/socket so/sndlowat)
368(define-integer-option so-receive-low-water sol/socket so/rcvlowat)
369;(define-socket-option so-receive-timeout sol/socket so/rcvtimeo set-timeval-option get-timeval-option)
370;(define-socket-option so-send-timeout sol/socket so/sndtimeo set-timeval-option get-timeval-option)
371(define-socket-option  so-error sol/socket so/error set-readonly-option get-integer-option)
372(define-socket-option  so-type sol/socket so/type set-readonly-option get-integer-option)
373
374;;; TCP options
375
376(define-boolean-option tcp-no-delay? ipproto/tcp tcp/nodelay)
377(define-optional-integer-option tcp-max-segment-size ipproto/tcp tcp/maxseg)
378(define-optional-boolean-option tcp-no-push? ipproto/tcp tcp/nopush)
379(define-optional-boolean-option tcp-no-options? ipproto/tcp tcp/noopt)
380(define-optional-integer-option tcp-keep-alive ipproto/tcp tcp/keepalive)
381
382;;; IP options
383
384;; Most of the IP option interface is currently unimplemented as it
385;; seems to differ widely between systems.
386;; TODO Multicast should be implemented if present.
387(define-boolean-option ip-header-included? ipproto/ip ip/hdrincl)
388(define-integer-option ip-type-of-service ipproto/ip ip/tos)
389(define-integer-option ip-time-to-live ipproto/ip ip/ttl)
390
391(define-optional-socket-option ipv6-v6-only? ipproto/ipv6 ipv6/v6only
392  set-boolean-option get-boolean-option)
393;;(define-boolean-option ipv6-v6-only? ipproto/ipv6 ipv6/v6only)
394