PageRenderTime 48ms CodeModel.GetById 2ms app.highlight 41ms RepoModel.GetById 1ms app.codeStats 0ms

/scheme/net/address.scm

https://bitbucket.org/ebb/scheme48
Lisp | 482 lines | 383 code | 80 blank | 19 comment | 0 complexity | d68865be9266bbc6c03c8e516bc084ae MD5 | raw file
  1; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.
  2
  3; We still need IDNA support.
  4
  5(define-external-enum-type-with-unknowns address-family
  6  (inet inet6 unix unspec)
  7  unknown-address-family :unknown-address-family
  8  make-unknown-address-family unknown-address-family? unknown-address-family-number
  9  100
 10  address-family? address-family->raw raw->address-family)
 11
 12;; IPv4
 13
 14(define-record-type ipv4-address :ipv4-address
 15  (really-make-ipv4-address ip)
 16  ipv4-address?
 17  ;; 32-bit number
 18  (ip ipv4-address-ip
 19      set-ipv4-address-ip!)) ; internal use only
 20
 21(define (split-ip ip)
 22  (list (arithmetic-shift ip -24)
 23	(bitwise-and (arithmetic-shift ip -16) #xFF)
 24	(bitwise-and (arithmetic-shift ip -8) #xFF)
 25	(bitwise-and ip #xFF)))
 26
 27(define-record-discloser :ipv4-address
 28  (lambda (r)
 29    (cons 'ipv4-address (split-ip (ipv4-address-ip r)))))
 30
 31;; This works the same way as the dot notation for IP addresses
 32(define (make-ipv4-address a . rest)
 33  (really-make-ipv4-address
 34   (cond
 35    ((null? rest) a)
 36    ((null? (cdr rest))
 37     (bitwise-ior (arithmetic-shift a 24) 
 38		  (car rest)))
 39    ((null? (cddr rest))
 40     (bitwise-ior (arithmetic-shift a 24)
 41		  (arithmetic-shift (car rest) 16)
 42		  (cadr rest)))
 43    (else
 44     (bitwise-ior (arithmetic-shift a 24)
 45		  (arithmetic-shift (car rest) 16)
 46		  (arithmetic-shift (cadr rest) 8)
 47		  (caddr rest))))))
 48
 49(import-lambda-definition-2 external-get-inaddr-any () "s48_get_inaddr_any")
 50(import-lambda-definition-2 external-get-inaddr-broadcast () "s48_get_inaddr_broadcast")
 51
 52(define *ipv4-address-any*
 53  (make-ipv4-address (external-get-inaddr-any)))
 54(define *ipv4-address-broadcast*
 55  (make-ipv4-address (external-get-inaddr-broadcast)))
 56(define-reinitializer ipv4-predefined-addresses
 57  (lambda ()
 58    (set-ipv4-address-ip! *ipv4-address-any* (external-get-inaddr-any))
 59    (set-ipv4-address-ip! *ipv4-address-broadcast* (external-get-inaddr-broadcast))))
 60
 61(define (ipv4-address-any) *ipv4-address-any*)
 62(define (ipv4-address-broadcast) *ipv4-address-broadcast*)
 63
 64;; IPv6
 65
 66(define-record-type ipv6-address :ipv6-address
 67  (make-ipv6-address elements)
 68  ipv6-address?
 69  ;; bytevector with 16 elements
 70  (elements ipv6-address-elements
 71	    set-ipv6-address-elements!)) ; internal use
 72
 73(define-record-discloser :ipv6-address
 74  (lambda (r)
 75    (list 'ipv6-address (ipv6-address-elements r))))
 76
 77(import-lambda-definition-2 external-get-in6addr-any () "s48_get_in6addr_any")
 78(import-lambda-definition-2 external-get-in6addr-loopback () "s48_get_in6addr_loopback")
 79
 80(define *ipv6-address-any*
 81  (make-ipv6-address (external-get-in6addr-any)))
 82(define *ipv6-address-loopback*
 83  (make-ipv6-address (external-get-in6addr-loopback)))
 84(define-reinitializer ipv6-predefined-addresses
 85  (lambda ()
 86    (set-ipv6-address-elements! *ipv6-address-any* (external-get-in6addr-any))
 87    (set-ipv6-address-elements! *ipv6-address-loopback* (external-get-in6addr-loopback))))
 88
 89(define (ipv6-address-any) *ipv6-address-any*)
 90(define (ipv6-address-loopback) *ipv6-address-loopback*)
 91
 92;; Socket addresses
 93
 94(define-record-type socket-address :socket-address
 95  (make-socket-address family data raw)
 96  socket-address?
 97  (family socket-address-family)
 98  ;; #f or address-family-specific object
 99  (data socket-address-data)
100  ;; external value containing the sockaddr_storage object
101  (raw real-socket-address-raw set-socket-address-raw!))
102
103(define-record-resumer :socket-address
104  (lambda (r)
105    (set-socket-address-raw! r #f)))
106
107(define (socket-address-raw sa)
108  (or (real-socket-address-raw sa)
109      (cond
110       ((socket-address-data sa)
111	=> (lambda (data)
112	     (let ((raw (make-socket-address-raw data)))
113	       (set-socket-address-raw! sa raw)
114	       raw)))
115       (else
116	(assertion-violation 'socket-address-raw
117			     "socket address of unknown address family couldn't be resumed"
118			     sa)))))
119
120(define-record-discloser :socket-address
121  (lambda (r)
122    (list 'socket-address (socket-address-data r))))
123
124(define (make-socket-address-raw data)
125  (cond
126   ((socket-address-data/ipv4? data)
127    (socket-address-data/ipv4->raw data))
128   ((socket-address-data/ipv6? data)
129    (socket-address-data/ipv6->raw data))
130   ((socket-address-data/unix? data)
131    (socket-address-data/unix->raw data))
132   (else
133    (assertion-violation 'make-socket-address-raw
134			 "unknown socket-address data"
135			 data))))
136
137;; IPv4
138
139(define-record-type socket-address-data/ipv4 :socket-address-data/ipv4
140  (make-socket-address-data/ipv4 address port)
141  socket-address-data/ipv4?
142  (address socket-address-data/ipv4-address)
143  (port socket-address-data/ipv4-port))
144
145(define-record-discloser :socket-address-data/ipv4
146  (lambda (r)
147    (list 'socket-address-data/ipv4
148	  (socket-address-data/ipv4-address r)
149	  (socket-address-data/ipv4-port r))))
150
151(define (make-ipv4-socket-address address port)
152  (make-socket-address
153   (address-family inet)
154   (make-socket-address-data/ipv4 address port)
155   #f))
156
157(define (ipv4-socket-address? obj)
158  (and (socket-address? obj)
159       (socket-address-data/ipv4? (socket-address-data obj))))
160
161(define (socket-address-data/ipv4->raw data)
162  (external-make-sockaddr-in-raw
163   (ipv4-address-ip (socket-address-data/ipv4-address data))
164   (socket-address-data/ipv4-port data)))
165
166(import-lambda-definition-2 external-make-sockaddr-in-raw (addr port)
167			  "s48_make_sockaddr_in_raw")
168
169
170(define (socket-address-ipv4-address sa)
171  (socket-address-data/ipv4-address (socket-address-data sa)))
172(define (socket-address-ipv4-port sa)
173  (socket-address-data/ipv4-port (socket-address-data sa)))
174
175;; IPv6
176
177(define-record-type socket-address-data/ipv6 :socket-address-data/ipv6
178  (make-socket-address-data/ipv6 address port scope-id)
179  socket-address-data/ipv6?
180  (address socket-address-data/ipv6-address)
181  (port socket-address-data/ipv6-port)
182  (scope-id socket-address-data/ipv6-scope-id))
183
184(define-record-discloser :socket-address-data/ipv6
185  (lambda (r)
186    (list 'socket-address-data/ipv6
187	  (socket-address-data/ipv6-address r)
188	  (socket-address-data/ipv6-port r)
189	  (socket-address-data/ipv6-scope-id r))))
190
191(define (make-ipv6-socket-address port address scope-id)
192  (make-socket-address
193   (address-family inet6)
194   (make-socket-address-data/ipv6 address port scope-id)
195   #f))
196
197(define (ipv6-socket-address? obj)
198  (and (socket-address? obj)
199       (socket-address-data/ipv6? (socket-address-data obj))))
200
201(define (socket-address-data/ipv6->raw data)
202  (external-make-sockaddr-in6-raw
203   (ipv6-address-elements (socket-address-data/ipv6-address data))
204   (socket-address-data/ipv6-port data)
205   (socket-address-data/ipv6-scope-id data)))
206
207(import-lambda-definition-2 external-make-sockaddr-in6-raw (addr port scope-id)
208			  "s48_make_sockaddr_in6_raw")
209
210(define (socket-address-ipv6-address sa)
211  (socket-address-data/ipv6-address (socket-address-data sa)))
212(define (socket-address-ipv6-port sa)
213  (socket-address-data/ipv6-address (socket-address-data sa)))
214(define (socket-address-ipv6-scope-id sa)
215  (socket-address-data/ipv6-scope-id (socket-address-data sa)))
216
217;; Unix domain
218
219(define-record-type  socket-address-data/unix :socket-address-data/unix
220  (make-socket-address-data/unix path)
221  socket-address-data/unix?
222  ;; OS-string
223  (path socket-address-data/unix-path))
224
225(define-record-discloser :socket-address-data/unix
226  (lambda (r)
227    (list 'socket-address-data/unix
228	  (socket-address-data/unix-path r))))
229
230(define (make-unix-socket-address path)
231  (make-socket-address
232   (address-family unix)
233   (make-socket-address-data/unix (x->os-string path))
234   #f))
235
236(define (unix-socket-address? obj)
237  (and (socket-address? obj)
238       (socket-address-data/unix? (socket-address-data obj))))
239
240(define (socket-address-data/unix->raw data)
241  (external-make-sockaddr-un-raw
242   (os-string->byte-vector (socket-address-data/unix-path data))))
243
244(import-lambda-definition-2 external-make-sockaddr-un-raw (path)
245			  "s48_make_sockaddr_un_raw")
246
247(define (socket-address-unix-path sa)
248  (socket-address-data/unix-path (socket-address-data sa)))
249
250;; Generic
251
252(define (raw->socket-address raw)
253  (let* ((family (raw->address-family (vector-ref raw 1)))
254	 (data
255	  (case family
256	    ((inet)
257	     (make-socket-address-data/ipv4
258	      (make-ipv4-address (vector-ref raw 3))
259	      (vector-ref raw 2)))
260	    ((inet6)
261	     (make-socket-address-data/ipv6
262	      (make-ipv6-address (vector-ref raw 3))
263	      (vector-ref raw 2)
264	      (vector-ref raw 4)))
265	    ((unix)
266	     (make-socket-address-data/unix
267	      (byte-vector->os-string (vector-ref raw 2))))
268	    (else #f))))
269    (make-socket-address family data (vector-ref raw 0))))
270
271
272;; Interfaces
273
274(define-record-type interface :interface
275  (make-interface name index)
276  interface?
277  (name interface-name)
278  (index interface-index))
279
280(define-record-discloser :interface
281  (lambda (r)
282    (list 'interface
283	  (interface-name r) (interface-index r))))
284
285(define (index->interface idx)
286  (if (and (integer? idx) (exact? idx) (positive? idx))
287      (make-interface (external-interface-index->name idx)
288		      idx)
289      (assertion-violation 'index->interface "invalid argument" idx)))
290
291(define (name->interface name)
292  (let ((index (external-interface-name->index name)))
293    (if (zero? index)
294	#f
295	(make-interface name index))))
296
297(define (get-all-interfaces)
298  (let* ((v (external-interface-index-table))
299	 (count (quotient (vector-length v) 2)))
300    (let loop ((i 0) (rev '()))
301      (if (>= i count)
302	  (reverse rev)
303	  (loop (+ 1 i)
304		(cons (make-interface (vector-ref v (+ 1 (* i 2)))
305				      (vector-ref v (* i 2)))
306		      rev))))))
307      
308(import-lambda-definition-2 external-interface-name->index (name)
309			  "s48_if_nametoindex")
310(import-lambda-definition-2 external-interface-index->name (index)
311			  "s48_if_indextoname")
312(import-lambda-definition-2 external-interface-index-table ()
313			  "s48_if_nameindex")
314
315; Nodename translation
316
317(define-enumeration address-info-flag
318  (passive
319   canonname
320   numerichost)
321  address-info-flags)
322
323(define address-info-flag-set-type (enum-set-type (address-info-flags)))
324
325(define-external-enum-type-with-unknowns ip-protocol
326  (ip ipv6 icmp raw tcp udp)
327  unknown-ip-protocol :unknown-ip-protocol
328  make-unknown-ip-protocol unknown-ip-protocol? unknown-ip-protocol-number
329  100
330  ip-protocol? ip-protocol->raw raw->ip-protocol)
331
332(define-external-enum-type-with-unknowns socket-type
333  (stream dgram raw seqpacket)
334  unknown-socket-type :unknown-socket-type
335  make-unknown-socket-type unknown-socket-type? unknown-socket-type-number
336  100
337  socket-type? socket-type->raw raw->socket-type)
338
339(define-record-type address-info :address-info
340  (make-address-info family socket-type protocol
341		     canonical-name socket-address)
342  address-info?
343  (family address-info-family)
344  (socket-type address-info-socket-type)
345  (protocol address-info-protocol)
346  (canonical-name address-info-canonical-name)
347  (socket-address address-info-socket-address))
348
349(define-record-discloser :address-info
350  (lambda (r)
351    (list 'address-info
352	  (address-info-family r)
353	  (address-info-socket-type r)
354	  (address-info-protocol r)
355	  (address-info-canonical-name r)
356	  (address-info-socket-address r))))
357
358(define (raw->address-info raw)
359  (make-address-info (raw->address-family (vector-ref raw 0))
360		     (raw->socket-type (vector-ref raw 1))
361		     (raw->ip-protocol (vector-ref raw 2))
362		     (vector-ref raw 3)
363		     (raw->socket-address (vector-ref raw 4))))
364
365(define (get-xxx-info retval get-result)
366  (if (pair? retval)
367      (let ((result #f))
368	(dynamic-wind ; we need to release the uid in case the thread gets killed
369	    values
370	    (lambda ()
371	      (wait-for-external-event (car retval)))
372	    (lambda ()
373	      (set! result (get-result (cdr retval)))))
374	result)
375      retval))
376
377(define get-address-info
378  (opt-lambda (node
379	       (server #f)
380	       (hint-flags (address-info-flags))
381	       (hint-family (address-family unspec))
382	       (hint-socket-type #f)
383	       (hint-protocol 'f))
384    (cond
385     ((get-xxx-info
386       (external-getaddrinfo
387	node server
388	(enum-set->integer hint-flags)
389	(address-family->raw hint-family)
390	(and hint-socket-type
391	     (socket-type->raw hint-socket-type))
392	(and hint-protocol
393	     (ip-protocol->raw hint-protocol)))
394       external-getaddrinfo-result)
395      => (lambda (result)
396	   (map raw->address-info
397		(vector->list result))))
398     (else #f))))
399
400(import-lambda-definition-2 external-getaddrinfo (nodename
401						servname
402						hint-flags hint-family
403						hint-socktype hint-protocol)
404			  "s48_getaddrinfo")
405(import-lambda-definition-2 external-getaddrinfo-result (handshake)
406			  "s48_getaddrinfo_result")
407
408(define-enumeration name-info-flag
409  (nofqdn numerichost namereqd numericserv dgram)
410  name-info-flags)
411
412(define get-name-info
413  (opt-lambda (socket-address (flags (name-info-flags)))
414    (let ((p (get-xxx-info
415	      (external-getnameinfo
416	       (socket-address-raw socket-address)
417	       (enum-set->integer flags))
418	      external-getnameinfo-result)))
419      (values (vector-ref p 0) (vector-ref p 1)))))
420
421(import-lambda-definition-2 external-getnameinfo (sock-address flags)
422			  "s48_getnameinfo")
423(import-lambda-definition-2 external-getnameinfo-result (handshake)
424			  "s48_getnameinfo_result")
425
426;; Address conversion
427
428(define (address->string addr)
429  (cond
430   ((ipv4-address? addr)
431    (external-inet-ntop (address-family->raw (address-family inet))
432			(ipv4-address-ip addr)))
433   ((ipv6-address? addr)
434    (external-inet-ntop (address-family->raw (address-family inet6))
435			(ipv6-address-elements addr)))
436   (else
437    (assertion-violation 'address->string "invalid address" addr))))
438
439(define (string->address family rep)
440  (let ((make
441	    (case family
442	      ((inet) make-ipv4-address)
443	      ((inet6) make-ipv6-address)
444	      (else
445	       (assertion-violation 'string->address "invalid address family"
446				    family)))))
447    (cond
448     ((external-inet-pton (address-family->raw family) rep) => make)
449     (else #f))))
450
451(import-lambda-definition-2 external-inet-pton (family rep)
452			  "s48_inet_pton")
453(import-lambda-definition-2 external-inet-ntop (family address)
454			  "s48_inet_ntop")
455
456;; Address testing
457
458(define-syntax define-address-predicate
459  (syntax-rules ()
460    ((define-address-predicate ?name ?external-name)
461     (begin
462       (import-lambda-definition-2 external? (address) ?external-name)
463       (define (?name addr)
464	 (external? (ipv6-address-elements addr)))))))
465
466(define-address-predicate ipv6-address-unspecified? "s48_IN6_IS_ADDR_UNSPECIFIED")
467(define-address-predicate ipv6-address-loopback? "s48_IN6_IS_ADDR_LOOPBACK")
468(define-address-predicate ipv6-address-multicast? "s48_IN6_IS_ADDR_MULTICAST")
469(define-address-predicate ipv6-address-link-local? "s48_IN6_IS_ADDR_LINKLOCAL")
470(define-address-predicate ipv6-address-site-local? "s48_IN6_IS_ADDR_SITELOCAL")
471(define-address-predicate ipv6-address-v4-mapped? "s48_IN6_IS_ADDR_V4MAPPED")
472(define-address-predicate ipv6-address-v4-compat? "s48_IN6_IS_ADDR_V4COMPAT")
473
474(define-address-predicate ipv6-address-multicast-unspecified?
475  "s48_IN6_IS_ADDR_MC_NODELOCAL")
476(define-address-predicate ipv6-address-multicast-unspecified?
477  "s48_IN6_IS_ADDR_MC_LINKLOCAL")
478(define-address-predicate ipv6-address-multicast-org-local?
479  "s48_IN6_IS_ADDR_MC_ORGLOCAL")
480(define-address-predicate ipv6-address-multicast-global?
481  "s48_IN6_IS_ADDR_MC_GLOBAL")
482