source: project/unix-sockets/unix-sockets.scm @ 5014

Last change on this file since 5014 was 5014, checked in by felix winkelmann, 13 years ago

new fp release (tagged)

File size: 9.4 KB
Line 
1;;;; unix-sockets.scm
2;
3; Copyright (c) 2000-2005, Felix L. Winkelmann
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
7; conditions are met:
8;
9;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
10;     disclaimer.
11;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
12;     disclaimer in the documentation and/or other materials provided with the distribution.
13;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
14;     products derived from this software without specific prior written permission.
15;
16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
24; POSSIBILITY OF SUCH DAMAGE.
25;
26; Send bugs, suggestions and ideas to:
27;
28; felix@call-with-current-continuation.org
29;
30; Felix L. Winkelmann
31; Unter den Gleichen 1
32; 37130 Gleichen
33; Germany
34
35
36(declare
37  (uses srfi-18)
38  (export unix-connect
39          unix-accept
40          unix-accept-ready?
41          unix-listener-fileno unix-listener-path
42          unix-close
43          unix-listener?
44          unix-listen) )
45
46
47#>
48#include <fcntl.h>
49#include <sys/types.h>
50#include <unistd.h>
51#include <errno.h>
52#include <sys/socket.h>
53#include <sys/un.h>
54#include <sys/time.h>
55
56static struct sockaddr_un socket_name;
57<#
58
59#>!
60static int
61create_socket(const char *filename, int backlog)
62{
63  int sock;
64  socklen_t size;
65     
66  /* Create the socket. */
67  sock = socket (PF_LOCAL, SOCK_STREAM, 0);
68
69  if (sock < 0) return -1;
70     
71  /* Bind a name to the socket. */
72  socket_name.sun_family = AF_LOCAL;
73  strncpy (socket_name.sun_path, filename, sizeof (socket_name.sun_path));
74  socket_name.sun_path[sizeof (socket_name.sun_path) - 1] = '\0';
75  size = SUN_LEN(&socket_name);
76     
77  if(bind (sock, (struct sockaddr *) &socket_name, size) < 0) return -1;
78
79  if(listen(sock, backlog) < 0) return -1;
80
81  return sock;
82}
83
84     
85static int
86connect_to_server(const char *filename)
87{
88  int sock;
89  socklen_t size;
90     
91  /* Create the socket. */
92  sock = socket (PF_LOCAL, SOCK_STREAM, 0);
93
94  if (sock < 0) return -1;
95     
96  socket_name.sun_family = AF_LOCAL;
97  strncpy(socket_name.sun_path, filename, sizeof(socket_name.sun_path));
98  socket_name.sun_path[sizeof (socket_name.sun_path) - 1] = '\0';
99  size = SUN_LEN(&socket_name);
100
101  /* Connect to the server. */
102  if (connect(sock, (struct sockaddr *) &socket_name, size) < 0)
103    return -1;
104
105  return sock;
106}
107
108
109static int
110accept_connection(int sock, char *filename)
111{
112  int s2;
113  socklen_t size;
114
115  socket_name.sun_family = AF_LOCAL;
116  strncpy(socket_name.sun_path, filename, sizeof(socket_name.sun_path));
117  socket_name.sun_path[sizeof (socket_name.sun_path) - 1] = '\0';
118  size = SUN_LEN(&socket_name);
119  s2 = accept(sock, (struct sockaddr *)&socket_name, &size);
120
121  if(s2 < 0) return -1;
122
123  return s2;
124}
125<#
126
127
128(define strerror (foreign-lambda c-string "strerror" int))
129(define close (foreign-lambda void "close" int))
130(define fd-read (foreign-lambda int "read" int pointer int))
131(define fd-write (foreign-lambda int "write" int pointer int))
132
133(define-foreign-variable errno int)
134
135(define-foreign-variable EWOULDBLOCK int)
136(define-foreign-variable SHUT_RD int)
137(define-foreign-variable SHUT_WR int)
138
139(define (unix-error loc msg . args)
140  (signal
141   (make-composite-condition
142    (make-property-condition 'exn 'message (string-append msg " - " (strerror errno)) 'location loc args args)
143    (make-property-condition 'unix 'errno errno) ) ) )
144
145(define (unix-connect filename)
146  (let ([n (##sys#pathname-resolution filename (lambda (f) (connect_to_server f)))])
147    (if (negative? n)
148        (unix-error 'unix-connect "can not connect" filename)
149        (io-ports 'unix-connect n) ) ) )
150
151(define-constant +buffer-size+ 1024)
152
153(define make-nonblocking
154  (foreign-lambda* bool ([int fd])
155    "int val = fcntl(fd, F_GETFL, 0);"
156    "if(val == -1) return(0);"
157    "return(fcntl(fd, F_SETFL, val | O_NONBLOCK) != -1);") )
158
159(define (yield)
160  (##sys#call-with-current-continuation
161   (lambda (return)
162     (let ((ct ##sys#current-thread))
163       (##sys#setslot ct 1 (lambda () (return (##core#undefined))))
164       (##sys#schedule) ) ) ) )
165
166(define select-read
167  (foreign-lambda* int ((int fd))
168    "fd_set in;
169     struct timeval tm;
170     FD_ZERO(&in);
171     FD_SET(fd, &in);
172     tm.tv_sec = tm.tv_usec = 0;
173     if(select(fd + 1, &in, NULL, NULL, &tm) == -1) return(-1);
174     else return(FD_ISSET(fd, &in) ? 1 : 0);") )
175
176#;(define select-write
177  (foreign-lambda* int ((int fd))
178    "fd_set out;
179     struct timeval tm;
180     FD_ZERO(&out);
181     FD_SET(fd, &out);
182     tm.tv_sec = tm.tv_usec = 0;
183     if(select(fd + 1, NULL, &out, NULL, &tm) == -1) return(-1);
184     else return(FD_ISSET(fd, &out) ? 1 : 0);") )
185
186(define shutdown (foreign-lambda int "shutdown" int int))
187
188(define io-ports
189  (let ([make-input-port make-input-port]
190        [make-output-port make-output-port] 
191        [make-string make-string] 
192        [substring substring] )
193    (lambda (loc fd)
194      (unless (make-nonblocking fd)
195        (unix-error loc "can not create unix socket ports") )
196      (let* ([buf (make-string +buffer-size+)]
197             [data (vector fd #f #f)]
198             [buflen 0]
199             [bufindex 0]
200             [iclosed #f] 
201             [oclosed #f]
202             [in
203              (make-input-port
204               (lambda ()
205                 (when (fx>= bufindex buflen)
206                   (let ([n (let loop ()
207                              (let ([n (fd-read fd buf +buffer-size+)])
208                                (if (eq? -1 n)
209                                    (if (eq? errno EWOULDBLOCK) 
210                                        (begin
211                                          (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
212                                          (yield)
213                                          (loop) )
214                                        (unix-error loc "can not read from socket" fd) )
215                                    n) ) ) ] )
216                     (set! buflen n)
217                     (set! bufindex 0) ) )
218                 (if (fx>= bufindex buflen)
219                     #!eof
220                     (let ([c (##core#inline "C_subchar" buf bufindex)])
221                       (set! bufindex (fx+ bufindex 1))
222                       c) ) )
223               (lambda ()
224                 (or (fx< bufindex buflen)
225                     (let ([f (select-read fd)])
226                       (when (eq? f -1)
227                         (unix-error loc "can not check socket for input" fd) )
228                       (eq? f 1) ) ) )
229               (lambda ()
230                 (unless iclosed
231                   (set! iclosed #t)
232                   (unless (##sys#slot data 1) (shutdown fd SHUT_RD))
233                   (when (and oclosed (eq? -1 (close fd)))
234                     (unix-error loc "can not close socket input port" fd) ) ) ) ) ]
235             [out
236              (make-output-port
237               (lambda (s) 
238                 (let ([len (##sys#size s)])
239                   (let loop ()
240                     (let ([n (fd-write fd s len)])
241                       (cond [(eq? -1 n)
242                              (if (eq? errno EWOULDBLOCK)
243                                  (begin
244                                    ;(##sys#thread-block-for-i/o! ##sys#current-thread fd #f)
245                                    (yield) 
246                                    (loop) )
247                                  (unix-error loc "can not write to socket" fd s) ) ]
248                             [(fx< n len)
249                              (set! s (substring s n len))
250                              (set! len (##sys#size s))
251                              (loop) ] ) ) ) ) )
252               (lambda ()
253                 (unless oclosed
254                   (set! oclosed #t)
255                   (unless (##sys#slot data 2) (shutdown fd SHUT_WR))
256                   (when (and iclosed (eq? -1 (close fd)))
257                     (unix-error loc "can not close socket output port" fd) ) ) ) ) ] )
258        (##sys#setslot in 3 "(unix)")
259        (##sys#setslot out 3 "(unix)")
260        (##sys#setslot in 7 'socket)
261        (##sys#setslot out 7 'socket)
262        (##sys#setslot (##sys#port-data in) 0 data)
263        (##sys#setslot (##sys#port-data out) 0 data)
264        (values in out) ) ) ) )
265
266(define (unix-listen filename #!optional (backlog 10))
267  (when (file-exists? filename)
268    (delete-file filename) )
269  (let ([n (##sys#pathname-resolution filename (lambda (name) (create_socket name backlog)))])
270    (if (negative? n)
271        (unix-error 'unix-listen "can not create socket" filename)
272        (##sys#make-structure 'unix-listener n filename) ) ) )
273
274(define (unix-accept listener)
275  (##sys#check-structure listener 'unix-listener 'unix-accept)
276  (let ([fd (##sys#slot listener 1)])
277    (let loop ()
278      (if (eq? 1 (select-read fd))
279          (let ([fd (accept_connection fd (##sys#slot listener 2))])
280            (when (negative? fd)
281              (unix-error 'unix-accept "could not accept from listener" listener) )
282            (io-ports 'unix-accept fd) )
283          (begin
284            (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
285            (yield)
286            (loop) ) ) ) ) )
287
288(define (unix-accept-ready? listener)
289  (##sys#check-structure listener 'unix-listener 'unix-accept-ready?)
290  (let ([f (select-read (##sys#slot listener 1))])
291    (when (eq? -1 f)
292      (unix-error 'unix-accept-ready? "can not check socket for input" listener) )
293    (eq? 1 f) ) )
294
295(define (unix-listener? x)
296  (##sys#structure? x 'unix-listener) )
297
298(define (unix-listener-fileno x)
299  (##sys#check-structure x 'unix-listener 'unix-listener-fileno)
300  (##sys#slot x 1) )
301
302(define (unix-listener-path x)
303  (##sys#check-structure x 'unix-listener 'unix-listener-path)
304  (##sys#slot x 2) )
305
306(define (unix-close l)
307  (##sys#check-structure l 'unix-listener)
308  (let ([s (##sys#slot l 1)])
309    (when (fx= -1 (close s))
310      (unix-error 'unix-close "can not close unix socket" l) ) ) )
Note: See TracBrowser for help on using the repository browser.