address.scm 15 KB

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