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

Support SRV records in net/dns.

Browse Source 
The new `dns-get-srv` returns a *list* of srv-rr structs, rather than
zero or one. A general-purpose RR-lookup routine, `dns-lookup`, exists
but is not exported for now since its API needs work. See comments in
net/dns.rkt.
This commit is contained in:
Tony Garnock-Jones 2016-01-20 18:43:52 -05:00
parent b37d322638
commit 8e05211169
5 changed files with 245 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
net-doc/net/scribblings/dns.scrbl
View File

@ -1,5 +1,8 @@
#lang scribble/doc
@(require "common.rkt" (for-label net/dns net/dns-unit net/dns-sig))
@(require "common.rkt" scribble/eval (for-label net/dns net/dns-unit net/dns-sig))
@(define dns-evaluator (make-base-eval))
@(dns-evaluator '(require net/dns))
@title[#:tag "dns"]{DNS: Domain Name Service Queries}
@ -32,6 +35,51 @@ an error will be raised.
}
@deftogether[(
@defproc[(dns-get-srv [nameserver string?]
[name string?]
[service string?]
[proto string? "tcp"])
(listof srv-rr?)]
@defstruct*[srv-rr ([priority (integer-in 0 65535)]
[weight (integer-in 0 65535)]
[port (integer-in 0 65535)]
[target string?]) #:prefab]
)]{
@margin-note{An SRV record is a particular kind of DNS resource record
that maps an abstract service name onto a hostname and port
combination. For more information, see
@hyperlink["https://en.wikipedia.org/wiki/SRV_record"]{the Wikipedia
page on SRV records}.}
Consults the specified nameserver (normally a numerical address like
@racket["128.42.1.30"]) to retrieve the SRV records corresponding to
the given name, service, and protocol. Returns a list of
@racket[srv-rr] structs if any corresponding SRV records are found;
otherwise, returns @racket['()].
If @racket[service] is @racket["X"], @racket[proto] is @racket["Y"],
and @racket[name] is @racket["example.com"], then this will retrieve
any SRV records at the domain name @tt{_X._Y.example.com}.
The query record sent to the DNS server includes the "recursive" bit,
but @racket[dns-get-srv] also implements a recursive search itself
in case the server does not provide this optional feature.
@examples[#:eval dns-evaluator
(eval:alts (dns-get-srv (dns-find-nameserver) "racket-lang.org" "xmpp-client")
(list (srv-rr 0 0 5222 "xmpp.racket-lang.org")))
(eval:alts (dns-get-srv (dns-find-nameserver) "racket-lang.org" "nonexistent-protocol")
(list))
(eval:alts (dns-get-srv (dns-find-nameserver) "racket-lang.org" "xmpp-client" "tcp")
(list (srv-rr 0 0 5222 "xmpp.racket-lang.org")))
(eval:alts (dns-get-srv (dns-find-nameserver) "racket-lang.org" "xmpp-client" "udp")
(list))
]
}
@defproc[(dns-get-name [nameserver string?]
[address string?])
string?]{
@ -80,4 +128,5 @@ Imports nothing, exports @racket[dns^].}
@defsignature[dns^ ()]{}
Includes everything exported by the @racketmodname[net/dns] module.
Includes @racket[dns-get-address], @racket[dns-get-name],
@racket[dns-get-mail-exchanger] and @racket[dns-find-nameserver].

131
net-lib/net/dns.rkt
View File

@ -3,17 +3,57 @@
;; DNS query library for Racket
(require "private/ip.rkt"
"private/rr-generic.rkt"
"private/rr-srv.rkt"
racket/contract
racket/format
racket/string
racket/system
racket/udp)
(provide (contract-out
(provide (struct-out srv-rr)
(contract-out
[dns-get-address
(->* ((or/c ip-address? ip-address-string?) string?)
(#:ipv6? any/c)
ip-address-string?)]
[dns-get-srv
(->* ((or/c ip-address? ip-address-string?)
string?
string?)
(string?)
(listof (struct/c srv-rr
(integer-in 0 65535)
(integer-in 0 65535)
(integer-in 0 65535)
string?)))]
;; N.B. We should eventually expose this *kind* of
;; functionality, but this interface is very unfriendly. We
;; should make the interface less unfriendly before we
;; expose this function. It should also be documented when
;; it is exposed.
;;
;; A second option, suitable for use in the interim, would
;; be to move dns-lookup to be a provided identifier (with
;; this contract) from some module in `private/`, but this
;; would involve moving most of the code in this file into
;; `private/`, which... ehhh. Could do I suppose. At least
;; that way people would be able to use dns-lookup in
;; extremis, even though it has an ugly API and no
;; documentation.
;;
;; [dns-lookup
;; (-> (or/c ip-address? ip-address-string?)
;; string?
;; #:rr-type symbol?
;; #:rr-parser (-> (listof (list/c bytes? ;; name
;; symbol? ;; type
;; symbol? ;; class
;; integer? ;; ttl
;; (listof byte?))) ;; rdata
;; (listof byte?) ;; the whole packet
;; any/c)
;; any/c)]
[dns-get-name
(-> (or/c ip-address? ip-address-string?)
(or/c ip-address? ip-address-string?)
@ -49,7 +89,8 @@
(minfo 14)
(mx 15)
(txt 16)
(aaaa 28)))
(aaaa 28)
(srv 33)))
;; A Class is one of the following
(define classes
@ -65,31 +106,6 @@
[(equal? (cadar l) i) (car l)]
[else (cossa i (cdr l))]))
(define (number->octet-pair n)
(list (arithmetic-shift n -8)
(modulo n 256)))
(define (octet-pair->number a b)
(+ (arithmetic-shift a 8) b))
(define (octet-quad->number a b c d)
(+ (arithmetic-shift a 24)
(arithmetic-shift b 16)
(arithmetic-shift c 8)
d))
;; Bytes -> LB
;; 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)
(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
;;
;; The opcode & flags are set as:
@ -118,37 +134,6 @@
(define (add-size-tag m)
(append (number->octet-pair (length m)) m))
(define (rr-data rr)
(cadddr (cdr rr)))
(define (rr-type rr)
(cadr rr))
(define (rr-name rr)
(car rr))
(define (parse-name start reply)
(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)])
(let* ([type (car (cossa (octet-pair->number (car start) (cadr start))
@ -341,23 +326,33 @@
ans-entry))
(define (dns-get-address nameserver-ip-or-string addr #:ipv6? [ipv6? #f])
(or (dns-lookup nameserver-ip-or-string addr
#:rr-type (if ipv6? 'aaaa 'a)
#:rr-parser (lambda (answer-records reply)
(and (positive? (length answer-records))
((if ipv6? ipv6->string ip->string)
(rr-data (car answer-records))))))
(error 'dns-lookup "bad address")))
(define (dns-get-srv nameserver-ip-or-string name service [proto "tcp"])
(dns-lookup nameserver-ip-or-string
(format "_~a._~a.~a" service proto name)
#:rr-type 'srv
#:rr-parser parse-srv-rr))
(define (dns-lookup nameserver-ip-or-string addr
#:rr-type type
#:rr-parser rr-parser)
(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 (get-address nameserver)
(define-values (auth? qds ans nss ars reply)
(dns-query/cache nameserver addr type 'in))
(define answer-records (get-records-from-ans ans type))
(define address
(and (positive? (length answer-records))
(let ([data (rr-data (car answer-records))])
(if ipv6?
(ipv6->string data)
(ip->string data)))))
(values address ars auth?))
(or (try-forwarding get-address nameserver)
(error 'dns-get-address "bad address")))
(define result (rr-parser answer-records reply))
(values result ars auth?))
(try-forwarding get-address nameserver))
(define (dns-get-mail-exchanger nameserver-ip-or-string addr)
(define nameserver (if (ip-address? nameserver-ip-or-string)

67
net-lib/net/private/rr-generic.rkt Normal file
View File

@ -0,0 +1,67 @@
#lang racket/base
;; Utilities for parsing and unparsing various pieces of DNS wire formats.
(provide number->octet-pair
octet-pair->number
octet-quad->number
parse-name
name->octets
rr-data
rr-type
rr-name)
(define (number->octet-pair n)
(list (arithmetic-shift n -8)
(modulo n 256)))
(define (octet-pair->number a b)
(+ (arithmetic-shift a 8) b))
(define (octet-quad->number a b c d)
(+ (arithmetic-shift a 24)
(arithmetic-shift b 16)
(arithmetic-shift c 8)
d))
(define (parse-name start reply)
(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))]))
;; Bytes -> LB
;; 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)
(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)))))
(define (rr-data rr)
(cadddr (cdr rr)))
(define (rr-type rr)
(cadr rr))
(define (rr-name rr)
(car rr))

35
net-lib/net/private/rr-srv.rkt Normal file
View File

@ -0,0 +1,35 @@
#lang racket/base
;; Parser and representation for SRV RRs.
(require racket/contract)
(provide parse-srv-rr
(contract-out
(struct srv-rr ((priority (integer-in 0 65535))
(weight (integer-in 0 65535))
(port (integer-in 0 65535))
(target string?)))))
(require racket/match)
(require "rr-generic.rkt")
(struct srv-rr (priority
weight
port
target)
#:prefab)
(define (parse-srv-rr answer-records reply)
(let loop ((rrs answer-records))
(match rrs
['() '()]
[(cons rr rest)
(match (rr-data rr)
[(list* prio1 prio2 weight1 weight2 port1 port2 target-bytes)
(define-values (target-name _rest) (parse-name target-bytes reply))
(cons (srv-rr (octet-pair->number prio1 prio2)
(octet-pair->number weight1 weight2)
(octet-pair->number port1 port2)
(bytes->string/latin-1 target-name))
(loop rest))]
[_ (loop rest)])])))

30
net-test/tests/net/dns.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require net/dns rackunit)
(require net/private/rr-srv)
;; internal tests
@ -90,13 +91,39 @@
(define *nwu-mx* '("cuda.eecs.northwestern.edu" "barra.eecs.northwestern.edu"))
(define *kame-url* "www.kame.net")
(define *kame-ip* "2001:200:dff:fff1:216:3eff:feb1:44d7")
(define *xmpp-client* (srv-rr 0 0 5222 "xmpp.racket-lang.org"))
(define (nameserver-tests nameserver)
(check member (dns-get-address nameserver *nwu-url*) *nwu-ips*)
(check-equal? (dns-get-address nameserver *racket-host*) *racket-ip*)
(check-equal? (dns-get-address nameserver *kame-url* #:ipv6? #t) *kame-ip*)
(check-equal? (dns-get-name nameserver *racket-ip*) *racket-host*)
(check member (dns-get-mail-exchanger nameserver *nwu-url*) *nwu-mx*))
(check member (dns-get-mail-exchanger nameserver *nwu-url*) *nwu-mx*)
(check-equal? (dns-get-srv nameserver "racket-lang.org" "xmpp-client") (list *xmpp-client*))
(check-equal? (dns-get-srv nameserver "nonexistent-srv-record.racket-lang.org" "xmpp-client")
'()))
(define (srv-tests)
(define srv-xmpp-8020-srv-rr
'((#"_xmpp-client._tcp.leastfixedpoint.com" srv in 62917
(0 0
0 0
20 102
4 120 109 112 112 13 101 105 103 104 116 121 45 116 119 101 110 116 121 3 111 114 103 0))))
(define srv-xmpp-8020-reply
'(0 185 129 128
0 1
0 1
0 3
0 0
12 95 120 109 112 112 45 99 108 105 101 110 116 4 95 116 99 112 15 108
101 97 115 116 102 105 120 101 100 112 111 105 110 116 3 99 111 109 0 0
33 0 1 192 12 0 33 0 1 0 1 7 160 0 30 0 0 0 0 20 102 4 120 109 112 112
13 101 105 103 104 116 121 45 116 119 101 110 116 121 3 111 114 103 0 192
30 0 2 0 1 0 1 51 30 0 13 1 98 2 110 115 5 106 111 107 101 114 192 46 192
30 0 2 0 1 0 1 51 30 0 4 1 99 192 111 192 30 0 2 0 1 0 1 51 30 0 4 1 97 192 111))
(check-equal? (parse-srv-rr srv-xmpp-8020-srv-rr srv-xmpp-8020-reply)
(list (srv-rr 0 0 5222 "xmpp.eighty-twenty.org"))))
(provide tests)
(module+ main (tests))
@ -104,6 +131,7 @@
(internal-tests)
(nameserver-tests *google-dns*)
(nameserver-tests *google-dns-2*)
(srv-tests)
(let ([ns (dns-find-nameserver)]) (when ns (nameserver-tests ns))))
(module+ test (require (submod ".." main))) ; for raco test & drdr