PageRenderTime 24ms CodeModel.GetById 1ms app.highlight 19ms RepoModel.GetById 1ms app.codeStats 1ms

/scheme/net/socket.scm

https://bitbucket.org/ebb/scheme48
Lisp | 348 lines | 282 code | 54 blank | 12 comment | 0 complexity | 5b419a5d21cf512dbfc9f405b97560ef MD5 | raw file
  1; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.
  2
  3; Sockets
  4
  5(define-record-type socket :socket
  6  (really-make-socket address-family type
  7		      channel condvar
  8		      input-port output-port)
  9  socket?
 10  (address-family socket-address-family)
 11  (type socket-socket-type)
 12  (channel socket-channel)
 13  (condvar socket-condvar) ; for blocking until a connection arrives
 14  (input-port socket-input-port set-socket-input-port!)
 15  (output-port socket-output-port set-socket-output-port!))
 16
 17(define-record-discloser :socket
 18  (lambda (s)
 19    (list 'socket 
 20	  (socket-address-family s)
 21	  (socket-socket-type s)
 22	  (socket-channel s))))
 23
 24(define (channel->socket family type channel)
 25  (really-make-socket family type
 26		      channel
 27		      (make-condvar) #f #f))
 28
 29(define (attach-socket-ports! socket output-channel)
 30  (let ((input-channel (socket-channel socket)))
 31    (set-socket-input-port!
 32     socket
 33     (input-channel+closer->port input-channel close-socket-input-channel))
 34    (set-socket-output-port!
 35     socket
 36     (output-channel+closer->port output-channel close-socket-output-channel))))
 37			
 38(define make-socket
 39  (opt-lambda (family type (protocol 0)) ; ####
 40    (channel->socket family type
 41		     (external-socket (address-family->raw family)
 42				      (socket-type->raw type)
 43				      protocol))))
 44
 45(import-lambda-definition-2 external-socket (family type protocol)
 46			  "s48_socket")
 47
 48(define (dup-socket sock)
 49  (channel->socket (socket-address-family sock)
 50		   (socket-socket-type sock)
 51		   (external-dup-socket-channel (socket-channel sock))))
 52
 53(define make-socket-pair
 54  (opt-lambda (family type (protocol 0))
 55    (let ((p (external-socketpair (address-family->raw family)
 56				  (socket-type->raw type)
 57				  protocol)))
 58      (let ((s1 (channel->socket family type (car p)))
 59	    (s2 (channel->socket family type (cdr p))))
 60	(attach-socket-ports! s1 (external-dup-socket-channel (car p)))
 61	(attach-socket-ports! s2 (external-dup-socket-channel (cdr p)))
 62	(values s1 s2)))))
 63
 64(import-lambda-definition-2 external-socketpair (family type protocol)
 65			  "s48_socketpair")
 66
 67; Close the channel, notifying any waiters that this has happened.
 68
 69(define (close-socket socket)
 70  (cond
 71   ((or (socket-input-port socket) (socket-output-port socket))
 72    (cond 
 73     ((socket-input-port socket) => close-input-port)
 74     ((socket-output-port socket) => close-output-port)))
 75   (else
 76    (let ((channel (socket-channel socket)))
 77      (with-new-proposal (lose)
 78	(or (channel-maybe-commit-and-close channel close-channel)
 79	    (lose)))))))
 80
 81(define (bind-socket socket address)
 82  (external-bind (socket-channel socket)
 83		 (socket-address-raw address)))
 84
 85(import-lambda-definition-2 external-bind (channel address)
 86			  "s48_bind")
 87
 88(define socket-listen
 89  (opt-lambda (socket (queue-size (max-socket-connection-count)))
 90    (external-listen (socket-channel socket)
 91		     queue-size)))
 92
 93(import-lambda-definition-2 external-listen (channel queue-size)
 94			  "s48_listen")
 95(import-lambda-definition-2 max-socket-connection-count ()
 96			  "s48_max_connection_count")
 97
 98; FreeBSD's connect() behaves oddly.  If you get told to wait, wait for select()
 99; to signal the all-clear, and then try to connect again, you get an `already
100; connected' error.  To handle this we pass in a RETRY? flag.  If RETRY? is
101; true the `already connected' error is ignored.
102
103(define (socket-connect socket address)
104  (let ((channel (socket-channel socket))
105	(raw-address (socket-address-raw address)))
106    (let loop ((retry? #f))
107      (disable-interrupts!)
108      (let ((output-channel (external-connect channel raw-address retry?)))
109	(cond ((channel? output-channel)
110	       (enable-interrupts!)
111	       (attach-socket-ports! socket output-channel))
112	      ((eq? output-channel #t)
113	       (assertion-violation 'socket-client
114				    "client socket already connected"
115				    socket address))
116	      (else
117	       (let ((condvar (make-condvar)))
118		 (wait-for-channel channel condvar)
119		 (with-new-proposal (lose)
120		   (maybe-commit-and-wait-for-condvar condvar))
121		 (enable-interrupts!)
122		 (loop #t))))))))
123
124(import-lambda-definition-2 external-connect (channel address retry?)
125			  "s48_connect")
126
127(define (socket-accept socket)
128  (let* ((channel (blocking-socket-op socket external-accept))
129	 (newsock (channel->socket (socket-address-family socket)
130				   (socket-socket-type socket)
131				   channel)))
132    (attach-socket-ports! newsock (external-dup-socket-channel channel))
133    newsock))
134
135(import-lambda-definition-2 external-accept (channel retry?)
136			  "s48_accept")
137(import-lambda-definition-2 external-dup-socket-channel (channel)
138			  "s48_dup_socket_channel")
139
140; Keep performing OP until it returns a non-#F value.  In between attempts we
141; block on the socket's channel.
142
143(define (blocking-socket-op socket op)
144  (let ((channel (socket-channel socket))
145	(condvar (socket-condvar socket)))
146    (let loop ((retry? #f))
147      (disable-interrupts!)
148      (cond ((op channel retry?)
149	     => (lambda (result)
150		  (enable-interrupts!)
151		  result))
152	    (else
153	     (wait-for-channel channel condvar)
154	     (with-new-proposal (lose)
155	       (maybe-commit-and-wait-for-condvar condvar))
156	     (enable-interrupts!)
157	     (loop #t))))))
158
159;----------------
160; We need to explicitly close socket channels.
161
162(define-enumeration shutdown-option
163  (read write read/write)
164  shutdown-option-set)
165
166(define shutdown-option->raw (enum-set-indexer (shutdown-option-set)))
167
168(define (shutdown-socket socket how)
169  (shutdown-socket-channel (socket-channel socket) how))
170
171(define (shutdown-socket-channel channel how)
172  (external-shutdown channel (shutdown-option->raw how)))
173
174(import-lambda-definition-2 external-shutdown (channel how)
175			  "s48_shutdown")
176
177(define (close-socket-input-channel channel)
178  (shutdown-socket-channel channel (shutdown-option read))
179  (close-channel channel))
180
181(define (close-socket-output-channel channel)
182  (shutdown-socket-channel channel (shutdown-option write))
183  (close-channel channel))
184
185(define (socket-address socket)
186  (raw->socket-address
187   (external-getsockname (socket-channel socket))))
188
189(import-lambda-definition-2 external-getsockname (channel)
190			  "s48_getsockname")
191
192(define (socket-peer-address socket)
193  (raw->socket-address
194   (external-getpeername (socket-channel socket))))
195
196(import-lambda-definition-2 external-getpeername (channel)
197			  "s48_getpeername")
198
199
200(define-syntax define-socket-option-setter
201  (syntax-rules ()
202    ((define-socket-option-setter ?name ?external-name)
203     (begin
204       (define (?name socket val)
205	 (external-setsockopt (socket-channel socket) val))
206       
207       (import-lambda-definition-2 external-setsockopt (channel val)
208				 ?external-name)))))
209
210(define-syntax define-socket-option-getter
211  (syntax-rules ()
212    ((define-socket-option-getter ?name ?external-name)
213     (begin
214       (define (?name socket)
215	 (external-getsockopt (socket-channel socket)))
216       
217       (import-lambda-definition-2 external-getsockopt (channel)
218				 ?external-name)))))
219
220
221(define-socket-option-setter set-socket-debug?!
222  "s48_setsockopt_SO_DEBUG")
223(define-socket-option-getter socket-debug?!
224  "s48_getsockopt_SO_DEBUG")
225(define-socket-option-setter set-socket-accept-connections?!
226  "s48_setsockopt_SO_ACCEPTCONN")
227(define-socket-option-getter socket-accept-connections?
228  "s48_getsockopt_SO_ACCEPTCONN")
229(define-socket-option-setter set-socket-broadcast?!
230  "s48_setsockopt_SO_BROADCAST")
231(define-socket-option-getter socket-broadcast?
232  "s48_getsockopt_SO_BROADCAST")
233(define-socket-option-setter set-socket-reuse-address?!
234  "s48_setsockopt_SO_REUSEADDR")
235(define-socket-option-getter socket-reuse-address?
236  "s48_getsockopt_SO_REUSEADDR")
237(define-socket-option-setter set-socket-keepalive?!
238  "s48_setsockopt_SO_KEEPALIVE")
239(define-socket-option-getter socket-keepalive?
240  "s48_getsockopt_SO_KEEPALIVE")
241(define-socket-option-setter set-socket-oob-inline?!
242  "s48_setsockopt_SO_OOBINLINE")
243(define-socket-option-getter socket-oob-inline?
244  "s48_getsockopt_SO_OOBINLINE")
245(define-socket-option-setter set-socket-send-buffer-size!
246  "s48_setsockopt_SO_SNDBUF")
247(define-socket-option-getter socket-send-buffer-size
248  "s48_getsockopt_SO_SNDBUF")
249(define-socket-option-setter set-socket-receive-buffer-size!
250  "s48_setsockopt_SO_RCVBUF")
251(define-socket-option-getter socket-receive-buffer-size
252  "s48_getsockopt_SO_RCVBUF")
253(define-socket-option-getter socket-error
254  "s48_getsockopt_SO_ERROR")
255(define-socket-option-setter set-socket-dontroute?!
256  "s48_setsockopt_SO_DONTROUTE")
257(define-socket-option-getter socket-dontroute?
258  "s48_getsockopt_SO_DONTROUTE")
259(define-socket-option-setter set-socket-minimum-receive-count!
260  "s48_setsockopt_SO_RCVLOWAT")
261(define-socket-option-getter socket-minimum-receive-count
262  "s48_getsockopt_SO_RCVLOWAT")
263(define-socket-option-setter set-socket-minimum-send-count!
264  "s48_setsockopt_SO_SNDLOWAT")
265(define-socket-option-getter socket-minimum-send-count
266  "s48_getsockopt_SO_SNDLOWAT")
267
268(define-socket-option-setter set-socket-ipv6-unicast-hops!
269  "s48_setsockopt_IPV6_UNICAST_HOPS")
270(define-socket-option-getter socket-ipv6-unicast-hops
271  "s48_getsockopt_IPV6_UNICAST_HOPS")
272(define-socket-option-setter set-socket-ipv6-multicast-interface!
273  "s48_setsockopt_IPV6_MULTICAST_IF")
274(define-socket-option-getter socket-ipv6-multicast-interface
275  "s48_getsockopt_IPV6_MULTICAST_IF")
276(define-socket-option-setter set-socket-ipv6-multicast-hops!
277  "s48_setsockopt_IPV6_MULTICAST_HOPS")
278(define-socket-option-getter socket-ipv6-multicast-hops
279  "s48_getsockopt_IPV6_MULTICAST_HOPS")
280(define-socket-option-setter set-socket-ipv6-multicast-loop?!
281  "s48_setsockopt_IPV6_MULTICAST_LOOP")
282(define-socket-option-getter socket-ipv6-multicast-loop?
283  "s48_getsockopt_IPV6_MULTICAST_LOOP")
284
285(define (socket-ipv6-join-group! socket address interface)
286  (external-ipv6-socket-join-group (socket-channel socket)
287				   (socket-address-raw address)
288				   (interface-index interface)))
289
290(import-lambda-definition-2 external-ipv6-socket-join-group (channel address if-index)
291			  "s48_ipv6_socket_join_group")
292
293(define (socket-ipv6-leave-group! socket address interface)
294  (external-ipv6-socket-leave-group (socket-channel socket)
295				    (socket-address-raw address)
296				    (interface-index interface)))
297
298(import-lambda-definition-2 external-ipv6-socket-leave-group (channel address if-index)
299			  "s48_ipv6_socket_leave_group")
300			  
301
302; Messages
303
304(define-enumeration message-option
305  (oob peek dontroute)
306  message-options)
307
308(define socket-send
309  (opt-lambda (socket
310	       buffer
311	       (start 0)
312	       (count (byte-vector-length buffer))
313	       (address (socket-peer-address socket)) ; cache this?
314	       (flags (message-options)))
315    (blocking-socket-op socket
316			(lambda (channel retry?)
317			  (external-sendto channel buffer start count
318					   (enum-set->integer flags)
319					   (socket-address-raw address)
320					   retry?)))))
321
322(import-lambda-definition-2 external-sendto (channel
323					   buffer start count flags address
324					   retry?)
325			  "s48_sendto")
326
327(define socket-receive
328  (opt-lambda (socket
329	       buffer
330	       (start 0)
331	       (count (byte-vector-length buffer))
332	       (want-sender? #t)
333	       (flags (message-options)))
334    (let ((got
335	   (blocking-socket-op socket
336			       (lambda (channel retry?)
337				 (external-recvfrom channel buffer start count
338						    (enum-set->integer flags)
339						    want-sender?
340						    retry?)))))
341      (if want-sender?
342	  (values (car got) (raw->socket-address (cdr got)))
343	  got))))
344
345(import-lambda-definition-2 external-recvfrom (channel
346					     buffer start count flags
347					     want-sender? retry?)
348			  "s48_recvfrom")