source: project/udp/udp.scm @ 3

Last change on this file since 3 was 3, checked in by felix winkelmann, 14 years ago

udp/test-infrastructure changes; added futures

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