source: project/release/3/sockets/sockets.scm @ 18200

Last change on this file since 18200 was 11397, checked in by elf, 11 years ago

another fix to make dns notice that the procedures do, in fact, exist

File size: 22.9 KB
Line 
1;;; sockets.ss v0.9 - 11 Seep 2006
2;;; taken from udp, as shown below
3;;; udp.ss v1.0 - 23 December 2003 - Category 5
4;;;         1.1 - 24 March 2004
5;;;               wrapped low-level I/O calls with restart-nonblocking
6;;;
7;;; An interface to the User Datagram Protocol socket system calls,
8;;; written for the CHICKEN Scheme compiler:
9;;;   http://www.call-with-current-continuation.org/
10
11;;; Example:
12;;;  csi> (require 'udp)
13;;;  ; loading /usr/local/lib/chicken/udp.so ...
14;;;  csi> (define s (udp-open-socket))
15;;;  csi> (udp-bind! s #f 0)
16;;;  csi> (udp-connect! s "localhost" 13)  ; daytime service
17;;;  csi> (udp-send s "\n")
18;;;  csi> (receive (n data from-host from-port) (udp-recvfrom s 64)
19;;;         (print* n " bytes from " from-host ":" from-port ": " data))
20;;;  26 bytes from 127.0.0.1:13: Wed Dec 24 11:53:14 2003
21;;;  csi> (udp-close-socket s)
22;;;  csi>
23
24
25; ----------------------------TERMS OF USE--------------------------------
26; Copyright (c) 2003-2004, Category 5
27; All rights reserved.
28;
29; Redistribution and use in source and binary forms, with or without
30; modification, are permitted provided that the following conditions are
31; met:
32;
33;   Redistributions of source code must retain the above copyright notice,
34;   this list of conditions and the following disclaimer. Redistributions in
35;   binary form must reproduce the above copyright notice, this list of
36;   conditions and the following disclaimer in the documentation and/or
37;   other materials provided with the distribution. Neither the name of the
38;   author nor the names of its contributors may be used to endorse or
39;   promote products derived from this software without specific prior
40;   written permission.
41;
42; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
43; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
44; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
45; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
46; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
47; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
48; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
49; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
50; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
51; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
52; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
53; ----------------------------TERMS OF USE--------------------------------
54
55
56(declare
57; (unit sockets)
58 (uses extras srfi-18)
59 (usual-integrations)
60 (fixnum-arithmetic)
61 (no-bound-checks)
62 (export io:event-dispatch io:descriptor io:read-handler io:write-handler
63         io:exception-handler io:set-read-handler! io:set-write-handler!
64         io:set-exception-handler!
65         socket? socket-udp? socket-tcp? socket-bound? socket-connected?
66         socket-listener?
67         socket-open socket-open* socket-bind! socket-connect! socket-send
68         socket-sendto socket-recv socket-recvfrom socket-close 
69         socket-bound-port socket-accept socket-listen socket-select
70         udp-set-multicast-interface udp-join-multicast-group)
71 (emit-exports "sockets.exports")
72 (bound-to-procedure
73  ##net#socket ##net#bind ##net#connect ##net#close ##net#recv ##net#recvfrom
74  ##net#accept ##net#listen
75  ##net#send ##net#sendto ##net#select ##net#gethostaddr ##sys#update-errno
76  ##sys#error ##sys#signal-hook ##net#make-nonblocking ##net#hstrerror
77  ##net#inaddr->string ##net#inaddr-port ##net#error ##net#herror
78  ##net#get-host-or-error syscall-failed?
79  ##io#select))
80
81(register-feature! 'udp)
82
83(cond-expand
84 [unsafe
85  (eval-when (compile)
86             (define-macro (##sys#check-structure x y) '(##core#undefined))
87             (define-macro (##sys#check-range x y z) '(##core#undefined))
88             (define-macro (##sys#check-pair x) '(##core#undefined))
89             (define-macro (##sys#check-list x) '(##core#undefined))
90             (define-macro (##sys#check-symbol x) '(##core#undefined))
91             (define-macro (##sys#check-string x) '(##core#undefined))
92             (define-macro (##sys#check-char x) '(##core#undefined))
93             (define-macro (##sys#check-exact x) '(##core#undefined))
94             (define-macro (##sys#check-port x) '(##core#undefined))
95             (define-macro (##sys#check-number x) '(##core#undefined))
96             (define-macro (##sys#check-byte-vector x) '(##core#undefined)))]
97 [else])
98
99
100;;; ------- copied from tcp.scm, more or less -------
101#>
102
103# include <errno.h>
104#ifdef _WIN32
105# if _MSC_VER > 1300
106# include <winsock2.h>
107# include <ws2tcpip.h>
108# else
109# include <winsock.h>
110# endif
111# define EWOULDBLOCK     0
112# define socklen_t       int
113static WSADATA wsa;
114# define hstrerror strerror
115
116const char *inet_ntop(int af, const void *src, char *dst, socklen_t cnt)
117{
118        if (af == AF_INET)
119        {
120                struct sockaddr_in in;
121                memset(&in, 0, sizeof(in));
122                in.sin_family = AF_INET;
123                memcpy(&in.sin_addr, src, sizeof(struct in_addr));
124                getnameinfo((struct sockaddr *)&in, sizeof(struct
125sockaddr_in), dst, cnt, NULL, 0, NI_NUMERICHOST);
126                return dst;
127        }
128        else if (af == AF_INET6)
129        {
130                struct sockaddr_in6 in;
131                memset(&in, 0, sizeof(in));
132                in.sin6_family = AF_INET6;
133                memcpy(&in.sin6_addr, src, sizeof(struct in_addr6));
134                getnameinfo((struct sockaddr *)&in, sizeof(struct
135sockaddr_in6), dst, cnt, NULL, 0, NI_NUMERICHOST);
136                return dst;
137        }
138        return NULL;
139}
140
141#else
142# include <fcntl.h>
143# include <sys/types.h>
144# include <sys/socket.h>
145# include <sys/time.h>
146# include <netinet/in.h>
147# include <arpa/inet.h>
148# include <unistd.h>
149# include <netdb.h>
150# include <signal.h>
151# define closesocket     close
152# define INVALID_SOCKET  -1
153#endif
154
155#ifndef INET_ADDRSTRLEN
156#define INET_ADDRSTRLEN 16
157#endif
158
159<#
160
161(define-foreign-variable errno int "errno")
162(define-foreign-variable h_errno int "h_errno")
163
164(define-foreign-variable _af_inet int "AF_INET")
165(define-foreign-variable _sock_stream int "SOCK_STREAM")
166(define-foreign-variable _sock_dgram int "SOCK_DGRAM")
167(define-foreign-variable _sockaddr_in_size int "sizeof(struct sockaddr_in)")
168(define-foreign-variable _ipproto_udp int "IPPROTO_UDP")
169(define-foreign-variable _ipproto_tcp int "IPPROTO_TCP")
170(define-foreign-variable _invalid_socket int "INVALID_SOCKET")
171(define-foreign-variable _ewouldblock int "EWOULDBLOCK")
172
173(define ##net#socket (foreign-lambda int "socket" int int int))
174(define ##net#bind (foreign-lambda int "bind" int pointer int))
175(define ##net#close (foreign-lambda int "closesocket" int))
176(define ##net#send (foreign-lambda int "send" int pointer int int))
177(define ##net#sendto (foreign-lambda int "sendto" int pointer int int pointer int))
178(define ##net#recv (foreign-lambda int "recv" int pointer int int))
179(define ##net#recvfrom (foreign-lambda int "recvfrom" int pointer int int pointer c-pointer))
180(define ##net#connect (foreign-lambda int "connect" int pointer int))
181(define ##net#listen (foreign-lambda int "listen" int int))
182(define ##net#accept (foreign-lambda int "accept" int pointer pointer))
183
184(define ##net#make-nonblocking
185  (foreign-lambda* bool ([int fd])
186#<<EOF
187#ifdef _WIN32
188  unsigned long mode = 1;
189  if(ioctlsocket(fd, FIONBIO, &mode)) {
190    errno = WSAGetLastError();
191    fprintf(stderr, "ioctlsocket failed: errno=%d\n", errno);
192    return(0);
193  }else{
194    return(1);
195  }
196#else
197  int val = fcntl(fd, F_GETFL, 0);
198  if(val == -1) return(0);
199  return(fcntl(fd, F_SETFL, val | O_NONBLOCK) != -1);
200#endif
201EOF
202))
203
204(define ##net#getsockport
205  (foreign-lambda* int ([int s])
206    "struct sockaddr_in sa;"
207    "int len = sizeof(struct sockaddr_in);"
208    "if(getsockname(s, (struct sockaddr *)&sa, (socklen_t *)&len) != 0) return(-1);"
209    "else return(ntohs(sa.sin_port));") )
210
211(define ##net#gethostaddr
212  (foreign-lambda* bool ((pointer saddr) (c-string host) (unsigned-short port))
213    "struct hostent *he = gethostbyname(host);"
214    "struct sockaddr_in *addr = (struct sockaddr_in *)saddr;"
215    "if(he == NULL) return(0);"
216    "memset(addr, 0, sizeof(struct sockaddr_in));"
217    "addr->sin_family = AF_INET;"
218    "addr->sin_port = htons((short)port);"
219    "addr->sin_addr = *((struct in_addr *)he->h_addr);"
220    "return(1);"))
221
222(define ##net#startup
223  (foreign-lambda* bool () #<<EOF
224#ifdef _WIN32
225     return(WSAStartup(MAKEWORD(1, 1), &wsa) == 0);
226#else
227     signal(SIGPIPE, SIG_IGN);
228     return(1);
229#endif
230EOF
231) )
232
233(unless (##net#startup)
234  (##sys#signal-hook #:network-error "can not initialize Winsock") )
235;;; ------- end of code from tcp.scm -------
236
237(define ##net#hstrerror (foreign-lambda c-string "hstrerror" int))
238
239;;; ##io#select : fd-vec fd-vec fd-vec timeout-secs timeout-usecs -> int
240;;; take three vectors of fds we want to read from, write from, and
241;;; handle exceptional events from, plus a timeout in seconds+microseconds,
242;;; and call select(2).  Mutate the vector slots to be -1 if the relevant
243;;; event didn't occur, otherwise leave them set to the fd number so we can
244;;; reverse-map the fds back to their socket container structures later.
245(define ##io#select
246  (foreign-lambda* int ((scheme-object rv)
247                        (scheme-object wv)
248                        (scheme-object ev)
249                        (int secs) (int usecs))
250#<<EOF
251  fd_set rfds, wfds, efds;
252  int nrfds, nwfds, nefds;
253  int *ra, *wa, *ea;
254  int maxfd = -1;
255  struct timeval tv;
256  int i, ret;
257
258  FD_ZERO(&rfds);
259  FD_ZERO(&wfds);
260  FD_ZERO(&efds);
261  tv.tv_sec = secs;
262  tv.tv_usec = usecs;
263
264  nrfds = C_header_size(rv);
265  nwfds = C_header_size(wv);
266  nefds = C_header_size(ev);
267 
268  ra = (int *)malloc(nrfds*sizeof(int));
269  wa = (int *)malloc(nwfds*sizeof(int));
270  ea = (int *)malloc(nefds*sizeof(int));
271
272  for (i=0; i < nrfds; i++) {
273       ra[i] = C_unfix(C_block_item(rv, i));
274       FD_SET(ra[i], &rfds);
275       if (ra[i] > maxfd)
276          maxfd = ra[i];
277  }
278  for (i=0; i < nwfds; i++) {
279       wa[i] = C_unfix(C_block_item(wv, i));
280       FD_SET(wa[i], &wfds);
281       if (wa[i] > maxfd)
282          maxfd = wa[i];
283  }
284  for (i=0; i < nefds; i++) {
285       ea[i] = C_unfix(C_block_item(ev, i));
286       FD_SET(ea[i], &efds);
287       if (ea[i] > maxfd)
288         maxfd = ea[i];
289  }
290
291  ret = select(maxfd+1, &rfds, &wfds, &efds,
292                        tv.tv_sec == -1 ? NULL : &tv);
293
294  if (ret > 0) {
295    for (i=0; i < nrfds; i++) {
296      if (!FD_ISSET(ra[i], &rfds))
297        C_mutate(&C_block_item(rv, i), C_fix(-1));
298    }
299    for (i=0; i < nwfds; i++) {
300      if (!FD_ISSET(wa[i], &wfds))
301        C_mutate(&C_block_item(wv, i), C_fix(-1));
302    }
303    for (i=0; i < nefds; i++) {
304      if (!FD_ISSET(ea[i], &efds))
305        C_mutate(&C_block_item(ev, i), C_fix(-1));
306    }
307  }
308  free(ra);
309  free(wa);
310  free(ea);
311  return(ret);
312EOF
313))
314
315;;; ##net#make-in-addr-any-addr : sockaddr-in-pointer port -> bool
316;;; make a sockaddr_in structure with the address set to INADDR_ANY
317;;; and the specified port.
318(define ##net#make-in-addr-any-addr
319  (foreign-lambda* bool ((pointer saddr) (int port))
320#<<EOF
321  struct sockaddr_in *addr = (struct sockaddr_in *)saddr;
322  memset(addr, 0, sizeof(struct sockaddr_in));
323  addr->sin_family = AF_INET;
324  addr->sin_port = htons(port);
325  addr->sin_addr.s_addr = INADDR_ANY;
326  return(1);
327EOF
328))
329
330;;; ##net#inaddr->string : sockaddr-in-pointer -> c-string
331;;; Use inet_ntop(3) to turn a sockaddr_in address into a string.
332(define ##net#inaddr->string
333  (foreign-lambda* c-string ((pointer saddr))
334#<<EOF
335  static char s[INET_ADDRSTRLEN];
336  struct sockaddr_in *addr = (struct sockaddr_in *)saddr;
337  if (inet_ntop(AF_INET, &addr->sin_addr.s_addr, s, sizeof(s)) == NULL)
338    return(NULL);
339  return(s);
340EOF
341))
342;;; ##net#inaddr-port : sockaddr-in-pointer -> int
343;;; return the port number of a sockaddr_in structure.
344(define ##net#inaddr-port
345  (foreign-lambda* int ((pointer saddr))
346#<<EOF
347  struct sockaddr_in *addr = (struct sockaddr_in *)saddr;
348  return(ntohs(addr->sin_port));
349EOF
350))
351
352
353;;; error-signaling calls
354(define ##net#error
355  (lambda args
356    (##sys#update-errno)
357    (apply ##sys#signal-hook #:network-error args)))
358(define ##net#herror
359  (lambda (host)
360    (##net#error "hostname lookup failed" host (##net#hstrerror h_errno))))
361(define ##net#get-host-or-error
362  (lambda (sa host port)
363    (if (not (##net#gethostaddr sa host port))
364        (##net#herror host))))
365
366(define syscall-failed?
367  (lambda (arg)
368    (eq? arg -1)))
369
370(define-foreign-variable error-message c-string "strerror(errno)")
371
372(define restart-nonblocking
373  (lambda (name fd i/o thunk)
374    (let ((return-code (thunk)))
375      (cond ((not (eq? return-code -1)) return-code)
376            ((eq? errno _ewouldblock)
377             (##sys#thread-block-for-i/o! ##sys#current-thread fd i/o)
378             (yield)
379             (restart-nonblocking name fd i/o thunk))
380            (else (##net#error error-message name))))))
381
382(define (yield)
383  (##sys#call-with-current-continuation
384   (lambda (return)
385     (let ((ct ##sys#current-thread))
386       (##sys#setslot ct 1 (lambda () (return (##core#undefined))))
387       (##sys#schedule) ) ) ) )
388
389;;; io:event-dispatch : slist timeout-secs timeout-usecs -> bool
390;;; high-level interface to ##io#select - take a list of descriptors
391;;; packaged in records that have, among other things, slots for read,
392;;; write, and exception handler callback procedures.  Extract the
393;;; fd numbers we want to handle events from, call ##io#select, and
394;;; use the results to run the handlers for the events that occurred.
395(define io:event-dispatch
396  (lambda (slist . args)
397  (let-optionals args
398     ((timeout-secs -1) (timeout-usecs -1) (timeout-handler #f))
399       (let ((readers (map (lambda (s) (cons (##sys#slot s 1) s))
400                           (filter (lambda (s) (##sys#slot s 4)) slist)))
401             (writers (map (lambda (s) (cons (##sys#slot s 1) s))
402                           (filter (lambda (s) (##sys#slot s 5)) slist)))
403             (cepters (map (lambda (s) (cons (##sys#slot s 1) s))
404                           (filter (lambda (s) (##sys#slot s 6)) slist))))
405         (let ((rv (list->vector (map car readers)))
406               (wv (list->vector (map car writers)))
407               (ev (list->vector (map car cepters))))
408           (let ((ret (##io#select rv wv ev timeout-secs timeout-usecs)))
409             (cond ((syscall-failed? ret) (##net#error "select"))
410                   ((fx= ret 0) (and (procedure? timeout-handler)
411                                   (timeout-handler slist)))
412                   (else
413                    (let ((readable (map (lambda (fd) (cdr (assq fd readers)))
414                                         (remove (lambda (fd) (fx= fd -1)) (vector->list rv))))
415                          (writable (map (lambda (fd) (cdr (assq fd writers)))
416                                         (remove (lambda (fd) (fx= fd -1)) (vector->list wv))))
417                          (ceptable (map (lambda (fd) (cdr (assq fd cepters)))
418                                         (remove (lambda (fd) (fx= fd -1)) (vector->list ev)))))
419                      (for-each (lambda (s) ((##sys#slot s 4) s)) readable)
420                      (for-each (lambda (s) ((##sys#slot s 5) s)) writable)
421                      (for-each (lambda (s) ((##sys#slot s 6) s)) ceptable)
422                      #t)))))))))
423
424(define socket-select (lambda (s t)
425    (let ((ret (##io#select (vector (##sys#slot s 1)) (vector) (vector) t 0)))
426        (if (syscall-failed? ret)
427            (##net#error "select")
428            ret))))
429
430;;; socket structure slots:
431;;; 1  2      3          4            5             6              7         8
432;;; fd bound? connected? read-handler write-handler except-handler listener? type
433(define (socket? x)
434    (and (##core#inline "C_blockp" x)
435         (##sys#structure? x 'socket)))
436(define (socket-udp? x)
437    (and (socket? x)
438         (eq? (##sys#slot s 8) 'udp)))
439(define (socket-tcp? x)
440    (and (socket? x)
441         (eq? (##sys#slot s 8) 'tcp)))
442(define (socket-bound? s)
443  (and (socket? s) (##sys#slot s 2)))
444(define (socket-connected? s)
445  (and (socket? s) (##sys#slot s 3)))
446(define (socket-listener? s)
447    (and (socket? s) (##sys#slot s 7)))
448
449;;; udp-open-socket : -> udp-socket
450(define socket-open
451  (lambda (t)
452    (let ((s (case t
453                 ((udp) (##net#socket _af_inet _sock_dgram 0))
454                 ((tcp) (##net#socket _af_inet _sock_stream 0))
455                 (else  (##sys#signal-hook #:network-error "invalid type")))))
456      (if (syscall-failed? s)
457          (##net#error "socket")
458          (if (eq? t 'udp)
459              (##sys#make-structure 'socket s #f #f #f #f #f #f 'udp)
460              (##sys#make-structure 'socket s #f #f #f #f #f #f 'tcp))))))
461
462(define io:descriptor (lambda (s) (##sys#slot s 1)))
463(define io:read-handler (lambda (s) (##sys#slot s 4)))
464(define io:write-handler (lambda (s) (##sys#slot s 5)))
465(define io:exception-handler (lambda (s) (##sys#slot s 6)))
466(define io:set-read-handler! (lambda (s p) (##sys#setslot s 4 p)))
467(define io:set-write-handler! (lambda (s p) (##sys#setslot s 5 p)))
468(define io:set-exception-handler! (lambda (s p) (##sys#setslot s 6 p)))
469
470;;; udp-open-socket* : -> udp-socket
471;;; open a UDP socket and make it nonblocking
472(define socket-open*
473  (lambda (t)
474    (let ((s (socket-open t)))
475      (and (socket? s) (##net#make-nonblocking (io:descriptor s)) s))))
476;;; udp-bind! : udp-socket host-string port-number -> unspecified
477;;; bind a socket to a local address (possibly INADDR_ANY) and port
478(define socket-bind!
479  (lambda (sock host port)
480    (let ((fd (io:descriptor sock))
481          (addr (make-string _sockaddr_in_size)))
482      (if host
483          (##net#get-host-or-error addr host port)
484          (##net#make-in-addr-any-addr addr port))
485      (if (syscall-failed? (##net#bind fd addr _sockaddr_in_size))
486          (##net#error "bind" host port)
487          (##sys#setslot sock 2 #t)))))
488
489(define socket-bound-port
490  (lambda (sock)
491    (let* ([fd (io:descriptor sock)]
492           [port (##net#getsockport fd)])
493      (if (eq? -1 port)
494        (##net#error "getsockport"))
495      port)))
496
497;;; udp-connect! : udp-socket host-string port -> unspecified
498;;; "connect" a socket.  In the case of UDP this does nothing more than
499;;; store a peer address in the kernel socket structure for use with
500;;; later calls to send(2).
501(define socket-connect!
502  (lambda (sock host port)
503    (let ((fd (io:descriptor sock))
504          (addr (make-string _sockaddr_in_size)))
505      (##net#get-host-or-error addr host port)
506      (if (syscall-failed? (##net#connect fd addr _sockaddr_in_size))
507          (##net#error "connect" host port)
508          (##sys#setslot sock 3 #t)))))
509
510;; socket-listen
511(define socket-listen
512    (lambda (sock backlog)
513        (and (not (socket-tcp? sock))
514             (##sys#signal-hook #:network-error "invalid type - not tcp"))
515        (and (not (socket-bound? sock))
516             (##sys#signal-hook #:network-error "not a bound socket"))
517        (if (syscall-failed? (##net#listen (io:descriptor sock) backlog))
518            (##net#error "listen" (io:descriptor sock))
519            (##sys#setslot sock 7 #t))))
520
521;;; socket-accept
522(define socket-accept
523    (lambda (sock)
524        (and (not (socket-tcp? sock))
525             (##sys#signal-hook #:network-error "invalid type"))
526        (and (not (socket-listener? sock))
527             (##sys#signal-hook #:network-error "not listener socket"))
528        (let ((s (##net#accept (io:descriptor sock) #f #f)))
529            (if (syscall-failed? s)
530                (##net#error "accept" (io:descriptor sock))
531                (##sys#make-structure 'socket s #t #t #f #f #f #f 'tcp)))))
532       
533
534;;; udp-send : udp-socket string -> unspecified
535;;; send bytes in string to the peer for this socket as specified earlier
536;;; with udp-connect!.  If the socket was not "connected", send(2) will
537;;; raise an error.
538(define socket-send
539  (lambda (sock str)
540    (let ((fd (io:descriptor sock)))
541      (restart-nonblocking "send" fd #f
542       (lambda ()
543         (##net#send fd str (string-length str) 0))))))
544
545;;; udp-sendto : udp-socket host-string port-num string -> unspecified
546;;; send bytes in string to host:port via udp-socket.
547(define socket-sendto
548  (lambda (sock host port str)
549    (let ((fd (io:descriptor sock))
550          (addr (make-string _sockaddr_in_size)))
551      (##net#get-host-or-error addr host port)
552      (restart-nonblocking "sendto" fd #f
553        (lambda () (##net#sendto fd str (string-length str)
554                                 0 addr _sockaddr_in_size))))))
555                         
556;;; udp-recv : udp-socket string -> [len packet]
557;;; receive a packet and store the data in string, returning the
558;;; length of the packet and the substring of len bytes.
559(define socket-recv
560  (lambda (sock len)
561    (let ((fd (io:descriptor sock))
562          (buf (make-string len)))
563      (let ((result
564             (restart-nonblocking "recv" fd #t
565               (lambda () (##net#recv fd buf len 0)))))
566          (values result (substring buf 0 result))))))
567
568     
569;;; udp-recvfrom : udp-socket string -> [len packet host-string port-num]
570;;; like recv but returns four values, including the length of the
571;;; received packet and the host and port from which it was received.
572(define socket-recvfrom
573  (lambda (sock len)
574    (let ((fd (io:descriptor sock))
575          (buf (make-string len))
576          (from (make-string _sockaddr_in_size)))
577      (let-location ((fromlen int _sockaddr_in_size))
578        (let ((result
579               (restart-nonblocking "recvfrom" fd #t
580                                    (lambda () (##net#recvfrom fd buf len
581                                                               0 from #$fromlen)))))
582          (values result (substring buf 0 result)
583                  (##net#inaddr->string from) (##net#inaddr-port from)))))) )
584
585;;; udp-close-socket : udp-socket -> bool
586;;; close a socket.
587(define socket-close
588  (lambda (sock)
589    (let ((fd (io:descriptor sock)))
590      (if (syscall-failed? (##net#close fd)) #f #t))))
591
592;;; multicast
593(define ##net#set-multicast-interface
594  (foreign-lambda* bool ((int s) (c-string host))
595#<<EOF
596#ifdef _WIN32
597  DWORD ipaddr;
598#else
599  in_addr_t ipaddr;
600#endif
601  ipaddr = inet_addr(host);
602  return (setsockopt(s, IPPROTO_IP, IP_MULTICAST_IF, &ipaddr, sizeof(ipaddr)) == 0);
603EOF
604))
605
606(define udp-set-multicast-interface
607  (lambda (sock interface-host)
608    (let ([fd (io:descriptor sock)])
609      (or (##net#set-multicast-interface fd interface-host)
610          (##net#error "udp-set-multicast-interface" error-message)))))
611
612(define ##net#join-multicast-group
613  (foreign-lambda* bool ((int s) (c-string ihost) (c-string mhost) (bool join))
614#<<EOF
615  struct ip_mreq mreq;
616  int optname;
617  if (ihost) {
618    mreq.imr_interface.s_addr = inet_addr(ihost);
619  } else {
620    mreq.imr_interface.s_addr = INADDR_ANY;
621  }
622  mreq.imr_multiaddr.s_addr = inet_addr(mhost);
623  if (join) {
624    optname = IP_ADD_MEMBERSHIP;
625  } else {
626    optname = IP_DROP_MEMBERSHIP;
627  }
628  return (setsockopt(s, IPPROTO_IP, optname, &mreq, sizeof(mreq)) == 0);
629EOF
630))
631
632(define udp-join-multicast-group
633  (lambda (sock interface-host multicast-host . opt)
634    (let ([fd (io:descriptor sock)]
635          [join (:optional opt #t)])
636      (or (##net#join-multicast-group fd interface-host multicast-host join)
637          (##net#error "udp-join-multicast-group" error-message)))))
638
639;;; END
Note: See TracBrowser for help on using the repository browser.