source: project/nondescript/sockets/sockets.scm @ 35339

Last change on this file since 35339 was 2448, checked in by elf, 14 years ago

updated. do not use.

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