diff --git a/collects/net/dns.rkt b/collects/net/dns.rkt index 3c61aa72e0..f2d8ba5f48 100644 --- a/collects/net/dns.rkt +++ b/collects/net/dns.rkt @@ -3,15 +3,11 @@ ;; DNS query library for Racket (require "private/ip.rkt" - racket/bool racket/contract racket/format - racket/list - racket/match racket/string racket/system - racket/udp - (only-in unstable/sequence in-slice)) + racket/udp) (provide (contract-out [dns-get-address @@ -29,8 +25,6 @@ [dns-find-nameserver (-> (or/c ip-address-string? #f))])) -(module+ test (require rackunit)) - ;; UDP retry timeout: (define INIT-TIMEOUT 50) @@ -39,23 +33,23 @@ ;; A Type is one of the following (define types - '((a 1) - (ns 2) - (md 3) - (mf 4) - (cname 5) - (soa 6) - (mb 7) - (mg 8) - (mr 9) - (null 10) - (wks 11) - (ptr 12) + '((a 1) + (ns 2) + (md 3) + (mf 4) + (cname 5) + (soa 6) + (mb 7) + (mg 8) + (mr 9) + (null 10) + (wks 11) + (ptr 12) (hinfo 13) (minfo 14) - (mx 15) - (txt 16) - (aaaa 28))) + (mx 15) + (txt 16) + (aaaa 28))) ;; A Class is one of the following (define classes @@ -67,9 +61,9 @@ ;;; (define (cossa i l) - (cond [(null? l) #f] + (cond [(null? l) #f] [(equal? (cadar l) i) (car l)] - [else (cossa i (cdr l))])) + [else (cossa i (cdr l))])) (define (number->octet-pair n) (list (arithmetic-shift n -8) @@ -88,13 +82,13 @@ ;; Convert the domain name into a sequence of labels, where each ;; label is a length octet and then that many octets (define (name->octets s) - (let ([do-one (lambda (s) (cons (bytes-length s) (bytes->list s)))]) - (let loop ([s s]) - (let ([m (regexp-match #rx#"^([^.]*)[.](.*)" s)]) - (if m - (append (do-one (cadr m)) (loop (caddr m))) - ;; terminate with zero length octet - (append (do-one s) (list 0))))))) + (define (do-one s) (cons (bytes-length s) (bytes->list s))) + (let loop ([s s]) + (define m (regexp-match #rx#"^([^.]*)[.](.*)" s)) + (if m + (append (do-one (cadr m)) (loop (caddr m))) + ;; terminate with zero length octet + (append (do-one s) (list 0))))) ;; The query header. See RFC1035 4.1.1 for details ;; @@ -134,27 +128,26 @@ (car rr)) (define (parse-name start reply) - (let ([v (car start)]) - (cond - [(zero? v) - ;; End of name - (values #f (cdr start))] - [(zero? (bitwise-and #xc0 v)) - ;; Normal label - (let loop ([len v][start (cdr start)][accum null]) - (if (zero? len) - (let-values ([(s start) (parse-name start reply)]) - (let ([s0 (list->bytes (reverse accum))]) - (values (if s (bytes-append s0 #"." s) s0) - start))) - (loop (sub1 len) (cdr start) (cons (car start) accum))))] - [else - ;; Compression offset - (let ([offset (+ (arithmetic-shift (bitwise-and #x3f v) 8) - (cadr start))]) - (let-values ([(s ignore-start) - (parse-name (list-tail reply offset) reply)]) - (values s (cddr start))))]))) + (define v (car start)) + (cond + [(zero? v) + ;; End of name + (values #f (cdr start))] + [(zero? (bitwise-and #xc0 v)) + ;; Normal label + (let loop ([len v] [start (cdr start)] [accum null]) + (if (zero? len) + (let-values ([(s start) (parse-name start reply)]) + (define s0 (list->bytes (reverse accum))) + (values (if s (bytes-append s0 #"." s) s0) + start)) + (loop (sub1 len) (cdr start) (cons (car start) accum))))] + [else + ;; Compression offset + (define offset (+ (arithmetic-shift (bitwise-and #x3f v) 8) + (cadr start))) + (define-values [s ignore-start] (parse-name (list-tail reply offset) reply)) + (values s (cddr start))])) (define (parse-rr start reply) (let-values ([(name start) (parse-name start reply)]) @@ -191,7 +184,7 @@ (values (list name type class) start)))) (define (parse-n parse start reply n) - (let loop ([n n][start start][accum null]) + (let loop ([n n] [start start] [accum null]) (if (zero? n) (values (reverse accum) start) (let-values ([(rr start) (parse start reply)]) @@ -205,58 +198,51 @@ (raise-type-error 'dns-query "DNS query class" class)) (define nameserver (ip-address->string nameserver-ip)) - - (let* ([query (make-query (random 256) (string->bytes/latin-1 addr) - type class)] - [udp (udp-open-socket nameserver 53)] - [reply - (dynamic-wind - void - (lambda () - (let ([s (make-bytes 512)]) - (let retry ([timeout INIT-TIMEOUT]) - (udp-send-to udp nameserver 53 (list->bytes query)) - (sync (handle-evt (udp-receive!-evt udp s) - (lambda (r) - (bytes->list (subbytes s 0 (car r))))) - (handle-evt (alarm-evt (+ (current-inexact-milliseconds) - timeout)) - (lambda (v) - (retry (* timeout 2)))))))) - (lambda () (udp-close udp)))]) - - ;; First two bytes must match sent message id: - (unless (and (= (car reply) (car query)) - (= (cadr reply) (cadr query))) - (error 'dns-query "bad reply id from server")) - - (let ([v0 (caddr reply)] - [v1 (cadddr reply)]) - ;; Check for error code: - (let ([rcode (bitwise-and #xf v1)]) - (unless (zero? rcode) - (error 'dns-query "error from server: ~a" - (case rcode - [(1) "format error"] - [(2) "server failure"] - [(3) "name error"] - [(4) "not implemented"] - [(5) "refused"])))) - - (let ([qd-count (octet-pair->number (list-ref reply 4) (list-ref reply 5))] - [an-count (octet-pair->number (list-ref reply 6) (list-ref reply 7))] - [ns-count (octet-pair->number (list-ref reply 8) (list-ref reply 9))] - [ar-count (octet-pair->number (list-ref reply 10) (list-ref reply 11))]) - - (let ([start (list-tail reply 12)]) - (let*-values ([(qds start) (parse-n parse-ques start reply qd-count)] - [(ans start) (parse-n parse-rr start reply an-count)] - [(nss start) (parse-n parse-rr start reply ns-count)] - [(ars start) (parse-n parse-rr start reply ar-count)]) - (unless (null? start) - (error 'dns-query "error parsing server reply")) - (values (positive? (bitwise-and #x4 v0)) - qds ans nss ars reply))))))) + (define query (make-query (random 256) (string->bytes/latin-1 addr) + type class)) + (define udp (udp-open-socket nameserver 53)) + (define reply + (dynamic-wind + void + (lambda () + (define s (make-bytes 512)) + (let retry ([timeout INIT-TIMEOUT]) + (udp-send-to udp nameserver 53 (list->bytes query)) + (sync (handle-evt (udp-receive!-evt udp s) + (lambda (r) (bytes->list (subbytes s 0 (car r))))) + (handle-evt (alarm-evt (+ (current-inexact-milliseconds) + timeout)) + (lambda (v) (retry (* timeout 2))))))) + (lambda () (udp-close udp)))) + ;; First two bytes must match sent message id: + (unless (and (= (car reply) (car query)) + (= (cadr reply) (cadr query))) + (error 'dns-query "bad reply id from server")) + (define v0 (caddr reply)) + (define v1 (cadddr reply)) + ;; Check for error code: + (let ([rcode (bitwise-and #xf v1)]) + (unless (zero? rcode) + (error 'dns-query "error from server: ~a" + (case rcode + [(1) "format error"] + [(2) "server failure"] + [(3) "name error"] + [(4) "not implemented"] + [(5) "refused"])))) + (define 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))) + (define 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))) + (define start (list-tail reply 12)) + (let*-values ([(qds start) (parse-n parse-ques start reply qd-count)] + [(ans start) (parse-n parse-rr start reply an-count)] + [(nss start) (parse-n parse-rr start reply ns-count)] + [(ars start) (parse-n parse-rr start reply ar-count)]) + (unless (null? start) + (error 'dns-query "error parsing server reply")) + (values (positive? (bitwise-and #x4 v0)) + qds ans nss ars reply))) ;; A cache for DNS query data ;; Stores a (List Boolean LB LB LB LB LB) @@ -290,10 +276,10 @@ (let-values ([(v ars auth?) (k nameserver)]) (or v (and (not auth?) - (let* ([ns (ormap (lambda (ar) - (and (eq? (rr-type ar) 'a) - (ip->string (rr-data ar)))) - ars)]) + (let ([ns (ormap (lambda (ar) + (and (eq? (rr-type ar) 'a) + (ip->string (rr-data ar)))) + ars)]) (and ns (not (member ns tried)) (loop ns (cons ns tried))))))))) @@ -307,41 +293,21 @@ ;; Convert an IPv4 address for reverse lookup (define (ip->in-addr.arpa ip) - (define bytes (ipv4-bytes ip)) - (format "~a.~a.~a.~a.in-addr.arpa" - (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")) + (apply format "~a.~a.~a.~a.in-addr.arpa" + (reverse (bytes->list (ipv4-bytes ip))))) ;; Convert an IPv6 address for reverse lookup (define (ip->ip6.arpa ip) - (define nibbles - (for/fold ([nibbles '()]) - ([byte (ipv6-bytes ip)]) - (define nib1 (arithmetic-shift (bitwise-and #xf0 byte) -4)) - (define nib2 (bitwise-and #x0f byte)) - (append (list nib2 nib1) nibbles))) - (string-append - (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")) + (string-join + (for/fold ([nibbles '()]) + ([byte (in-bytes (ipv6-bytes ip))]) + (define nib1 (arithmetic-shift (bitwise-and #xf0 byte) -4)) + (define nib2 (bitwise-and #x0f byte)) + (append (list (~r nib2 #:base 16) (~r nib1 #:base 16)) nibbles)) + "." #:after-last ".ip6.arpa")) (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 nameserver (if (ip-address? nameserver-ip-or-string) @@ -365,7 +331,7 @@ ;; Get resource records corresponding to the given 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)) ans-entry)) @@ -404,12 +370,12 @@ nss) addr))] [else - (let ([d (rr-data (car ans))]) - (let ([pref (octet-pair->number (car d) (cadr d))]) - (if (< pref best-pref) - (let-values ([(name start) (parse-name (cddr d) reply)]) - (loop (cdr ans) pref name)) - (loop (cdr ans) best-pref exchanger))))])) + (define d (rr-data (car ans))) + (define pref (octet-pair->number (car d) (cadr d))) + (if (< pref best-pref) + (let-values ([(name start) (parse-name (cddr d) reply)]) + (loop (cdr ans) pref name)) + (loop (cdr ans) best-pref exchanger))])) ars auth?))) nameserver) (error 'dns-get-mail-exchanger "bad address"))) @@ -421,34 +387,34 @@ (with-input-from-file "/etc/resolv.conf" (lambda () (let loop () - (let ([l (read-line)]) - (or (and (string? l) - (let ([m (regexp-match - #rx"nameserver[ \t]+([0-9]+[.][0-9]+[.][0-9]+[.][0-9]+)" - l)]) - (and m (cadr m)))) - (and (not (eof-object? l)) - (loop))))))))] + (define line (read-line)) + (or (and (string? line) + (let ([m (regexp-match + #rx"nameserver[ \t]+([0-9]+[.][0-9]+[.][0-9]+[.][0-9]+)" + line)]) + (and m (cadr m)))) + (and (not (eof-object? line)) + (loop)))))))] [(windows) - (let ([nslookup (find-executable-path "nslookup.exe" #f)]) - (and nslookup - (let-values ([(pin pout pid perr proc) - (apply - values - (process/ports - #f (open-input-file "NUL") (current-error-port) - nslookup))]) - (let loop ([name #f] [ip #f] [try-ip? #f]) - (let ([line (read-line pin 'any)]) - (cond [(eof-object? line) - (close-input-port pin) - (proc 'wait) - (or ip name)] - [(and (not name) - (regexp-match #rx"^Default Server: +(.*)$" line)) - => (lambda (m) (loop (cadr m) #f #t))] - [(and try-ip? - (regexp-match #rx"^Address: +(.*)$" line)) - => (lambda (m) (loop name (cadr m) #f))] - [else (loop name ip #f)]))))))] + (define nslookup (find-executable-path "nslookup.exe" #f)) + (and nslookup + (let-values ([(pin pout pid perr proc) + (apply + values + (process/ports + #f (open-input-file "NUL") (current-error-port) + nslookup))]) + (let loop ([name #f] [ip #f] [try-ip? #f]) + (define line (read-line pin 'any)) + (cond [(eof-object? line) + (close-input-port pin) + (proc 'wait) + (or ip name)] + [(and (not name) + (regexp-match #rx"^Default Server: +(.*)$" line)) + => (lambda (m) (loop (cadr m) #f #t))] + [(and try-ip? + (regexp-match #rx"^Address: +(.*)$" line)) + => (lambda (m) (loop name (cadr m) #f))] + [else (loop name ip #f)]))))] [else #f])) diff --git a/collects/net/private/ip.rkt b/collects/net/private/ip.rkt index 1b7e034417..7178a28e4f 100644 --- a/collects/net/private/ip.rkt +++ b/collects/net/private/ip.rkt @@ -34,8 +34,6 @@ (struct ipv4 ([bytes (bytes-of-length 4)])) (struct ipv6 ([bytes (bytes-of-length 16)])))) -(module+ test (require rackunit)) - ;; data definitions ;; An IPAddress is one of @@ -73,26 +71,6 @@ [(? (bytes-of-length 4)) (ipv4 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) (and (string? val) (or (ipv4-string? val) @@ -147,39 +125,6 @@ ;; this is the +1 octet pair (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 ;; converts a string representating an IPv4 address to bytes (define (ipv4-string->bytes ip) @@ -190,16 +135,6 @@ (string->number (list-ref result 3)) (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 ;; converts a string representing an IPv6 address to bytes (define (ipv6-string->bytes ip) @@ -224,22 +159,6 @@ (loop (bytes-append result (octet-pair-string->bytes (car 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 ;; Turn an ip struct into a byte string (define (ip-address->bytes ip) @@ -247,12 +166,6 @@ [(? ipv4?) (ipv4-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 ;; Convert an IP address to a string (define (ip-address->string ip) @@ -260,25 +173,10 @@ [(? ipv4?) (ipv4->string (ipv4-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 ;; Convert a bytestring for an IPv4 address to a string (define (ipv4->string bytes) - (string-join (for/list ([b 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")) + (string-join (for/list ([b (in-bytes bytes)]) (~r b)) ".")) ;; Bytes -> String ;; Convert a bytestring representing an IPv6 address to a string @@ -291,7 +189,7 @@ (define compressed (compress two-octets)) ;; add an extra "" if :: is at the start (define compressed-strs - (for/list ([elem compressed]) + (for/list ([elem (in-list compressed)]) (if (eq? elem '::) "" ; string-join will turn this into :: (~r elem #:base 16)))) @@ -301,41 +199,21 @@ 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 '::)) ;; Compress an IPv6 address to its shortest representation (define (compress lon) (let loop ([acc '()] [lon lon]) (cond [(empty? lon) (reverse acc)] [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)) (if (<= num-zs 1) (loop (cons (car lon) acc) (cdr lon)) (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 (define (bytes-of-length n) (flat-named-contract `(bytes-of-length ,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"))) - diff --git a/collects/tests/net/dns.rkt b/collects/tests/net/dns.rkt index 495c0c0e6e..336f6f032a 100644 --- a/collects/tests/net/dns.rkt +++ b/collects/tests/net/dns.rkt @@ -2,33 +2,43 @@ (require net/dns tests/eli-tester) -;; Run internal unit tests -(require (submod net/dns test)) +;; internal tests +(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 ;; when server setups change, so keep them up-to-date. -(define *google-dns* "8.8.8.8") +(define *google-dns* "8.8.8.8") (define *google-dns-2* "8.8.4.4") -(define *racket-url* "racket-lang.org") -(define *racket-host* "champlain.ccs.neu.edu") -(define *racket-ip* "129.10.115.116") -(define *racket-mx* "aspmx.l.google.com") -(define *kame-url* "www.kame.net") -(define *kame-ip* "2001:200:dff:fff1:216:3eff:feb1:44d7") +(define *racket-url* "racket-lang.org") +(define *racket-host* "champlain.ccs.neu.edu") +(define *racket-ip* "129.10.115.116") +(define *racket-mx* "aspmx.l.google.com") +(define *kame-url* "www.kame.net") +(define *kame-ip* "2001:200:dff:fff1:216:3eff:feb1:44d7") -(module+ main (tests)) -(define (dns-test/nameserver nameserver) +(define (nameserver-tests nameserver) (test (dns-get-address nameserver *racket-url*) => *racket-ip* (dns-get-address nameserver *racket-host*) => *racket-ip* (dns-get-address nameserver *kame-url* #:ipv6? #t) => *kame-ip* (dns-get-name nameserver *racket-ip*) => *racket-host* (dns-get-mail-exchanger nameserver *racket-url*) => *racket-mx*)) +(provide tests) +(module+ main (tests)) (define (tests) - (dns-test/nameserver *google-dns*) - (dns-test/nameserver *google-dns-2*) - - (define ns (dns-find-nameserver)) - (when ns - (dns-test/nameserver ns))) - + (test do (internal-tests) + (nameserver-tests *google-dns*) + (nameserver-tests *google-dns-2*) + (let ([ns (dns-find-nameserver)]) (when ns (nameserver-tests ns))))) diff --git a/collects/tests/net/ip.rkt b/collects/tests/net/ip.rkt new file mode 100644 index 0000000000..3f91d5c8b3 --- /dev/null +++ b/collects/tests/net/ip.rkt @@ -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")) + ;; ---------------------------------------- + )) diff --git a/collects/tests/net/main.rkt b/collects/tests/net/main.rkt index 4eed040b91..3b0fb4d114 100644 --- a/collects/tests/net/main.rkt +++ b/collects/tests/net/main.rkt @@ -1,6 +1,8 @@ #lang racket/base (require tests/eli-tester + (prefix-in ip: "ip.rkt") + (prefix-in dns: "dns.rkt") (prefix-in ucodec: "uri-codec.rkt") (prefix-in url: "url.rkt") (prefix-in cgi: "cgi.rkt") @@ -13,7 +15,9 @@ (prefix-in websocket: "websocket.rkt")) (define (tests) - (test do (url:tests) + (test do (ip:tests) + do (dns:tests) + do (url:tests) do (ucodec:tests) do (ucodec:noels-tests) do (cgi:tests) diff --git a/collects/tests/net/url.rkt b/collects/tests/net/url.rkt index 8c47a3ce1f..cddf7685d1 100644 --- a/collects/tests/net/url.rkt +++ b/collects/tests/net/url.rkt @@ -43,7 +43,9 @@ (test (combine-url/relative-vec (->vec base) relative) => (->vec expected))) -(define (run-tests) +(provide tests) +(module+ main (tests)) +(define (tests) (test ;; Test the current-proxy-servers parameter can be set (parameterize ([current-proxy-servers '(("http" "proxy.com" 3128))]) @@ -373,7 +375,3 @@ )) ) - -(provide tests) -(module+ main (tests)) -(define (tests) (test do (run-tests)))