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

316
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)
@ -39,23 +33,23 @@
;; A Type is one of the following ;; A Type is one of the following
(define types (define types
'((a 1) '((a 1)
(ns 2) (ns 2)
(md 3) (md 3)
(mf 4) (mf 4)
(cname 5) (cname 5)
(soa 6) (soa 6)
(mb 7) (mb 7)
(mg 8) (mg 8)
(mr 9) (mr 9)
(null 10) (null 10)
(wks 11) (wks 11)
(ptr 12) (ptr 12)
(hinfo 13) (hinfo 13)
(minfo 14) (minfo 14)
(mx 15) (mx 15)
(txt 16) (txt 16)
(aaaa 28))) (aaaa 28)))
;; A Class is one of the following ;; A Class is one of the following
(define classes (define classes
@ -67,9 +61,9 @@
;;; ;;;
(define (cossa i l) (define (cossa i l)
(cond [(null? l) #f] (cond [(null? l) #f]
[(equal? (cadar l) i) (car l)] [(equal? (cadar l) i) (car l)]
[else (cossa i (cdr l))])) [else (cossa i (cdr l))]))
(define (number->octet-pair n) (define (number->octet-pair n)
(list (arithmetic-shift n -8) (list (arithmetic-shift n -8)
@ -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,27 +128,26 @@
(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
(values #f (cdr start))] (values #f (cdr start))]
[(zero? (bitwise-and #xc0 v)) [(zero? (bitwise-and #xc0 v))
;; Normal label ;; Normal label
(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)])
@ -191,7 +184,7 @@
(values (list name type class) start)))) (values (list name type class) start))))
(define (parse-n parse start reply n) (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) (if (zero? n)
(values (reverse accum) start) (values (reverse accum) start)
(let-values ([(rr start) (parse start reply)]) (let-values ([(rr start) (parse start reply)])
@ -205,58 +198,51 @@
(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 () (define s (make-bytes 512))
(let ([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) (bytes->list (subbytes s 0 (car r)))))
(lambda (r) (handle-evt (alarm-evt (+ (current-inexact-milliseconds)
(bytes->list (subbytes s 0 (car r))))) timeout))
(handle-evt (alarm-evt (+ (current-inexact-milliseconds) (lambda (v) (retry (* timeout 2)))))))
timeout)) (lambda () (udp-close udp))))
(lambda (v) ;; First two bytes must match sent message id:
(retry (* timeout 2)))))))) (unless (and (= (car reply) (car query))
(lambda () (udp-close udp)))]) (= (cadr reply) (cadr query)))
(error 'dns-query "bad reply id from server"))
;; First two bytes must match sent message id: (define v0 (caddr reply))
(unless (and (= (car reply) (car query)) (define v1 (cadddr reply))
(= (cadr reply) (cadr query))) ;; Check for error code:
(error 'dns-query "bad reply id from server")) (let ([rcode (bitwise-and #xf v1)])
(unless (zero? rcode)
(let ([v0 (caddr reply)] (error 'dns-query "error from server: ~a"
[v1 (cadddr reply)]) (case rcode
;; Check for error code: [(1) "format error"]
(let ([rcode (bitwise-and #xf v1)]) [(2) "server failure"]
(unless (zero? rcode) [(3) "name error"]
(error 'dns-query "error from server: ~a" [(4) "not implemented"]
(case rcode [(5) "refused"]))))
[(1) "format error"] (define qd-count (octet-pair->number (list-ref reply 4) (list-ref reply 5)))
[(2) "server failure"] (define an-count (octet-pair->number (list-ref reply 6) (list-ref reply 7)))
[(3) "name error"] (define ns-count (octet-pair->number (list-ref reply 8) (list-ref reply 9)))
[(4) "not implemented"] (define ar-count (octet-pair->number (list-ref reply 10) (list-ref reply 11)))
[(5) "refused"])))) (define start (list-tail reply 12))
(let*-values ([(qds start) (parse-n parse-ques start reply qd-count)]
(let ([qd-count (octet-pair->number (list-ref reply 4) (list-ref reply 5))] [(ans start) (parse-n parse-rr start reply an-count)]
[an-count (octet-pair->number (list-ref reply 6) (list-ref reply 7))] [(nss start) (parse-n parse-rr start reply ns-count)]
[ns-count (octet-pair->number (list-ref reply 8) (list-ref reply 9))] [(ars start) (parse-n parse-rr start reply ar-count)])
[ar-count (octet-pair->number (list-ref reply 10) (list-ref reply 11))]) (unless (null? start)
(error 'dns-query "error parsing server reply"))
(let ([start (list-tail reply 12)]) (values (positive? (bitwise-and #x4 v0))
(let*-values ([(qds start) (parse-n parse-ques start reply qd-count)] qds ans nss ars reply)))
[(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 ;; 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,10 +276,10 @@
(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)])
(and ns (and ns
(not (member ns tried)) (not (member ns tried))
(loop ns (cons ns tried))))))))) (loop ns (cons ns tried)))))))))
@ -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,34 +387,34 @@
(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
values values
(process/ports (process/ports
#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)
(or ip name)] (or ip name)]
[(and (not name) [(and (not name)
(regexp-match #rx"^Default Server: +(.*)$" line)) (regexp-match #rx"^Default Server: +(.*)$" line))
=> (lambda (m) (loop (cadr m) #f #t))] => (lambda (m) (loop (cadr m) #f #t))]
[(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")))

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

@ -2,33 +2,43 @@
(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.
(define *google-dns* "8.8.8.8") (define *google-dns* "8.8.8.8")
(define *google-dns-2* "8.8.4.4") (define *google-dns-2* "8.8.4.4")
(define *racket-url* "racket-lang.org") (define *racket-url* "racket-lang.org")
(define *racket-host* "champlain.ccs.neu.edu") (define *racket-host* "champlain.ccs.neu.edu")
(define *racket-ip* "129.10.115.116") (define *racket-ip* "129.10.115.116")
(define *racket-mx* "aspmx.l.google.com") (define *racket-mx* "aspmx.l.google.com")
(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)))