123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498 |
- ; Part of Scheme 48 1.9. See file COPYING for notices and license.
- ; Authors: Mike Sperber, Marcus Crestani
- ; We still need IDNA support.
- (define-external-enum-type-with-unknowns address-family
- (inet inet6 unix unspec)
- unknown-address-family :unknown-address-family
- make-unknown-address-family unknown-address-family? unknown-address-family-number
- 100
- address-family? address-family->raw raw->address-family)
- ;; IPv4
- (define-record-type ipv4-address :ipv4-address
- (really-make-ipv4-address ip)
- ipv4-address?
- ;; 32-bit number
- (ip ipv4-address-ip
- set-ipv4-address-ip!)) ; internal use only
- (define (split-ip ip)
- (list (arithmetic-shift ip -24)
- (bitwise-and (arithmetic-shift ip -16) #xFF)
- (bitwise-and (arithmetic-shift ip -8) #xFF)
- (bitwise-and ip #xFF)))
- (define-record-discloser :ipv4-address
- (lambda (r)
- (cons 'ipv4-address (split-ip (ipv4-address-ip r)))))
- ;; This works the same way as the dot notation for IP addresses
- (define (make-ipv4-address a . rest)
- (really-make-ipv4-address
- (cond
- ((null? rest) a)
- ((null? (cdr rest))
- (bitwise-ior (arithmetic-shift a 24)
- (car rest)))
- ((null? (cddr rest))
- (bitwise-ior (arithmetic-shift a 24)
- (arithmetic-shift (car rest) 16)
- (cadr rest)))
- (else
- (bitwise-ior (arithmetic-shift a 24)
- (arithmetic-shift (car rest) 16)
- (arithmetic-shift (cadr rest) 8)
- (caddr rest))))))
- (import-lambda-definition-2 external-get-inaddr-any () "s48_get_inaddr_any")
- (import-lambda-definition-2 external-get-inaddr-broadcast () "s48_get_inaddr_broadcast")
- (define *ipv4-address-any*
- (make-ipv4-address (external-get-inaddr-any)))
- (define *ipv4-address-broadcast*
- (make-ipv4-address (external-get-inaddr-broadcast)))
- (define-reinitializer ipv4-predefined-addresses
- (lambda ()
- (set-ipv4-address-ip! *ipv4-address-any* (external-get-inaddr-any))
- (set-ipv4-address-ip! *ipv4-address-broadcast* (external-get-inaddr-broadcast))))
- (define (ipv4-address-any) *ipv4-address-any*)
- (define (ipv4-address-broadcast) *ipv4-address-broadcast*)
- ;; IPv6
- (define-record-type ipv6-address :ipv6-address
- (make-ipv6-address elements)
- ipv6-address?
- ;; bytevector with 16 elements
- (elements ipv6-address-elements
- set-ipv6-address-elements!)) ; internal use
- (define-record-discloser :ipv6-address
- (lambda (r)
- (list 'ipv6-address (ipv6-address-elements r))))
- (import-lambda-definition-2 external-get-in6addr-any () "s48_get_in6addr_any")
- (import-lambda-definition-2 external-get-in6addr-loopback () "s48_get_in6addr_loopback")
- (define *ipv6-address-any*
- (make-ipv6-address (external-get-in6addr-any)))
- (define *ipv6-address-loopback*
- (make-ipv6-address (external-get-in6addr-loopback)))
- (define-reinitializer ipv6-predefined-addresses
- (lambda ()
- (set-ipv6-address-elements! *ipv6-address-any* (external-get-in6addr-any))
- (set-ipv6-address-elements! *ipv6-address-loopback* (external-get-in6addr-loopback))))
- (define (ipv6-address-any) *ipv6-address-any*)
- (define (ipv6-address-loopback) *ipv6-address-loopback*)
- ;; Socket addresses
- (define-record-type socket-address :socket-address
- (make-socket-address family data raw)
- socket-address?
- (family socket-address-family)
- ;; #f or address-family-specific object
- (data socket-address-data)
- ;; external value containing the sockaddr_storage object
- (raw real-socket-address-raw set-socket-address-raw!))
- (define-record-resumer :socket-address
- (lambda (r)
- (set-socket-address-raw! r #f)))
- (define (socket-address-raw sa)
- (or (real-socket-address-raw sa)
- (cond
- ((socket-address-data sa)
- => (lambda (data)
- (let ((raw (make-socket-address-raw data)))
- (set-socket-address-raw! sa raw)
- raw)))
- (else
- (assertion-violation 'socket-address-raw
- "socket address of unknown address family couldn't be resumed"
- sa)))))
- (define-record-discloser :socket-address
- (lambda (r)
- (list 'socket-address (socket-address-data r))))
- (define (make-socket-address-raw data)
- (cond
- ((socket-address-data/ipv4? data)
- (socket-address-data/ipv4->raw data))
- ((socket-address-data/ipv6? data)
- (socket-address-data/ipv6->raw data))
- ((socket-address-data/unix? data)
- (socket-address-data/unix->raw data))
- (else
- (assertion-violation 'make-socket-address-raw
- "unknown socket-address data"
- data))))
- ;; IPv4
- (define-record-type socket-address-data/ipv4 :socket-address-data/ipv4
- (make-socket-address-data/ipv4 address port)
- socket-address-data/ipv4?
- (address socket-address-data/ipv4-address)
- (port socket-address-data/ipv4-port))
- (define-record-discloser :socket-address-data/ipv4
- (lambda (r)
- (list 'socket-address-data/ipv4
- (socket-address-data/ipv4-address r)
- (socket-address-data/ipv4-port r))))
- (define (make-ipv4-socket-address address port)
- (make-socket-address
- (address-family inet)
- (make-socket-address-data/ipv4 address port)
- #f))
- (define (ipv4-socket-address? obj)
- (and (socket-address? obj)
- (socket-address-data/ipv4? (socket-address-data obj))))
- (define (socket-address-data/ipv4->raw data)
- (external-make-sockaddr-in-raw
- (ipv4-address-ip (socket-address-data/ipv4-address data))
- (socket-address-data/ipv4-port data)))
- (import-lambda-definition-2 external-make-sockaddr-in-raw (addr port)
- "s48_make_sockaddr_in_raw")
- (define (socket-address-ipv4-address sa)
- (socket-address-data/ipv4-address (socket-address-data sa)))
- (define (socket-address-ipv4-port sa)
- (socket-address-data/ipv4-port (socket-address-data sa)))
- ;; IPv6
- (define-record-type socket-address-data/ipv6 :socket-address-data/ipv6
- (make-socket-address-data/ipv6 address port scope-id)
- socket-address-data/ipv6?
- (address socket-address-data/ipv6-address)
- (port socket-address-data/ipv6-port)
- (scope-id socket-address-data/ipv6-scope-id))
- (define-record-discloser :socket-address-data/ipv6
- (lambda (r)
- (list 'socket-address-data/ipv6
- (socket-address-data/ipv6-address r)
- (socket-address-data/ipv6-port r)
- (socket-address-data/ipv6-scope-id r))))
- (define (make-ipv6-socket-address port address scope-id)
- (make-socket-address
- (address-family inet6)
- (make-socket-address-data/ipv6 address port scope-id)
- #f))
- (define (ipv6-socket-address? obj)
- (and (socket-address? obj)
- (socket-address-data/ipv6? (socket-address-data obj))))
- (define (socket-address-data/ipv6->raw data)
- (external-make-sockaddr-in6-raw
- (ipv6-address-elements (socket-address-data/ipv6-address data))
- (socket-address-data/ipv6-port data)
- (socket-address-data/ipv6-scope-id data)))
- (import-lambda-definition-2 external-make-sockaddr-in6-raw (addr port scope-id)
- "s48_make_sockaddr_in6_raw")
- (define (socket-address-ipv6-address sa)
- (socket-address-data/ipv6-address (socket-address-data sa)))
- (define (socket-address-ipv6-port sa)
- (socket-address-data/ipv6-address (socket-address-data sa)))
- (define (socket-address-ipv6-scope-id sa)
- (socket-address-data/ipv6-scope-id (socket-address-data sa)))
- ;; Unix domain
- (define-record-type socket-address-data/unix :socket-address-data/unix
- (make-socket-address-data/unix path)
- socket-address-data/unix?
- ;; OS-string
- (path socket-address-data/unix-path))
- (define-record-discloser :socket-address-data/unix
- (lambda (r)
- (list 'socket-address-data/unix
- (socket-address-data/unix-path r))))
- (define (make-unix-socket-address path)
- (make-socket-address
- (address-family unix)
- (make-socket-address-data/unix (x->os-string path))
- #f))
- (define (unix-socket-address? obj)
- (and (socket-address? obj)
- (socket-address-data/unix? (socket-address-data obj))))
- (define (socket-address-data/unix->raw data)
- (external-make-sockaddr-un-raw
- (os-string->byte-vector (socket-address-data/unix-path data))))
- (import-lambda-definition-2 external-make-sockaddr-un-raw (path)
- "s48_make_sockaddr_un_raw")
- (define (socket-address-unix-path sa)
- (socket-address-data/unix-path (socket-address-data sa)))
- ;; Generic
- (define (raw->socket-address raw)
- (let* ((family (raw->address-family (vector-ref raw 1)))
- (data
- (case family
- ((inet)
- (make-socket-address-data/ipv4
- (make-ipv4-address (vector-ref raw 3))
- (vector-ref raw 2)))
- ((inet6)
- (make-socket-address-data/ipv6
- (make-ipv6-address (vector-ref raw 3))
- (vector-ref raw 2)
- (vector-ref raw 4)))
- ((unix)
- (make-socket-address-data/unix
- (byte-vector->os-string (vector-ref raw 2))))
- (else #f))))
- (make-socket-address family data (vector-ref raw 0))))
- ;; Interfaces
- (define-record-type interface :interface
- (make-interface name index)
- interface?
- (name interface-name)
- (index interface-index))
- (define-record-discloser :interface
- (lambda (r)
- (list 'interface
- (interface-name r) (interface-index r))))
- (define (index->interface idx)
- (if (and (integer? idx) (exact? idx) (positive? idx))
- (make-interface (external-interface-index->name idx)
- idx)
- (assertion-violation 'index->interface "invalid argument" idx)))
- (define (name->interface name)
- (let ((index (external-interface-name->index name)))
- (if (zero? index)
- #f
- (make-interface name index))))
- (define (get-all-interfaces)
- (let* ((v (external-interface-index-table))
- (count (quotient (vector-length v) 2)))
- (let loop ((i 0) (rev '()))
- (if (>= i count)
- (reverse rev)
- (loop (+ 1 i)
- (cons (make-interface (vector-ref v (+ 1 (* i 2)))
- (vector-ref v (* i 2)))
- rev))))))
-
- (import-lambda-definition-2 external-interface-name->index (name)
- "s48_if_nametoindex")
- (import-lambda-definition-2 external-interface-index->name (index)
- "s48_if_indextoname")
- (import-lambda-definition-2 external-interface-index-table ()
- "s48_if_nameindex")
- ; Nodename translation
- (define-enumeration address-info-flag
- (passive
- canonname
- numerichost)
- address-info-flags)
- (define address-info-flag-set-type (enum-set-type (address-info-flags)))
- (define-external-enum-type-with-unknowns ip-protocol
- (ip ipv6 icmp raw tcp udp)
- unknown-ip-protocol :unknown-ip-protocol
- make-unknown-ip-protocol unknown-ip-protocol? unknown-ip-protocol-number
- 100
- ip-protocol? ip-protocol->raw raw->ip-protocol)
- (define-external-enum-type-with-unknowns socket-type
- (stream dgram raw seqpacket)
- unknown-socket-type :unknown-socket-type
- make-unknown-socket-type unknown-socket-type? unknown-socket-type-number
- 100
- socket-type? socket-type->raw raw->socket-type)
- (define-record-type address-info :address-info
- (make-address-info family socket-type protocol
- canonical-name socket-address)
- address-info?
- (family address-info-family)
- (socket-type address-info-socket-type)
- (protocol address-info-protocol)
- (canonical-name address-info-canonical-name)
- (socket-address address-info-socket-address))
- (define-record-discloser :address-info
- (lambda (r)
- (list 'address-info
- (address-info-family r)
- (address-info-socket-type r)
- (address-info-protocol r)
- (address-info-canonical-name r)
- (address-info-socket-address r))))
- (define (raw->address-info raw)
- (make-address-info (raw->address-family (vector-ref raw 0))
- (raw->socket-type (vector-ref raw 1))
- (raw->ip-protocol (vector-ref raw 2))
- (vector-ref raw 3)
- (raw->socket-address (vector-ref raw 4))))
- (define (get-xxx-info event-uid retval condvar get-result)
- (if (vector? retval)
- retval
- (begin
- (dynamic-wind ; we need to release the uid in case the thread gets killed
- values
- (lambda ()
- (wait-for-external-event condvar))
- (lambda ()
- (unregister-external-event-uid! event-uid)))
- (get-result retval))))
- (define get-address-info
- (opt-lambda (node
- (server #f)
- (hint-flags (address-info-flags))
- (hint-family (address-family unspec))
- (hint-socket-type #f)
- (hint-protocol #f))
- (call-with-values
- (lambda () (new-external-event))
- (lambda (event-uid condvar)
- (cond
- ((get-xxx-info
- event-uid
- (external-getaddrinfo
- event-uid
- node server
- (enum-set->integer hint-flags)
- (address-family->raw hint-family)
- (and hint-socket-type
- (socket-type->raw hint-socket-type))
- (and hint-protocol
- (ip-protocol->raw hint-protocol)))
- condvar
- external-getaddrinfo-result)
- => (lambda (result)
- (map raw->address-info
- (vector->list result))))
- (else #f))))))
- (import-lambda-definition-2 external-getaddrinfo (event-uid
- nodename
- servname
- hint-flags hint-family
- hint-socktype hint-protocol)
- "s48_getaddrinfo")
- (import-lambda-definition-2 external-getaddrinfo-result (handshake)
- "s48_getaddrinfo_result")
- (define-enumeration name-info-flag
- (nofqdn numerichost namereqd numericserv dgram)
- name-info-flags)
- (define get-name-info
- (opt-lambda (socket-address (flags (name-info-flags)))
- (call-with-values
- (lambda () (new-external-event))
- (lambda (event-uid condvar)
- (let ((p (get-xxx-info
- event-uid
- (external-getnameinfo
- event-uid
- (socket-address-raw socket-address)
- (enum-set->integer flags))
- condvar
- external-getnameinfo-result)))
- (values (vector-ref p 0) (vector-ref p 1)))))))
- (import-lambda-definition-2 external-getnameinfo (event-uid sock-address flags)
- "s48_getnameinfo")
- (import-lambda-definition-2 external-getnameinfo-result (handshake)
- "s48_getnameinfo_result")
- ;; Address conversion
- (define (address->string addr)
- (cond
- ((ipv4-address? addr)
- (external-inet-ntop (address-family->raw (address-family inet))
- (ipv4-address-ip addr)))
- ((ipv6-address? addr)
- (external-inet-ntop (address-family->raw (address-family inet6))
- (ipv6-address-elements addr)))
- (else
- (assertion-violation 'address->string "invalid address" addr))))
- (define (string->address family rep)
- (let ((make
- (case family
- ((inet) make-ipv4-address)
- ((inet6) make-ipv6-address)
- (else
- (assertion-violation 'string->address "invalid address family"
- family)))))
- (cond
- ((external-inet-pton (address-family->raw family) rep) => make)
- (else #f))))
- (import-lambda-definition-2 external-inet-pton (family rep)
- "s48_inet_pton")
- (import-lambda-definition-2 external-inet-ntop (family address)
- "s48_inet_ntop")
- ;; Address testing
- (define-syntax define-address-predicate
- (syntax-rules ()
- ((define-address-predicate ?name ?external-name)
- (begin
- (import-lambda-definition-2 external? (address) ?external-name)
- (define (?name addr)
- (external? (ipv6-address-elements addr)))))))
- (define-address-predicate ipv6-address-unspecified? "s48_IN6_IS_ADDR_UNSPECIFIED")
- (define-address-predicate ipv6-address-loopback? "s48_IN6_IS_ADDR_LOOPBACK")
- (define-address-predicate ipv6-address-multicast? "s48_IN6_IS_ADDR_MULTICAST")
- (define-address-predicate ipv6-address-link-local? "s48_IN6_IS_ADDR_LINKLOCAL")
- (define-address-predicate ipv6-address-site-local? "s48_IN6_IS_ADDR_SITELOCAL")
- (define-address-predicate ipv6-address-v4-mapped? "s48_IN6_IS_ADDR_V4MAPPED")
- (define-address-predicate ipv6-address-v4-compat? "s48_IN6_IS_ADDR_V4COMPAT")
- (define-address-predicate ipv6-address-multicast-unspecified?
- "s48_IN6_IS_ADDR_MC_NODELOCAL")
- (define-address-predicate ipv6-address-multicast-unspecified?
- "s48_IN6_IS_ADDR_MC_LINKLOCAL")
- (define-address-predicate ipv6-address-multicast-org-local?
- "s48_IN6_IS_ADDR_MC_ORGLOCAL")
- (define-address-predicate ipv6-address-multicast-global?
- "s48_IN6_IS_ADDR_MC_GLOBAL")
|