suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Misc improvements to net/dns' and net/private/ip'.

Browse Source 
* Some racketisms.

* Use explicit `in-list' etc in for loops.

* Remove some redundant requires from `net/dns'.

* Move all tests to `tests/net', including a new `tests/net/ip'.  In the
  future there's a plan to have things like stripped zos etc for
  distribution, but we're not there yet, and the net collection is
  already organized nicely so this also makes it more uniform.

* Include the dns tests in the main test file.

original commit: 6149134011
This commit is contained in:
Eli Barzilay 2013-04-05 01:29:05 -04:00
parent 518051a4b3
commit 92358cb553
6 changed files with 306 additions and 325 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

128
collects/net/dns.rkt
View File

@ -3,15 +3,11 @@
;; DNS query library for Racket ;; DNS query library for Racket
(require "private/ip.rkt" (require "private/ip.rkt"
racket/bool
racket/contract racket/contract
racket/format racket/format
racket/list
racket/match
racket/string racket/string
racket/system racket/system
racket/udp racket/udp)
(only-in unstable/sequence in-slice))
(provide (contract-out (provide (contract-out
[dns-get-address [dns-get-address
@ -29,8 +25,6 @@
[dns-find-nameserver [dns-find-nameserver
(-> (or/c ip-address-string? #f))])) (-> (or/c ip-address-string? #f))]))
(module+ test (require rackunit))
;; UDP retry timeout: ;; UDP retry timeout:
(define INIT-TIMEOUT 50) (define INIT-TIMEOUT 50)
@ -88,13 +82,13 @@
;; Convert the domain name into a sequence of labels, where each ;; Convert the domain name into a sequence of labels, where each
;; label is a length octet and then that many octets ;; label is a length octet and then that many octets
(define (name->octets s) (define (name->octets s)
(let ([do-one (lambda (s) (cons (bytes-length s) (bytes->list s)))]) (define (do-one s) (cons (bytes-length s) (bytes->list s)))
(let loop ([s s]) (let loop ([s s])
(let ([m (regexp-match #rx#"^([^.]*)[.](.*)" s)]) (define m (regexp-match #rx#"^([^.]*)[.](.*)" s))
(if m (if m
(append (do-one (cadr m)) (loop (caddr m))) (append (do-one (cadr m)) (loop (caddr m)))
;; terminate with zero length octet ;; terminate with zero length octet
(append (do-one s) (list 0))))))) (append (do-one s) (list 0)))))
;; The query header. See RFC1035 4.1.1 for details ;; The query header. See RFC1035 4.1.1 for details
;; ;;
@ -134,7 +128,7 @@
(car rr)) (car rr))
(define (parse-name start reply) (define (parse-name start reply)
(let ([v (car start)]) (define v (car start))
(cond (cond
[(zero? v) [(zero? v)
;; End of name ;; End of name
@ -144,17 +138,16 @@
(let loop ([len v] [start (cdr start)] [accum null]) (let loop ([len v] [start (cdr start)] [accum null])
(if (zero? len) (if (zero? len)
(let-values ([(s start) (parse-name start reply)]) (let-values ([(s start) (parse-name start reply)])
(let ([s0 (list->bytes (reverse accum))]) (define s0 (list->bytes (reverse accum)))
(values (if s (bytes-append s0 #"." s) s0) (values (if s (bytes-append s0 #"." s) s0)
start))) start))
(loop (sub1 len) (cdr start) (cons (car start) accum))))] (loop (sub1 len) (cdr start) (cons (car start) accum))))]
[else [else
;; Compression offset ;; Compression offset
(let ([offset (+ (arithmetic-shift (bitwise-and #x3f v) 8) (define offset (+ (arithmetic-shift (bitwise-and #x3f v) 8)
(cadr start))]) (cadr start)))
(let-values ([(s ignore-start) (define-values [s ignore-start] (parse-name (list-tail reply offset) reply))
(parse-name (list-tail reply offset) reply)]) (values s (cddr start))]))
(values s (cddr start))))])))
(define (parse-rr start reply) (define (parse-rr start reply)
(let-values ([(name start) (parse-name start reply)]) (let-values ([(name start) (parse-name start reply)])
@ -205,33 +198,28 @@
(raise-type-error 'dns-query "DNS query class" class)) (raise-type-error 'dns-query "DNS query class" class))
(define nameserver (ip-address->string nameserver-ip)) (define nameserver (ip-address->string nameserver-ip))
(define query (make-query (random 256) (string->bytes/latin-1 addr)
(let* ([query (make-query (random 256) (string->bytes/latin-1 addr) type class))
type class)] (define udp (udp-open-socket nameserver 53))
[udp (udp-open-socket nameserver 53)] (define reply
[reply
(dynamic-wind (dynamic-wind
void void
(lambda () (lambda ()
(let ([s (make-bytes 512)]) (define s (make-bytes 512))
(let retry ([timeout INIT-TIMEOUT]) (let retry ([timeout INIT-TIMEOUT])
(udp-send-to udp nameserver 53 (list->bytes query)) (udp-send-to udp nameserver 53 (list->bytes query))
(sync (handle-evt (udp-receive!-evt udp s) (sync (handle-evt (udp-receive!-evt udp s)
(lambda (r) (lambda (r) (bytes->list (subbytes s 0 (car r)))))
(bytes->list (subbytes s 0 (car r)))))
(handle-evt (alarm-evt (+ (current-inexact-milliseconds) (handle-evt (alarm-evt (+ (current-inexact-milliseconds)
timeout)) timeout))
(lambda (v) (lambda (v) (retry (* timeout 2)))))))
(retry (* timeout 2)))))))) (lambda () (udp-close udp))))
(lambda () (udp-close udp)))])
;; First two bytes must match sent message id: ;; First two bytes must match sent message id:
(unless (and (= (car reply) (car query)) (unless (and (= (car reply) (car query))
(= (cadr reply) (cadr query))) (= (cadr reply) (cadr query)))
(error 'dns-query "bad reply id from server")) (error 'dns-query "bad reply id from server"))
(define v0 (caddr reply))
(let ([v0 (caddr reply)] (define v1 (cadddr reply))
[v1 (cadddr reply)])
;; Check for error code: ;; Check for error code:
(let ([rcode (bitwise-and #xf v1)]) (let ([rcode (bitwise-and #xf v1)])
(unless (zero? rcode) (unless (zero? rcode)
@ -242,13 +230,11 @@
[(3) "name error"] [(3) "name error"]
[(4) "not implemented"] [(4) "not implemented"]
[(5) "refused"])))) [(5) "refused"]))))
(define qd-count (octet-pair->number (list-ref reply 4) (list-ref reply 5)))
(let ([qd-count (octet-pair->number (list-ref reply 4) (list-ref reply 5))] (define an-count (octet-pair->number (list-ref reply 6) (list-ref reply 7)))
[an-count (octet-pair->number (list-ref reply 6) (list-ref reply 7))] (define ns-count (octet-pair->number (list-ref reply 8) (list-ref reply 9)))
[ns-count (octet-pair->number (list-ref reply 8) (list-ref reply 9))] (define ar-count (octet-pair->number (list-ref reply 10) (list-ref reply 11)))
[ar-count (octet-pair->number (list-ref reply 10) (list-ref reply 11))]) (define start (list-tail reply 12))
(let ([start (list-tail reply 12)])
(let*-values ([(qds start) (parse-n parse-ques start reply qd-count)] (let*-values ([(qds start) (parse-n parse-ques start reply qd-count)]
[(ans start) (parse-n parse-rr start reply an-count)] [(ans start) (parse-n parse-rr start reply an-count)]
[(nss start) (parse-n parse-rr start reply ns-count)] [(nss start) (parse-n parse-rr start reply ns-count)]
@ -256,7 +242,7 @@
(unless (null? start) (unless (null? start)
(error 'dns-query "error parsing server reply")) (error 'dns-query "error parsing server reply"))
(values (positive? (bitwise-and #x4 v0)) (values (positive? (bitwise-and #x4 v0))
qds ans nss ars reply))))))) qds ans nss ars reply)))
;; A cache for DNS query data ;; A cache for DNS query data
;; Stores a (List Boolean LB LB LB LB LB) ;; Stores a (List Boolean LB LB LB LB LB)
@ -290,7 +276,7 @@
(let-values ([(v ars auth?) (k nameserver)]) (let-values ([(v ars auth?) (k nameserver)])
(or v (or v
(and (not auth?) (and (not auth?)
(let* ([ns (ormap (lambda (ar) (let ([ns (ormap (lambda (ar)
(and (eq? (rr-type ar) 'a) (and (eq? (rr-type ar) 'a)
(ip->string (rr-data ar)))) (ip->string (rr-data ar))))
ars)]) ars)])
@ -307,41 +293,21 @@
;; Convert an IPv4 address for reverse lookup ;; Convert an IPv4 address for reverse lookup
(define (ip->in-addr.arpa ip) (define (ip->in-addr.arpa ip)
(define bytes (ipv4-bytes ip)) (apply format "~a.~a.~a.~a.in-addr.arpa"
(format "~a.~a.~a.~a.in-addr.arpa" (reverse (bytes->list (ipv4-bytes ip)))))
(bytes-ref bytes 3) (bytes-ref bytes 2)
(bytes-ref bytes 1) (bytes-ref bytes 0)))
(module+ test
(check-equal? (ip->in-addr.arpa (ipv4 (bytes 8 8 8 8)))
"8.8.8.8.in-addr.arpa")
(check-equal? (ip->in-addr.arpa (ipv4 (bytes 127 0 0 1)))
"1.0.0.127.in-addr.arpa"))
;; Convert an IPv6 address for reverse lookup ;; Convert an IPv6 address for reverse lookup
(define (ip->ip6.arpa ip) (define (ip->ip6.arpa ip)
(define nibbles (string-join
(for/fold ([nibbles '()]) (for/fold ([nibbles '()])
([byte (ipv6-bytes ip)]) ([byte (in-bytes (ipv6-bytes ip))])
(define nib1 (arithmetic-shift (bitwise-and #xf0 byte) -4)) (define nib1 (arithmetic-shift (bitwise-and #xf0 byte) -4))
(define nib2 (bitwise-and #x0f byte)) (define nib2 (bitwise-and #x0f byte))
(append (list nib2 nib1) nibbles))) (append (list (~r nib2 #:base 16) (~r nib1 #:base 16)) nibbles))
(string-append "." #:after-last ".ip6.arpa"))
(string-join
(for/list ([n nibbles]) (~r n #:base 16))
".")
".ip6.arpa"))
(module+ test
(check-equal?
(ip->ip6.arpa (make-ip-address "4321:0:1:2:3:4:567:89ab"))
"b.a.9.8.7.6.5.0.4.0.0.0.3.0.0.0.2.0.0.0.1.0.0.0.0.0.0.0.1.2.3.4.ip6.arpa")
(check-equal?
(ip->ip6.arpa (make-ip-address "2001:db8::567:89ab"))
"b.a.9.8.7.6.5.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.8.b.d.0.1.0.0.2.ip6.arpa"))
(define (get-ptr-list-from-ans ans) (define (get-ptr-list-from-ans ans)
(filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'ptr)) ans)) (filter (λ (ans-entry) (eq? (list-ref ans-entry 1) 'ptr)) ans))
(define (dns-get-name nameserver-ip-or-string ip-or-string) (define (dns-get-name nameserver-ip-or-string ip-or-string)
(define nameserver (if (ip-address? nameserver-ip-or-string) (define nameserver (if (ip-address? nameserver-ip-or-string)
@ -365,7 +331,7 @@
;; Get resource records corresponding to the given type ;; Get resource records corresponding to the given type
(define (get-records-from-ans ans type) (define (get-records-from-ans ans type)
(for/list ([ans-entry ans] (for/list ([ans-entry (in-list ans)]
#:when (eq? (list-ref ans-entry 1) type)) #:when (eq? (list-ref ans-entry 1) type))
ans-entry)) ans-entry))
@ -404,12 +370,12 @@
nss) nss)
addr))] addr))]
[else [else
(let ([d (rr-data (car ans))]) (define d (rr-data (car ans)))
(let ([pref (octet-pair->number (car d) (cadr d))]) (define pref (octet-pair->number (car d) (cadr d)))
(if (< pref best-pref) (if (< pref best-pref)
(let-values ([(name start) (parse-name (cddr d) reply)]) (let-values ([(name start) (parse-name (cddr d) reply)])
(loop (cdr ans) pref name)) (loop (cdr ans) pref name))
(loop (cdr ans) best-pref exchanger))))])) (loop (cdr ans) best-pref exchanger))]))
ars auth?))) ars auth?)))
nameserver) nameserver)
(error 'dns-get-mail-exchanger "bad address"))) (error 'dns-get-mail-exchanger "bad address")))
@ -421,16 +387,16 @@
(with-input-from-file "/etc/resolv.conf" (with-input-from-file "/etc/resolv.conf"
(lambda () (lambda ()
(let loop () (let loop ()
(let ([l (read-line)]) (define line (read-line))
(or (and (string? l) (or (and (string? line)
(let ([m (regexp-match (let ([m (regexp-match
#rx"nameserver[ \t]+([0-9]+[.][0-9]+[.][0-9]+[.][0-9]+)" #rx"nameserver[ \t]+([0-9]+[.][0-9]+[.][0-9]+[.][0-9]+)"
l)]) line)])
(and m (cadr m)))) (and m (cadr m))))
(and (not (eof-object? l)) (and (not (eof-object? line))
(loop))))))))] (loop)))))))]
[(windows) [(windows)
(let ([nslookup (find-executable-path "nslookup.exe" #f)]) (define nslookup (find-executable-path "nslookup.exe" #f))
(and nslookup (and nslookup
(let-values ([(pin pout pid perr proc) (let-values ([(pin pout pid perr proc)
(apply (apply
@ -439,7 +405,7 @@
#f (open-input-file "NUL") (current-error-port) #f (open-input-file "NUL") (current-error-port)
nslookup))]) nslookup))])
(let loop ([name #f] [ip #f] [try-ip? #f]) (let loop ([name #f] [ip #f] [try-ip? #f])
(let ([line (read-line pin 'any)]) (define line (read-line pin 'any))
(cond [(eof-object? line) (cond [(eof-object? line)
(close-input-port pin) (close-input-port pin)
(proc 'wait) (proc 'wait)
@ -450,5 +416,5 @@
[(and try-ip? [(and try-ip?
(regexp-match #rx"^Address: +(.*)$" line)) (regexp-match #rx"^Address: +(.*)$" line))
=> (lambda (m) (loop name (cadr m) #f))] => (lambda (m) (loop name (cadr m) #f))]
[else (loop name ip #f)]))))))] [else (loop name ip #f)]))))]
[else #f])) [else #f]))

130
collects/net/private/ip.rkt
View File

@ -34,8 +34,6 @@
(struct ipv4 ([bytes (bytes-of-length 4)])) (struct ipv4 ([bytes (bytes-of-length 4)]))
(struct ipv6 ([bytes (bytes-of-length 16)])))) (struct ipv6 ([bytes (bytes-of-length 16)]))))
(module+ test (require rackunit))
;; data definitions ;; data definitions
;; An IPAddress is one of ;; An IPAddress is one of
@ -73,26 +71,6 @@
[(? (bytes-of-length 4)) (ipv4 input)] [(? (bytes-of-length 4)) (ipv4 input)]
[(? (bytes-of-length 16)) (ipv6 input)])) [(? (bytes-of-length 16)) (ipv6 input)]))
(module+ test
(check-equal? (make-ip-address "127.0.0.1")
(ipv4 (bytes 127 0 0 1)))
(check-equal? (make-ip-address (bytes 127 0 0 1))
(ipv4 (bytes 127 0 0 1)))
(check-equal? (make-ip-address "2607:f8b0:4009:800::100e")
(ipv6 (bytes 38 7 248 176 64 9 8 0 0 0 0 0 0 0 16 14)))
(check-equal? (make-ip-address (bytes 38 7 248 176 64 9 8 0 0 0 0 0 0 0 16 14))
(ipv6 (bytes 38 7 248 176 64 9 8 0 0 0 0 0 0 0 16 14)))
(check-equal? (make-ip-address "0.0.0.1")
(ipv4 (bytes 0 0 0 1)))
(check-not-equal? (make-ip-address "128.0.0.1")
(make-ip-address "255.3.255.0"))
(let ([ip-bytes (bytes 127 0 0 1)])
(define ip (make-ip-address ip-bytes))
(bytes-set! ip-bytes 0 255)
(check-equal? ip (make-ip-address "127.0.0.1")
"IP addresses should be immutable")))
(define (ip-address-string? val) (define (ip-address-string? val)
(and (string? val) (and (string? val)
(or (ipv4-string? val) (or (ipv4-string? val)
@ -147,39 +125,6 @@
;; this is the +1 octet pair ;; this is the +1 octet pair
(regexp-match? re-end str))])))) (regexp-match? re-end str))]))))
(module+ test
(check-true (ip-address-string? "0.0.0.0"))
(check-true (ip-address-string? "0.1.0.2"))
(check-true (ip-address-string? "8.8.8.8"))
(check-true (ip-address-string? "12.81.255.109"))
(check-true (ip-address-string? "192.168.0.1"))
(check-true (ip-address-string? "2001:0db8:85a3:0000:0000:8a2e:0370:7334"))
(check-true (ip-address-string? "2001:200:dff:fff1:216:3eff:feb1:44d7"))
(check-true (ip-address-string? "2001:db8:85a3:0:0:8a2e:370:7334"))
(check-true (ip-address-string? "2001:db8:85a3::8a2e:370:7334"))
(check-true (ip-address-string? "0:0:0:0:0:0:0:1"))
(check-true (ip-address-string? "0:0:0:0:0:0:0:0"))
(check-true (ip-address-string? "::"))
(check-true (ip-address-string? "::0"))
(check-true (ip-address-string? "::ffff:c000:0280"))
(check-true (ip-address-string? "2001:db8::2:1"))
(check-true (ip-address-string? "2001:db8:0:0:1::1"))
(check-false (ip-address-string? ""))
(check-false (ip-address-string? ":::"))
(check-false (ip-address-string? "::0::"))
(check-false (ip-address-string? "2001::db8::2:1"))
(check-false (ip-address-string? "2001:::db8:2:1"))
(check-false (ip-address-string? "52001:db8::2:1"))
(check-false (ip-address-string? "80.8.800.8"))
(check-false (ip-address-string? "80.8.800.0"))
(check-false (ip-address-string? "080.8.800.8"))
(check-false (ip-address-string? "vas8.8.800.8"))
(check-false (ip-address-string? "80.8.128.8dd"))
(check-false (ip-address-string? "0.8.800.008"))
(check-false (ip-address-string? "0.8.800.a8"))
(check-false (ip-address-string? "potatoes"))
(check-false (ip-address-string? "127.0.0")))
;; String -> Bytes ;; String -> Bytes
;; converts a string representating an IPv4 address to bytes ;; converts a string representating an IPv4 address to bytes
(define (ipv4-string->bytes ip) (define (ipv4-string->bytes ip)
@ -190,16 +135,6 @@
(string->number (list-ref result 3)) (string->number (list-ref result 3))
(string->number (list-ref result 4))))) (string->number (list-ref result 4)))))
(module+ test
(check-equal? (ipv4-string->bytes "0.8.255.0")
(bytes 0 8 255 0))
(check-equal? (ipv4-string->bytes "8.8.8.8")
(bytes 8 8 8 8))
(check-equal? (ipv4-string->bytes "12.81.255.109")
(bytes 12 81 255 109))
(check-equal? (ipv4-string->bytes "192.168.0.1")
(bytes 192 168 0 1)))
;; String -> Bytes ;; String -> Bytes
;; converts a string representing an IPv6 address to bytes ;; converts a string representing an IPv6 address to bytes
(define (ipv6-string->bytes ip) (define (ipv6-string->bytes ip)
@ -224,22 +159,6 @@
(loop (bytes-append result (octet-pair-string->bytes (car splitted))) (loop (bytes-append result (octet-pair-string->bytes (car splitted)))
(cdr splitted))]))) (cdr splitted))])))
(module+ test
(check-equal? (ipv6-string->bytes "2001:0db8:85a3:0000:0000:8a2e:0370:7334")
(bytes 32 1 13 184 133 163 0 0 0 0 138 46 3 112 115 52))
(check-equal? (ipv6-string->bytes "2001:200:dff:fff1:216:3eff:feb1:44d7")
(bytes 32 1 2 0 13 255 255 241 2 22 62 255 254 177 68 215))
(check-equal? (ipv6-string->bytes "2001:db8:85a3:0:0:8a2e:370:7334")
(bytes 32 1 13 184 133 163 0 0 0 0 138 46 3 112 115 52))
(check-equal? (ipv6-string->bytes "2001:db8:85a3::8a2e:370:7334")
(bytes 32 1 13 184 133 163 0 0 0 0 138 46 3 112 115 52))
(check-equal? (ipv6-string->bytes "2607:f8b0:4009:800::100e")
(bytes 38 7 248 176 64 9 8 0 0 0 0 0 0 0 16 14))
(check-equal? (ipv6-string->bytes "::1")
(bytes 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1))
(check-equal? (ipv6-string->bytes "::ffff")
(bytes 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255)))
;; IPAddress -> Bytestring ;; IPAddress -> Bytestring
;; Turn an ip struct into a byte string ;; Turn an ip struct into a byte string
(define (ip-address->bytes ip) (define (ip-address->bytes ip)
@ -247,12 +166,6 @@
[(? ipv4?) (ipv4-bytes ip)] [(? ipv4?) (ipv4-bytes ip)]
[(? ipv6?) (ipv6-bytes ip)])) [(? ipv6?) (ipv6-bytes ip)]))
(module+ test
(check-equal? (ip-address->bytes (make-ip-address "8.8.8.8"))
(bytes 8 8 8 8))
(check-equal? (ip-address->bytes (make-ip-address "::1"))
(bytes 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1)))
;; IPAddress -> String ;; IPAddress -> String
;; Convert an IP address to a string ;; Convert an IP address to a string
(define (ip-address->string ip) (define (ip-address->string ip)
@ -260,25 +173,10 @@
[(? ipv4?) (ipv4->string (ipv4-bytes ip))] [(? ipv4?) (ipv4->string (ipv4-bytes ip))]
[(? ipv6?) (ipv6->string (ipv6-bytes ip))])) [(? ipv6?) (ipv6->string (ipv6-bytes ip))]))
(module+ test
(check-equal? (ip-address->string (make-ip-address "8.8.8.8"))
"8.8.8.8")
(check-equal? (ip-address->string (make-ip-address "::1"))
"::1"))
;; Bytes -> String ;; Bytes -> String
;; Convert a bytestring for an IPv4 address to a string ;; Convert a bytestring for an IPv4 address to a string
(define (ipv4->string bytes) (define (ipv4->string bytes)
(string-join (for/list ([b bytes]) (~r b)) ".")) (string-join (for/list ([b (in-bytes bytes)]) (~r b)) "."))
(module+ test
(check-equal? (ipv4->string (bytes 0 0 0 0)) "0.0.0.0")
(check-equal? (ipv4->string (bytes 255 255 0 1))
"255.255.0.1")
(check-equal? (ipv4->string (bytes 127 0 0 1))
"127.0.0.1")
(check-equal? (ipv4->string (bytes 8 8 8 8))
"8.8.8.8"))
;; Bytes -> String ;; Bytes -> String
;; Convert a bytestring representing an IPv6 address to a string ;; Convert a bytestring representing an IPv6 address to a string
@ -291,7 +189,7 @@
(define compressed (compress two-octets)) (define compressed (compress two-octets))
;; add an extra "" if :: is at the start ;; add an extra "" if :: is at the start
(define compressed-strs (define compressed-strs
(for/list ([elem compressed]) (for/list ([elem (in-list compressed)])
(if (eq? elem '::) (if (eq? elem '::)
"" ; string-join will turn this into :: "" ; string-join will turn this into ::
(~r elem #:base 16)))) (~r elem #:base 16))))
@ -301,41 +199,21 @@
compressed-strs)) compressed-strs))
(string-join compressed-strs* ":")) (string-join compressed-strs* ":"))
(module+ test
(check-equal? (ipv6->string (bytes 32 1 13 184 133 163 0 0 0 0 138 46 3 112 115 52))
"2001:db8:85a3::8a2e:370:7334")
(check-equal? (ipv6->string (bytes 38 7 248 176 64 9 8 0 0 0 0 0 0 0 16 14))
"2607:f8b0:4009:800::100e")
(check-equal? (ipv6->string (bytes 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255))
"::ffff")
(check-equal? (ipv6->string (bytes 255 255 0 0 0 0 0 0 0 0 0 0 0 0 255 255))
"ffff::ffff"))
;; (Listof Number) -> (Listof (U Number '::)) ;; (Listof Number) -> (Listof (U Number '::))
;; Compress an IPv6 address to its shortest representation ;; Compress an IPv6 address to its shortest representation
(define (compress lon) (define (compress lon)
(let loop ([acc '()] [lon lon]) (let loop ([acc '()] [lon lon])
(cond [(empty? lon) (reverse acc)] (cond [(empty? lon) (reverse acc)]
[else [else
(define zeroes (for/list ([n lon] #:break (not (zero? n))) n)) (define zeroes
(for/list ([n (in-list lon)] #:break (not (zero? n))) n))
(define num-zs (length zeroes)) (define num-zs (length zeroes))
(if (<= num-zs 1) (if (<= num-zs 1)
(loop (cons (car lon) acc) (cdr lon)) (loop (cons (car lon) acc) (cdr lon))
(append (reverse acc) '(::) (drop lon num-zs)))]))) (append (reverse acc) '(::) (drop lon num-zs)))])))
(module+ test
(check-equal? (compress '(0 0 0 5 5)) '(:: 5 5))
(check-equal? (compress '(0 5 5)) '(0 5 5))
(check-equal? (compress '(0 0 5 0 0 5)) '(:: 5 0 0 5))
(check-equal? (compress '(0 5 0 0 0 5)) '(0 5 :: 5)))
;; contract helper ;; contract helper
(define (bytes-of-length n) (define (bytes-of-length n)
(flat-named-contract (flat-named-contract
`(bytes-of-length ,n) `(bytes-of-length ,n)
(λ (bs) (and (bytes? bs) (= (bytes-length bs) n))))) (λ (bs) (and (bytes? bs) (= (bytes-length bs) n)))))
(module+ test
(check-true ((bytes-of-length 5) (bytes 1 2 3 4 5)))
(check-false ((bytes-of-length 5) "moogle")))

32
collects/tests/net/dns.rkt
View File

@ -2,8 +2,20 @@
(require net/dns tests/eli-tester) (require net/dns tests/eli-tester)
;; Run internal unit tests ;; internal tests
(require (submod net/dns test)) (require (only-in rackunit require/expose) net/private/ip)
(require/expose net/dns (ip->in-addr.arpa ip->ip6.arpa))
(define (internal-tests)
(test (ip->in-addr.arpa (ipv4 (bytes 8 8 8 8)))
=> "8.8.8.8.in-addr.arpa"
(ip->in-addr.arpa (ipv4 (bytes 127 0 0 1)))
=> "1.0.0.127.in-addr.arpa"
(ip->ip6.arpa (make-ip-address "4321:0:1:2:3:4:567:89ab"))
=> (string-append "b.a.9.8.7.6.5.0.4.0.0.0.3.0.0.0"
".2.0.0.0.1.0.0.0.0.0.0.0.1.2.3.4.ip6.arpa")
(ip->ip6.arpa (make-ip-address "2001:db8::567:89ab"))
=> (string-append "b.a.9.8.7.6.5.0.0.0.0.0.0.0.0.0"
".0.0.0.0.0.0.0.0.8.b.d.0.1.0.0.2.ip6.arpa")))
;; Constants for testing. These can go out of sync ;; Constants for testing. These can go out of sync
;; when server setups change, so keep them up-to-date. ;; when server setups change, so keep them up-to-date.
@ -16,19 +28,17 @@
(define *kame-url* "www.kame.net") (define *kame-url* "www.kame.net")
(define *kame-ip* "2001:200:dff:fff1:216:3eff:feb1:44d7") (define *kame-ip* "2001:200:dff:fff1:216:3eff:feb1:44d7")
(module+ main (tests)) (define (nameserver-tests nameserver)
(define (dns-test/nameserver nameserver)
(test (dns-get-address nameserver *racket-url*) => *racket-ip* (test (dns-get-address nameserver *racket-url*) => *racket-ip*
(dns-get-address nameserver *racket-host*) => *racket-ip* (dns-get-address nameserver *racket-host*) => *racket-ip*
(dns-get-address nameserver *kame-url* #:ipv6? #t) => *kame-ip* (dns-get-address nameserver *kame-url* #:ipv6? #t) => *kame-ip*
(dns-get-name nameserver *racket-ip*) => *racket-host* (dns-get-name nameserver *racket-ip*) => *racket-host*
(dns-get-mail-exchanger nameserver *racket-url*) => *racket-mx*)) (dns-get-mail-exchanger nameserver *racket-url*) => *racket-mx*))
(provide tests)
(module+ main (tests))
(define (tests) (define (tests)
(dns-test/nameserver *google-dns*) (test do (internal-tests)
(dns-test/nameserver *google-dns-2*) (nameserver-tests *google-dns*)
(nameserver-tests *google-dns-2*)
(define ns (dns-find-nameserver)) (let ([ns (dns-find-nameserver)]) (when ns (nameserver-tests ns)))))
(when ns
(dns-test/nameserver ns)))

125
collects/tests/net/ip.rkt Normal file
View File

@ -0,0 +1,125 @@
#lang racket/base
(require net/private/ip tests/eli-tester)
(require (only-in rackunit require/expose))
(require/expose net/private/ip
(ipv4-string->bytes ipv6-string->bytes ipv4->string ipv6->string
compress bytes-of-length))
(provide tests)
(module+ main (tests))
(define (tests)
(test
;; ----------------------------------------
(make-ip-address "127.0.0.1")
=> (ipv4 (bytes 127 0 0 1))
(make-ip-address (bytes 127 0 0 1))
=> (ipv4 (bytes 127 0 0 1))
(make-ip-address "2607:f8b0:4009:800::100e")
=> (ipv6 (bytes 38 7 248 176 64 9 8 0 0 0 0 0 0 0 16 14))
(make-ip-address (bytes 38 7 248 176 64 9 8 0 0 0 0 0 0 0 16 14))
=> (ipv6 (bytes 38 7 248 176 64 9 8 0 0 0 0 0 0 0 16 14))
(make-ip-address "0.0.0.1")
=> (ipv4 (bytes 0 0 0 1))
(not (equal? (make-ip-address "128.0.0.1")
(make-ip-address "255.3.255.0")))
do (let ([ip-bytes (bytes 127 0 0 1)])
(define ip (make-ip-address ip-bytes))
(bytes-set! ip-bytes 0 255)
(test #:failure-message "IP addresses should be immutable"
ip => (make-ip-address "127.0.0.1")))
;; ----------------------------------------
(ip-address-string? "0.0.0.0")
(ip-address-string? "0.1.0.2")
(ip-address-string? "8.8.8.8")
(ip-address-string? "12.81.255.109")
(ip-address-string? "192.168.0.1")
(ip-address-string? "2001:0db8:85a3:0000:0000:8a2e:0370:7334")
(ip-address-string? "2001:200:dff:fff1:216:3eff:feb1:44d7")
(ip-address-string? "2001:db8:85a3:0:0:8a2e:370:7334")
(ip-address-string? "2001:db8:85a3::8a2e:370:7334")
(ip-address-string? "0:0:0:0:0:0:0:1")
(ip-address-string? "0:0:0:0:0:0:0:0")
(ip-address-string? "::")
(ip-address-string? "::0")
(ip-address-string? "::ffff:c000:0280")
(ip-address-string? "2001:db8::2:1")
(ip-address-string? "2001:db8:0:0:1::1")
(not (ip-address-string? ""))
(not (ip-address-string? ":::"))
(not (ip-address-string? "::0::"))
(not (ip-address-string? "2001::db8::2:1"))
(not (ip-address-string? "2001:::db8:2:1"))
(not (ip-address-string? "52001:db8::2:1"))
(not (ip-address-string? "80.8.800.8"))
(not (ip-address-string? "80.8.800.0"))
(not (ip-address-string? "080.8.800.8"))
(not (ip-address-string? "vas8.8.800.8"))
(not (ip-address-string? "80.8.128.8dd"))
(not (ip-address-string? "0.8.800.008"))
(not (ip-address-string? "0.8.800.a8"))
(not (ip-address-string? "potatoes"))
(not (ip-address-string? "127.0.0"))
;; ----------------------------------------
(ipv4-string->bytes "0.8.255.0")
=> (bytes 0 8 255 0)
(ipv4-string->bytes "8.8.8.8")
=> (bytes 8 8 8 8)
(ipv4-string->bytes "12.81.255.109")
=> (bytes 12 81 255 109)
(ipv4-string->bytes "192.168.0.1")
=> (bytes 192 168 0 1)
;; ----------------------------------------
(ipv6-string->bytes "2001:0db8:85a3:0000:0000:8a2e:0370:7334")
=> (bytes 32 1 13 184 133 163 0 0 0 0 138 46 3 112 115 52)
(ipv6-string->bytes "2001:200:dff:fff1:216:3eff:feb1:44d7")
=> (bytes 32 1 2 0 13 255 255 241 2 22 62 255 254 177 68 215)
(ipv6-string->bytes "2001:db8:85a3:0:0:8a2e:370:7334")
=> (bytes 32 1 13 184 133 163 0 0 0 0 138 46 3 112 115 52)
(ipv6-string->bytes "2001:db8:85a3::8a2e:370:7334")
=> (bytes 32 1 13 184 133 163 0 0 0 0 138 46 3 112 115 52)
(ipv6-string->bytes "2607:f8b0:4009:800::100e")
=> (bytes 38 7 248 176 64 9 8 0 0 0 0 0 0 0 16 14)
(ipv6-string->bytes "::1")
=> (bytes 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1)
(ipv6-string->bytes "::ffff")
=> (bytes 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255)
;; ----------------------------------------
(ip-address->bytes (make-ip-address "8.8.8.8"))
=> (bytes 8 8 8 8)
(ip-address->bytes (make-ip-address "::1"))
=> (bytes 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1)
;; ----------------------------------------
(ip-address->string (make-ip-address "8.8.8.8"))
=> "8.8.8.8"
(ip-address->string (make-ip-address "::1"))
=> "::1"
;; ----------------------------------------
(ipv4->string (bytes 0 0 0 0))
=> "0.0.0.0"
(ipv4->string (bytes 255 255 0 1))
=> "255.255.0.1"
(ipv4->string (bytes 127 0 0 1))
=> "127.0.0.1"
(ipv4->string (bytes 8 8 8 8))
=> "8.8.8.8"
;; ----------------------------------------
(ipv6->string (bytes 32 1 13 184 133 163 0 0 0 0 138 46 3 112 115 52))
=> "2001:db8:85a3::8a2e:370:7334"
(ipv6->string (bytes 38 7 248 176 64 9 8 0 0 0 0 0 0 0 16 14))
=> "2607:f8b0:4009:800::100e"
(ipv6->string (bytes 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255))
=> "::ffff"
(ipv6->string (bytes 255 255 0 0 0 0 0 0 0 0 0 0 0 0 255 255))
=> "ffff::ffff"
;; ----------------------------------------
(compress '(0 0 0 5 5)) => '(:: 5 5)
(compress '(0 5 5)) => '(0 5 5)
(compress '(0 0 5 0 0 5)) => '(:: 5 0 0 5)
(compress '(0 5 0 0 0 5)) => '(0 5 :: 5)
;; ----------------------------------------
((bytes-of-length 5) (bytes 1 2 3 4 5))
(not ((bytes-of-length 5) "moogle"))
;; ----------------------------------------
))

6
collects/tests/net/main.rkt
View File

@ -1,6 +1,8 @@
#lang racket/base #lang racket/base
(require tests/eli-tester (require tests/eli-tester
(prefix-in ip: "ip.rkt")
(prefix-in dns: "dns.rkt")
(prefix-in ucodec: "uri-codec.rkt") (prefix-in ucodec: "uri-codec.rkt")
(prefix-in url: "url.rkt") (prefix-in url: "url.rkt")
(prefix-in cgi: "cgi.rkt") (prefix-in cgi: "cgi.rkt")
@ -13,7 +15,9 @@
(prefix-in websocket: "websocket.rkt")) (prefix-in websocket: "websocket.rkt"))
(define (tests) (define (tests)
(test do (url:tests) (test do (ip:tests)
do (dns:tests)
do (url:tests)
do (ucodec:tests) do (ucodec:tests)
do (ucodec:noels-tests) do (ucodec:noels-tests)
do (cgi:tests) do (cgi:tests)

8
collects/tests/net/url.rkt
View File

@ -43,7 +43,9 @@
(test (combine-url/relative-vec (->vec base) relative) (test (combine-url/relative-vec (->vec base) relative)
=> (->vec expected))) => (->vec expected)))
(define (run-tests) (provide tests)
(module+ main (tests))
(define (tests)
(test (test
;; Test the current-proxy-servers parameter can be set ;; Test the current-proxy-servers parameter can be set
(parameterize ([current-proxy-servers '(("http" "proxy.com" 3128))]) (parameterize ([current-proxy-servers '(("http" "proxy.com" 3128))])
@ -373,7 +375,3 @@
)) ))
) )
(provide tests)
(module+ main (tests))
(define (tests) (test do (run-tests)))