PageRenderTime 56ms CodeModel.GetById 27ms RepoModel.GetById 1ms app.codeStats 0ms

/scheme/net/address.scm

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