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

Use net/private/ip in net/dns

Browse Source 
This simplifies the code by outsourcing IP
address functionality to net/private/ip.

original commit: 92102a2f07
This commit is contained in:
Asumu Takikawa 2013-04-04 11:53:36 -04:00
parent a1d0fe9fe1
commit 3822cad523
1 changed files with 59 additions and 169 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

228
collects/net/dns.rkt
View File

@ -2,7 +2,8 @@
;; DNS query library for Racket ;; DNS query library for Racket
(require racket/bool (require "private/ip.rkt"
racket/bool
racket/contract racket/contract
racket/format racket/format
racket/list racket/list
@ -14,13 +15,17 @@
(provide (contract-out (provide (contract-out
[dns-get-address [dns-get-address
(->* (ip-address-string? string?) (->* ((or/c ip-address? ip-address-string?) string?)
(#:ipv6? any/c) (#:ipv6? any/c)
ip-address-string?)] ip-address-string?)]
[dns-get-name [dns-get-name
(-> ip-address-string? ip-address-string? string?)] (-> (or/c ip-address? ip-address-string?)
(or/c ip-address? ip-address-string?)
string?)]
[dns-get-mail-exchanger [dns-get-mail-exchanger
(-> ip-address-string? string? (or/c bytes? string?))] (-> (or/c ip-address? ip-address-string?)
string?
(or/c bytes? string?))]
[dns-find-nameserver [dns-find-nameserver
(-> (or/c ip-address-string? #f))])) (-> (or/c ip-address-string? #f))]))
@ -29,95 +34,8 @@
;; UDP retry timeout: ;; UDP retry timeout:
(define INIT-TIMEOUT 50) (define INIT-TIMEOUT 50)
;; Contract utilities and Data Definitions ;; Data Definitions
;;
;; An LB is a (Listof Bytes) ;; An LB is a (Listof Bytes)
;;
;; An IPAddressString passes the following predicate
(define (ip-address-string? val)
(and (string? val)
(or (ipv4-string? val)
(ipv6-string? val))))
;; String -> Boolean
;; Check if the input string represents an IPv4 address
(define (ipv4-string? str)
;; String -> Boolean
;; check if the given string has leading zeroes
(define (has-leading-zeroes? str)
(and (> (string-length str) 1)
(char=? (string-ref str 0) #\0)))
(define matches
(regexp-match #px"^(\\d{1,3})\\.(\\d{1,3})\\.(\\d{1,3})\\.(\\d{1,3})$"
str))
(and matches
(= (length matches) 5)
;; check that each octet field is an octet
(andmap byte? (map string->number (cdr matches)))
;; leading zeroes lead to query errors
(not (ormap has-leading-zeroes? matches))))
;; String -> Boolean
;; Check if the input string represents an IPv6 address
;; TODO: support dotted quad notation
(define (ipv6-string? str)
(define re-::/: #px"^([0-9a-fA-F]{1,4})(::|:)")
(define re-:: #px"^()(::)")
(define re-: #px"^([0-9a-fA-F]{1,4})(:)")
(define re-end #px"^[0-9a-fA-F]{1,4}$")
(or (regexp-match? #px"^::$" str) ; special case
(let loop ([octet-pairs '()] ; keep octet-pairs to count
[::? #f] ; seen a :: in the string yet?
[str str])
;; match digit groups and a separator
(define matches
(if ::?
(regexp-match re-: str)
(or (regexp-match re-:: str)
(regexp-match re-::/: str))))
(cond [matches
(match-define (list match digits sep) matches)
(define rest (substring str (string-length match)))
;; we need to make sure there is only one :: at most
(if (or ::? (string=? sep "::"))
(loop (cons digits octet-pairs) #t rest)
(loop (cons digits octet-pairs) #f rest))]
[else
(and ;; if there isn't a ::, we need 7+1 octet-pairs
(implies (not ::?) (= (length octet-pairs) 7))
;; this is the +1 octet pair
(regexp-match? re-end str))]))))
(module+ test
(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")))
;; A Type is one of the following ;; A Type is one of the following
(define types (define types
@ -280,12 +198,14 @@
(loop (sub1 n) start (cons rr accum)))))) (loop (sub1 n) start (cons rr accum))))))
;; NameServer String Type Class -> (Values Boolean LB LB LB LB LB) ;; NameServer String Type Class -> (Values Boolean LB LB LB LB LB)
(define (dns-query nameserver addr type class) (define (dns-query nameserver-ip addr type class)
(unless (assoc type types) (unless (assoc type types)
(raise-type-error 'dns-query "DNS query type" type)) (raise-type-error 'dns-query "DNS query type" type))
(unless (assoc class classes) (unless (assoc class classes)
(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))
(let* ([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)]
[udp (udp-open-socket nameserver 53)] [udp (udp-open-socket nameserver 53)]
@ -345,51 +265,22 @@
;; NameServer Address Type Class -> (Values Boolean LB LB LB LB LB) ;; NameServer Address Type Class -> (Values Boolean LB LB LB LB LB)
;; Execute a DNS query and cache it ;; Execute a DNS query and cache it
(define (dns-query/cache nameserver addr type class) (define (dns-query/cache nameserver addr type class)
(let ([key (string->symbol (format "~a;~a;~a;~a" nameserver addr type class))]) (define key (string->symbol (format "~a;~a;~a;~a" nameserver addr type class)))
(let ([v (hash-ref cache key (lambda () #f))]) (define v (hash-ref cache key (lambda () #f)))
(if v (if v
(apply values v) (apply values v)
(let-values ([(auth? qds ans nss ars reply) (let-values ([(auth? qds ans nss ars reply)
(dns-query nameserver addr type class)]) (dns-query nameserver addr type class)])
(hash-set! cache key (list auth? qds ans nss ars reply)) (hash-set! cache key (list auth? qds ans nss ars reply))
(values auth? qds ans nss ars reply)))))) (values auth? qds ans nss ars reply))))
(define (ip->string s) ;; Convert a list of bytes representing an IPv4 address to a string
(format "~a.~a.~a.~a" (define (ip->string lob)
(list-ref s 0) (list-ref s 1) (list-ref s 2) (list-ref s 3))) (ip-address->string (ipv4 (list->bytes lob))))
;; Convert a list of bytes representing an IPv6 address to a string ;; Convert a list of bytes representing an IPv6 address to a string
(define (ipv6->string lob) (define (ipv6->string lob)
(define two-octets (ip-address->string (ipv6 (list->bytes lob))))
(for/list ([oct-pair (in-slice 2 (in-list lob))])
(define oct1 (car oct-pair))
(define oct2 (cadr oct-pair))
(+ (arithmetic-shift oct1 8) oct2)))
(define compressed (compress two-octets))
(define compressed-strs
(for/list ([elem compressed])
(if (eq? elem '::)
"" ; string-join will turn this into ::
(~r elem #:base 16))))
(string-join compressed-strs ":"))
;; (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 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)))
;; (NameServer -> (Values Any LB Boolean)) NameServer -> Any ;; (NameServer -> (Values Any LB Boolean)) NameServer -> Any
;; Run the given query function, trying until an answer is found ;; Run the given query function, trying until an answer is found
@ -407,48 +298,34 @@
(not (member ns tried)) (not (member ns tried))
(loop ns (cons ns tried))))))))) (loop ns (cons ns tried)))))))))
;; String -> String ;; IPAddress -> String
;; Convert an IP address to a suitable format for a reverse lookup ;; Convert an IP address to a suitable format for a reverse lookup
(define (ip->query-domain ip) (define (ip->query-domain ip)
(if (ipv4-string? ip) (if (ipv4? ip)
(ip->in-addr.arpa ip) (ip->in-addr.arpa ip)
(ip->ip6.arpa ip))) (ip->ip6.arpa ip)))
;; 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)
(let ([result (regexp-match #rx"^([0-9]+)\\.([0-9]+)\\.([0-9]+)\\.([0-9]+)$" (define bytes (ipv4-bytes ip))
ip)]) (format "~a.~a.~a.~a.in-addr.arpa"
(format "~a.~a.~a.~a.in-addr.arpa" (bytes-ref bytes 3) (bytes-ref bytes 2)
(list-ref result 4) (bytes-ref bytes 1) (bytes-ref bytes 0)))
(list-ref result 3)
(list-ref result 2) (module+ test
(list-ref result 1)))) (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 has-::? (regexp-match? #rx"::" ip))
(define octet-pair-strings
(cond [has-::?
(define without-:: (regexp-replace #rx"::" ip ":replace-me:"))
(define pieces (regexp-split #rx":" without-::))
(define num-pieces (sub1 (length pieces))) ; don't count replace-me
(flatten
;; put in as many 0s needed to expand the ::
(for/list ([piece pieces])
(if (string=? piece "replace-me")
(build-list (- 8 num-pieces) (λ _ "0"))
piece)))]
[else (regexp-split #rx":" ip)]))
;; convert to nibbles
(define nibbles (define nibbles
(for/fold ([nibbles '()]) (for/fold ([nibbles '()])
([two-octs octet-pair-strings]) ([byte (ipv6-bytes ip)])
(define n (string->number two-octs 16)) (define nib1 (arithmetic-shift (bitwise-and #xf0 byte) -4))
(define nib1 (arithmetic-shift (bitwise-and #xf000 n) -12)) (define nib2 (bitwise-and #x0f byte))
(define nib2 (arithmetic-shift (bitwise-and #x0f00 n) -8)) (append (list nib2 nib1) nibbles)))
(define nib3 (arithmetic-shift (bitwise-and #x00f0 n) -4))
(define nib4 (bitwise-and #x000f n))
(append (list nib4 nib3 nib2 nib1) nibbles)))
(string-append (string-append
(string-join (string-join
(for/list ([n nibbles]) (~r n #:base 16)) (for/list ([n nibbles]) (~r n #:base 16))
@ -457,16 +334,23 @@
(module+ test (module+ test
(check-equal? (check-equal?
(ip->ip6.arpa "4321:0:1:2:3:4:567:89ab") (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") "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? (check-equal?
(ip->ip6.arpa "2001:db8::567:89ab") (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")) "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 (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'ptr)) ans))
(define (dns-get-name nameserver ip) (define (dns-get-name nameserver-ip-or-string ip-or-string)
(define nameserver (if (ip-address? nameserver-ip-or-string)
nameserver-ip-or-string
(make-ip-address nameserver-ip-or-string)))
(define ip (if (ip-address? ip-or-string)
ip-or-string
(make-ip-address ip-or-string)))
(or (try-forwarding (or (try-forwarding
(lambda (nameserver) (lambda (nameserver)
(let-values ([(auth? qds ans nss ars reply) (let-values ([(auth? qds ans nss ars reply)
@ -485,7 +369,10 @@
#:when (eq? (list-ref ans-entry 1) type)) #:when (eq? (list-ref ans-entry 1) type))
ans-entry)) ans-entry))
(define (dns-get-address nameserver addr #:ipv6? [ipv6? #f]) (define (dns-get-address nameserver-ip-or-string addr #:ipv6? [ipv6? #f])
(define nameserver (if (ip-address? nameserver-ip-or-string)
nameserver-ip-or-string
(make-ip-address nameserver-ip-or-string)))
(define type (if ipv6? 'aaaa 'a)) (define type (if ipv6? 'aaaa 'a))
(define (get-address nameserver) (define (get-address nameserver)
(define-values (auth? qds ans nss ars reply) (define-values (auth? qds ans nss ars reply)
@ -501,7 +388,10 @@
(or (try-forwarding get-address nameserver) (or (try-forwarding get-address nameserver)
(error 'dns-get-address "bad address"))) (error 'dns-get-address "bad address")))
(define (dns-get-mail-exchanger nameserver addr) (define (dns-get-mail-exchanger nameserver-ip-or-string addr)
(define nameserver (if (ip-address? nameserver-ip-or-string)
nameserver-ip-or-string
(make-ip-address nameserver-ip-or-string)))
(or (try-forwarding (or (try-forwarding
(lambda (nameserver) (lambda (nameserver)
(let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'mx 'in)]) (let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'mx 'in)])