From e2697605f6982db181c3559673e0c960bda2348b Mon Sep 17 00:00:00 2001 From: mainzelm Date: Mon, 10 Feb 2003 08:04:17 +0000 Subject: [PATCH] + rr-X -> resource-record-X + removed separate cache mapping IPs to FQDNs --- scheme/lib/dns.scm | 567 ++++++++++++++++++++++----------------------- 1 file changed, 278 insertions(+), 289 deletions(-) diff --git a/scheme/lib/dns.scm b/scheme/lib/dns.scm index 6a4da50..a08f76e 100644 --- a/scheme/lib/dns.scm +++ b/scheme/lib/dns.scm @@ -377,14 +377,14 @@ ;; filters types in a list of rrs (define (filter-type list type) (filter (lambda (rr) - (eq? (rr-type rr) type)) + (eq? (resource-record-type rr) type)) list)) -;; sorts a mx-rr-list by preference. needed for dns-lookup-mail-exchanger. +;; sorts a mx-resource-record-list by preference. needed for dns-lookup-mail-exchanger. (define (sort-by-preference mx-list) (sort-list mx-list (lambda (a b) - (< (rr-data-mx-preference (rr-data a)) (rr-data-mx-preference (rr-data b)))))) + (< (resource-record-data-mx-preference (resource-record-data a)) (resource-record-data-mx-preference (resource-record-data b)))))) ;; returns a IP if available (additonal type-a processing) @@ -422,16 +422,17 @@ ;; makes a query-message (header and question only) ;; TODO does this really work for several questions as well? -(define (make-query-dns-message header . questions) - (make-message header questions '() '() '() - (apply - append - (header->octets header) - (map question->octets questions)))) +(define (make-query-message header question . questions) + (let ((questions (cons question questions))) + (make-message header questions '() '() '() + (apply + append + (header->octets header) + (map question->octets questions))))) -(define (make-simple-query-dns-message id name type class) - (make-query-dns-message (make-std-query-header id 1) - (make-question name type class))) +(define (make-simple-query-message name type class) + (make-query-message (make-std-query-header (random 256) 1) + (make-question name type class))) ;; makes a resource record for ans, nss, ars (name, type, class, ttl, data) (define (make-octet-rr name type class ttl rdata) @@ -566,15 +567,15 @@ (message-class-number (question-class q))))) (append qname qtype qclass))) -;;type rr -(define-record-type rr :rr - (make-rr name type class ttl data) - rr? - (name rr-name) - (type rr-type) - (class rr-class) - (ttl rr-ttl) - (data rr-data)) +;;type resource-record +(define-record-type resource-record :resource-record + (make-resource-record name type class ttl data) + resource-record? + (name resource-record-name) + (type resource-record-type) + (class resource-record-class) + (ttl resource-record-ttl) + (data resource-record-data)) ;; cache (define-record-type cache :cache @@ -654,94 +655,94 @@ (start start) (accum '())) (if (zero? len) - (values (make-rr name type class ttl (parse-rr-data type class (reverse! accum) message)) start) + (values (make-resource-record name type class ttl (parse-resource-record-data type class (reverse! accum) message)) start) (loop (- len 1) (cdr start) (cons (car start) accum))))))))))) -;;; -- rr-data-type records +;;; -- resource-record-data-type records -(define-record-type rr-data-a :rr-data-a - (make-rr-data-a ip) - rr-data-a? - (ip rr-data-a-ip)) +(define-record-type resource-record-data-a :resource-record-data-a + (make-resource-record-data-a ip) + resource-record-data-a? + (ip resource-record-data-a-ip)) -(define-record-type rr-data-ns :rr-data-ns - (make-rr-data-ns name) - rr-data-ns? - (name rr-data-ns-name)) +(define-record-type resource-record-data-ns :resource-record-data-ns + (make-resource-record-data-ns name) + resource-record-data-ns? + (name resource-record-data-ns-name)) -(define-record-type rr-data-cname :rr-data-cname - (make-rr-data-cname name) - rr-data-cname? - (name rr-data-cname-name)) +(define-record-type resource-record-data-cname :resource-record-data-cname + (make-resource-record-data-cname name) + resource-record-data-cname? + (name resource-record-data-cname-name)) ;; ### ;; hinfo not correctly implemented, trying to find examples -(define-record-type rr-data-hinfo :rr-data-hinfo - (make-rr-data-hinfo data) - rr-data-hinfo? - (data rr-data-hinfo-data)) +(define-record-type resource-record-data-hinfo :resource-record-data-hinfo + (make-resource-record-data-hinfo data) + resource-record-data-hinfo? + (data resource-record-data-hinfo-data)) -(define-record-type rr-data-mx :rr-data-mx - (make-rr-data-mx preference exchanger) - rr-data-mx? - (preference rr-data-mx-preference) - (exchanger rr-data-mx-exchanger)) +(define-record-type resource-record-data-mx :resource-record-data-mx + (make-resource-record-data-mx preference exchanger) + resource-record-data-mx? + (preference resource-record-data-mx-preference) + (exchanger resource-record-data-mx-exchanger)) -(define-record-type rr-data-ptr :rr-data-ptr - (make-rr-data-ptr name) - rr-data-ptr? - (name rr-data-ptr-name)) +(define-record-type resource-record-data-ptr :resource-record-data-ptr + (make-resource-record-data-ptr name) + resource-record-data-ptr? + (name resource-record-data-ptr-name)) -(define-record-type rr-data-soa :rr-data-soa - (make-rr-data-soa mname rname serial refresh retry expire minimum) - rr-data-soa? - (mname rr-data-soa-mname) - (rname rr-data-soa-rname) - (serial rr-data-soa-serial) - (refresh rr-data-soa-refresh) - (retry rr-data-soa-retry) - (expire rr-data-soa-expire) - (minimum rr-data-soa-minimum)) +(define-record-type resource-record-data-soa :resource-record-data-soa + (make-resource-record-data-soa mname rname serial refresh retry expire minimum) + resource-record-data-soa? + (mname resource-record-data-soa-mname) + (rname resource-record-data-soa-rname) + (serial resource-record-data-soa-serial) + (refresh resource-record-data-soa-refresh) + (retry resource-record-data-soa-retry) + (expire resource-record-data-soa-expire) + (minimum resource-record-data-soa-minimum)) ;; ### same as hinfo -(define-record-type rr-data-txt :rr-data-txt - (make-rr-data-txt text) - rr-data-txt? - (text rr-data-txt-text)) +(define-record-type resource-record-data-txt :resource-record-data-txt + (make-resource-record-data-txt text) + resource-record-data-txt? + (text resource-record-data-txt-text)) ;; ### same as hinfo and txt -(define-record-type rr-data-wks :rr-data-wks - (make-rr-data-wks data) - rr-data-wks? - (data rr-data-wks-data)) +(define-record-type resource-record-data-wks :resource-record-data-wks + (make-resource-record-data-wks data) + resource-record-data-wks? + (data resource-record-data-wks-data)) ;; -(define (parse-rr-data type class data message) +(define (parse-resource-record-data type class data message) (cond ((eq? type (message-type a)) - (make-rr-data-a (octet-ip->address32 data))) + (make-resource-record-data-a (octet-ip->address32 data))) ((eq? type (message-type ns)) - (make-rr-data-ns (call-with-values + (make-resource-record-data-ns (call-with-values (lambda () (parse-name data message)) (lambda (name rest) name)))) ((eq? type (message-type cname)) - (make-rr-data-cname (call-with-values + (make-resource-record-data-cname (call-with-values (lambda () (parse-name data message)) (lambda (name rest) name)))) ((eq? type (message-type mx)) - (make-rr-data-mx (octet-pair->number (car data) (cadr data)) + (make-resource-record-data-mx (octet-pair->number (car data) (cadr data)) (call-with-values (lambda ()(parse-name (cddr data) message)) (lambda (name rest) name)))) ((eq? type (message-type ptr)) - (make-rr-data-ptr (call-with-values + (make-resource-record-data-ptr (call-with-values (lambda () (parse-name data message)) (lambda (name rest) name)))) @@ -762,16 +763,16 @@ (rest (cddddr rest))) (let ((minimum (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest))) (rest (cddddr rest))) - (make-rr-data-soa mname rname serial refresh retry expire minimum))))))))))) + (make-resource-record-data-soa mname rname serial refresh retry expire minimum))))))))))) ((eq? type (message-type hinfo)) - (make-rr-data-hinfo (list->string data))) + (make-resource-record-data-hinfo (list->string data))) ((eq? type (message-type txt)) - (make-rr-data-txt (list->string data))) + (make-resource-record-data-txt (list->string data))) ((eq? type (message-type wks)) - (make-rr-data-wks data)) + (make-resource-record-data-wks data)) (else (list data)))) @@ -875,10 +876,10 @@ (sock (cdr (assoc w wport-socket-alist)))) (if (not (connect-socket-successful? sock)) (dns-error 'bad-nameserver hit-ns)) - (let ((query-string - (add-size-tag (list->string (message-source query)))) + (let ((query-string + (list->string (add-size-tag (message-source query)))) (r (socket:inport sock))) - (display (list->string query-string) w) + (display query-string w) (force-output w) (let ((a (read-char r)) (b (read-char r))) @@ -960,12 +961,12 @@ (for-each (lambda (x) (find-shortest-ttl-1 x)) (message-nameservers dns-msg)) (for-each (lambda (x) (find-shortest-ttl-1 x)) (message-additionals dns-msg)) minimum) - ((rr? dns-msg) + ((resource-record? dns-msg) (cond - ((not minimum) (set! minimum (rr-ttl dns-msg))) + ((not minimum) (set! minimum (resource-record-ttl dns-msg))) (else - (if (and (not minimum) (> minimum (rr-ttl dns-msg))) - (set! minimum (rr-ttl dns-msg)))))))))) + (if (and (not minimum) (> minimum (resource-record-ttl dns-msg))) + (set! minimum (resource-record-ttl dns-msg)))))))))) (find-shortest-ttl-1 dns-msg))) @@ -1022,10 +1023,17 @@ nameservers))) (else (lp (cdr ns)))))))) +(define-enumerated-type network-protocol :network-protocol + network-protocol? + network-protocols + network-protocol-name + network-protocol-index + (udp tcp)) + (define (send-receive-message nameservers query protocol) ((cond - ((eq? protocol 'tcp) send-receive-message-tcp) - ((eq? protocol 'udp) send-receive-message-udp)) + ((eq? protocol (network-protocol tcp)) send-receive-message-tcp) + ((eq? protocol (network-protocol udp)) send-receive-message-udp)) nameservers query)) ;; makes a dns-query. optional cache-check. @@ -1042,28 +1050,29 @@ ;; this feature is technically optional (RFC 1035). ;; dns-get-information implements the resovler-side recursion. ;; it returns a dns-message -(define (dns-get-information query use-cache? protocol nameservers check-answer) - (let lp ((tried '()) (nss nameservers)) - (if (null? nss) - (dns-error 'bad-address) - (receive (dns-msg hit-ns nss-with-no-reply) - (dns-query/cache query use-cache? protocol nss tried) - (if (check-answer dns-msg) - dns-msg - (let ((auth? (flags-authoritative? (header-flags - (message-header - (dns-message-reply dns-msg)))))) - (if auth? - (dns-error 'bad-address) - ;; other nameservers names are found in the nameserver-part, - ;; but their ip-adresses are found in the additonal-rrs - (let ((other-nameservers - (filter (lambda (elem) (eq? (rr-type elem) (message-type a))) - (message-additionals (dns-message-reply dns-msg))))) - (lp (if (not (member hit-ns tried)) (cons hit-ns tried) tried) - (lset-union equal? - nss-with-no-reply - (lset-difference equal? other-nameservers tried))))))))))) +(define (dns-get-information query protocol check-answer . args) + (receive (nameservers use-cache?) (lookup-optional-args args) + (let lp ((tried '()) (nss nameservers)) + (if (null? nss) + (dns-error 'bad-address) + (receive (dns-msg hit-ns nss-with-no-reply) + (dns-query/cache query use-cache? protocol nss tried) + (if (check-answer dns-msg) + dns-msg + (let ((auth? (flags-authoritative? (header-flags + (message-header + (dns-message-reply dns-msg)))))) + (if auth? + (dns-error 'bad-address) + ;; other nameservers names are found in the nameserver-part, + ;; but their ip-adresses are found in the additonal-rrs + (let ((other-nameservers + (filter (lambda (elem) (eq? (resource-record-type elem) (message-type a))) + (message-additionals (dns-message-reply dns-msg))))) + (lp (if (not (member hit-ns tried)) (cons hit-ns tried) tried) + (lset-union equal? + nss-with-no-reply + (lset-difference equal? other-nameservers tried)))))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Parsing of /etc/resolv.conf @@ -1241,147 +1250,147 @@ (car ns)))) -;; checks the nameservers argument of the lookup functions. +;; computes the nameservers argument of the lookup functions. ;; if a nameserver-name is given and not a nameserver-ip ;; (dns-lookup-name nameserver) is called. -(define (check-args args) +;; use-cache? defaults to #t +(define (lookup-optional-args args) (if (null? args) - (map ip-string->address32 (dns-find-nameserver-list)) - (map (lambda (nameserver) - (cond - ((address32? nameserver) nameserver) - ((ip-string? nameserver) (ip-string->address32 nameserver)) - (else (map (dns-lookup-name nameserver (dns-find-nameserver-list)))))) - (car args)))) + (values (map ip-string->address32 (dns-find-nameserver-list)) #t) + (values + (map (lambda (nameserver) + (cond + ((address32? nameserver) nameserver) + ((ip-string? nameserver) (ip-string->address32 nameserver)) + (else (map (dns-lookup-name nameserver (dns-find-nameserver-list)))))) + (car args)) + (if (null? (cdr args)) + #t + (cadr args))))) ;; dns-lookup with more options than dns-lookup-* -(define (dns-lookup name type . nameservers) - (let* ((maybe-ip-string (if (address32? name) - (ip-string->in-addr-arpa (address32->ip-string name)) - (ip-string->in-addr-arpa name))) - (query (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address - (make-simple-query-dns-message - (random 256) maybe-ip-string type (message-class in)) - (make-simple-query-dns-message (random 256) name type (message-class in)))) - (use-cache? #t) - (protocol 'udp) - (nameservers (check-args nameservers)) - (check-answer (lambda (dns-msg) #t)) - (dns-msg (dns-get-information query use-cache? protocol nameservers check-answer)) - (answers (message-answers (dns-message-reply dns-msg)))) - dns-msg)) +(define (dns-lookup name type . args) + (receive (nameservers use-cache?) (lookup-optional-args args) + (let* ((maybe-ip-string (if (address32? name) + (ip-string->in-addr-arpa (address32->ip-string name)) + (ip-string->in-addr-arpa name))) + (query (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address + (make-simple-query-message + maybe-ip-string type (message-class in)) + (make-simple-query-message name type (message-class in)))) + (protocol (network-protocol udp)) + (check-answer (lambda (dns-msg) #t)) + (dns-msg (dns-get-information query protocol check-answer nameservers use-cache?)) + (answers (message-answers (dns-message-reply dns-msg)))) + dns-msg))) ;; looks up a hostname, returns an ip. ;; (dns-lookup-name nameservers) -(define (dns-lookup-name name . nameservers) - (let* ((maybe-ip-string (if (address32? name) - (ip-string->in-addr-arpa (address32->ip-string name)) - (ip-string->in-addr-arpa name))) - (query (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address - (dns-error 'not-a-hostname) - (make-simple-query-dns-message (random 256) name (message-type a) (message-class in)))) - (use-cache? #t) - (protocol 'udp) - (nameservers (check-args nameservers)) - (check-answer (lambda (dns-msg) - (let* ((reply (dns-message-reply dns-msg)) - (answers (message-answers reply))) - (not (null? (filter-type answers (message-type a))))))) - (dns-msg (dns-get-information query use-cache? protocol nameservers check-answer)) - (answers (filter-type (message-answers (dns-message-reply dns-msg)) (message-type a)))) - (rr-data-a-ip (rr-data (car answers))))) +(define (dns-lookup-name name . args) + (receive (nameservers use-cache?) (lookup-optional-args args) + (let* ((maybe-ip-string (if (address32? name) + (ip-string->in-addr-arpa (address32->ip-string name)) + (ip-string->in-addr-arpa name))) + (query (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address + (dns-error 'not-a-hostname) + (make-simple-query-message name (message-type a) (message-class in)))) + (protocol (network-protocol udp)) + (check-answer (lambda (dns-msg) + (let* ((reply (dns-message-reply dns-msg)) + (answers (message-answers reply))) + (not (null? (filter-type answers (message-type a))))))) + (dns-msg (dns-get-information query protocol check-answer nameservers use-cache?)) + (answers (filter-type (message-answers (dns-message-reply dns-msg)) (message-type a)))) + (resource-record-data-a-ip (resource-record-data (car answers)))))) ;; looks up an ip, returns a hostname ;; (dns-inverse-lookup [nameserver]) -(define (dns-lookup-ip ip . nameservers) - (let* ((maybe-ip-string (if (address32? ip) - (ip-string->in-addr-arpa (address32->ip-string ip)) - (ip-string->in-addr-arpa ip))) - (query (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address - (make-simple-query-dns-message (random 256) maybe-ip-string (message-type ptr) (message-class in)) - (dns-error 'not-a-ip))) - (use-cache? #t) - (protocol 'udp) - (nameservers (check-args nameservers)) - (check-answer (lambda (dns-msg) - (let* ((reply (dns-message-reply dns-msg)) - (answers (message-answers reply))) - (not (null? (filter-type answers (message-type ptr))))))) - (dns-msg (dns-get-information query use-cache? protocol nameservers check-answer)) - (answers (filter-type (message-answers (dns-message-reply dns-msg)) (message-type ptr)))) - (rr-data-ptr-name (rr-data (car answers))))) +(define (dns-lookup-ip ip . args) + (receive (nameservers use-cache?) (lookup-optional-args args) + (let* ((maybe-ip-string (if (address32? ip) + (ip-string->in-addr-arpa (address32->ip-string ip)) + (ip-string->in-addr-arpa ip))) + (query (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address + (make-simple-query-message maybe-ip-string (message-type ptr) (message-class in)) + (dns-error 'not-a-ip))) + (protocol (network-protocol udp)) + (check-answer (lambda (dns-msg) + (let* ((reply (dns-message-reply dns-msg)) + (answers (message-answers reply))) + (not (null? (filter-type answers (message-type ptr))))))) + (dns-msg (dns-get-information query protocol check-answer nameservers use-cache?)) + (answers (filter-type (message-answers (dns-message-reply dns-msg)) (message-type ptr)))) + (resource-record-data-ptr-name (resource-record-data (car answers)))))) (define dns-inverse-lookup dns-lookup-ip) ;; looks up an authoritative nameserver for a hostname ;; returns a list of nameservers ;; (dns-lookup-nameserver [nameserver]) -(define (dns-lookup-nameserver name . nameservers) - (let* ((maybe-ip-string (if (address32? name) - (ip-string->in-addr-arpa (address32->ip-string name)) - (ip-string->in-addr-arpa name))) - (query (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address - (dns-error 'not-a-hostname) - (make-simple-query-dns-message - (random 256) name (message-type ns) (message-class in)))) - (use-cache? #t) - (protocol 'udp) - (nameservers (check-args nameservers)) - (check-answer (lambda (dns-msg) - (let* ((reply (dns-message-reply dns-msg)) - (answers (message-answers reply)) - (nameservers (message-nameservers reply))) - (or (not (null? (filter-type nameservers (message-type soa)))) - (not (null? (filter-type answers (message-type ns)))))))) - (dns-msg (dns-get-information query use-cache? protocol nameservers check-answer)) - (reply (dns-message-reply dns-msg)) - (soa (filter-type (message-nameservers reply) (message-type soa))) - (nss (filter-type (message-answers reply) (message-type ns))) - (add (filter-type (message-additionals reply) (message-type a)))) - (if (null? nss) - (list (dns-lookup-name (rr-data-soa-mname (rr-data (car soa))))) - (map (lambda (elem) (rr-data-a-ip (rr-data elem))) add)))) +(define (dns-lookup-nameserver name . args) + (receive (nameservers use-cache?) (lookup-optional-args args) + (let* ((maybe-ip-string (if (address32? name) + (ip-string->in-addr-arpa (address32->ip-string name)) + (ip-string->in-addr-arpa name))) + (query (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address + (dns-error 'not-a-hostname) + (make-simple-query-message + name (message-type ns) (message-class in)))) + (protocol (network-protocol udp)) + (check-answer (lambda (dns-msg) + (let* ((reply (dns-message-reply dns-msg)) + (answers (message-answers reply)) + (nameservers (message-nameservers reply))) + (or (not (null? (filter-type nameservers (message-type soa)))) + (not (null? (filter-type answers (message-type ns)))))))) + (dns-msg (dns-get-information query protocol check-answer nameservers use-cache?)) + (reply (dns-message-reply dns-msg)) + (soa (filter-type (message-nameservers reply) (message-type soa))) + (nss (filter-type (message-answers reply) (message-type ns))) + (add (filter-type (message-additionals reply) (message-type a)))) + (if (null? nss) + (list (dns-lookup-name (resource-record-data-soa-mname (resource-record-data (car soa))))) + (map (lambda (elem) (resource-record-data-a-ip (resource-record-data elem))) add))))) ;; looks up a mail-exchanger for a hostname. ;; returns a list of mail-exchanger, sorted by their preference ;; if there are no mx-records in the answer-section, ;; implementation based on RFC2821 ;; (dns-lookup-mail-exchanger [nameserver]) -(define (dns-lookup-mail-exchanger name . nameservers) - (let* ((ip-string (if (address32? name) - (ip-string->in-addr-arpa (address32->ip-string name)) - (ip-string->in-addr-arpa name))) - (query (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address - (dns-error 'not-a-hostname) - (make-simple-query-dns-message - (random 256) name (message-type mx) (message-class in)))) - (use-cache? #t) - (protocol 'tcp) - (nameservers (check-args nameservers)) - (check-answer (lambda (dns-msg) - (let* ((reply (dns-message-reply dns-msg)) - (answers (message-answers reply)) - (nameservers (message-nameservers reply))) - (or (not (null? (filter-type answers (message-type mx)))) - (not (null? (filter-type answers (message-type cname)))) - (not (null? (filter-type answers (message-type a)))))))) - (dns-msg (dns-get-information query use-cache? protocol nameservers check-answer)) - (reply (dns-message-reply dns-msg)) - (mx (filter-type (message-answers reply) (message-type mx))) - (soa (filter-type (message-nameservers reply)(message-type soa))) - (cname (filter-type (message-answers reply) (message-type cname))) - (a (filter-type (message-answers reply) (message-type a)))) +(define (dns-lookup-mail-exchanger name . args) + (receive (nameservers use-cache?) (lookup-optional-args args) + (let* ((ip-string (if (address32? name) + (ip-string->in-addr-arpa (address32->ip-string name)) + (ip-string->in-addr-arpa name))) + (query (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address + (dns-error 'not-a-hostname) + (make-simple-query-message + name (message-type mx) (message-class in)))) + (protocol (network-protocol tcp)) + (check-answer (lambda (dns-msg) + (let* ((reply (dns-message-reply dns-msg)) + (answers (message-answers reply)) + (nameservers (message-nameservers reply))) + (or (not (null? (filter-type answers (message-type mx)))) + (not (null? (filter-type answers (message-type cname)))) + (not (null? (filter-type answers (message-type a)))))))) + (dns-msg (dns-get-information query protocol check-answer nameservers use-cache?)) + (reply (dns-message-reply dns-msg)) + (mx (filter-type (message-answers reply) (message-type mx))) + (soa (filter-type (message-nameservers reply)(message-type soa))) + (cname (filter-type (message-answers reply) (message-type cname))) + (a (filter-type (message-answers reply) (message-type a)))) - (cond - ((not (null? a)) - (list (rr-data-a-ip (rr-data (car a))))) - ((not (null? cname)) - (dns-lookup-mail-exchanger (rr-data-cname-name (rr-data (car cname))))) - ((null? mx) - (list (rr-data-soa-rname (rr-data (car soa))))) - (else - (map (lambda (elem) (rr-data-mx-exchanger (rr-data elem))) (sort-by-preference mx)))))) + (cond + ((not (null? a)) + (list (resource-record-data-a-ip (resource-record-data (car a))))) + ((not (null? cname)) + (dns-lookup-mail-exchanger (resource-record-data-cname-name (resource-record-data (car cname))))) + ((null? mx) + (list (resource-record-data-soa-rname (resource-record-data (car soa))))) + (else + (map (lambda (elem) (resource-record-data-mx-exchanger (resource-record-data elem))) (sort-by-preference mx))))))) ;;; pretty-prints a dns-msg (define (pretty-print-dns-message dns-msg . maybe-port) @@ -1413,8 +1422,8 @@ "not found in cache")) (d 1 "PROTOCOL" (let ((protocol (dns-message-protocol dns-msg))) (cond - ((eq? protocol 'tcp) "TCP") - ((eq? protocol 'udp) "UDP")))) + ((eq? protocol (network-protocol tcp)) "TCP") + ((eq? protocol (network-protocol udp)) "UDP")))) (d 1 "TRIED-NAMESERVERS" (if (> (length (dns-message-tried-nameservers dns-msg)) 1) (begin (display " had perform recursion: ") @@ -1453,73 +1462,52 @@ (d 4 "name " (question-name dns-msg)) (d 4 "type " (message-type-name (question-type dns-msg))) (d 4 "class" (message-class-name (question-class dns-msg))))) - ((rr? dns-msg) + ((resource-record? dns-msg) (begin - (d 4 "name " (rr-name dns-msg)) - (d 4 "type "(message-type-name (rr-type dns-msg))) - (d 4 "class" (message-class-name (rr-class dns-msg))) - (d 4 "ttl " (rr-ttl dns-msg)) - (d 4 "data " "") (show-dns-message (rr-data dns-msg)))) - ((rr-data-a? dns-msg) - (d 5 "ip " (rr-data-a-ip dns-msg))) - ((rr-data-ns? dns-msg) - (d 5 "name " (rr-data-ns-name dns-msg))) - ((rr-data-cname? dns-msg) - (d 5 "name " (rr-data-cname-name dns-msg))) - ((rr-data-mx? dns-msg) + (d 4 "name " (resource-record-name dns-msg)) + (d 4 "type "(message-type-name (resource-record-type dns-msg))) + (d 4 "class" (message-class-name (resource-record-class dns-msg))) + (d 4 "ttl " (resource-record-ttl dns-msg)) + (d 4 "data " "") (show-dns-message (resource-record-data dns-msg)))) + ((resource-record-data-a? dns-msg) + (d 5 "ip " (resource-record-data-a-ip dns-msg))) + ((resource-record-data-ns? dns-msg) + (d 5 "name " (resource-record-data-ns-name dns-msg))) + ((resource-record-data-cname? dns-msg) + (d 5 "name " (resource-record-data-cname-name dns-msg))) + ((resource-record-data-mx? dns-msg) (begin - (d 5 "preference " (rr-data-mx-preference dns-msg)) - (d 5 "exchanger " (rr-data-mx-exchanger dns-msg)))) - ((rr-data-ptr? dns-msg) - (d 5 "name " (rr-data-ptr-name dns-msg))) - ((rr-data-soa? dns-msg) + (d 5 "preference " (resource-record-data-mx-preference dns-msg)) + (d 5 "exchanger " (resource-record-data-mx-exchanger dns-msg)))) + ((resource-record-data-ptr? dns-msg) + (d 5 "name " (resource-record-data-ptr-name dns-msg))) + ((resource-record-data-soa? dns-msg) (begin - (d 5 "mname " (rr-data-soa-mname dns-msg)) - (d 5 "rname " (rr-data-soa-rname dns-msg)) - (d 5 "serial " (rr-data-soa-serial dns-msg)) - (d 5 "refresh " (rr-data-soa-refresh dns-msg)) - (d 5 "expire " (rr-data-soa-expire dns-msg)) - (d 5 "minimum " (rr-data-soa-expire dns-msg)))) + (d 5 "mname " (resource-record-data-soa-mname dns-msg)) + (d 5 "rname " (resource-record-data-soa-rname dns-msg)) + (d 5 "serial " (resource-record-data-soa-serial dns-msg)) + (d 5 "refresh " (resource-record-data-soa-refresh dns-msg)) + (d 5 "expire " (resource-record-data-soa-expire dns-msg)) + (d 5 "minimum " (resource-record-data-soa-expire dns-msg)))) ;; ### - ((rr-data-hinfo? dns-msg) - (d 5 "data " (rr-data-hinfo-data dns-msg))) - ((rr-data-txt? dns-msg) - (d 5 "text " (rr-data-txt-text dns-msg))) - ((rr-data-wks? dns-msg) - (d 5 "data " (rr-data-wks-data dns-msg))) + ((resource-record-data-hinfo? dns-msg) + (d 5 "data " (resource-record-data-hinfo-data dns-msg))) + ((resource-record-data-txt? dns-msg) + (d 5 "text " (resource-record-data-txt-text dns-msg))) + ((resource-record-data-wks? dns-msg) + (d 5 "data " (resource-record-data-wks-data dns-msg))) )) (show-dns-message dns-msg))))) -(define *fqdn-lock* (make-lock)) -(define *fqdn-cache* '()) - -(define (socket-address->fqdn addr cache?) +(define (socket-address->fqdn addr . args) (receive (ip32 port) (socket-address->internet-address addr) - (internet-address->fqdn ip32 cache?))) + (apply dns-lookup-ip ip32 args))) -(define (internet-address->fqdn ip32 cache?) - (if cache? - (begin - (obtain-lock *fqdn-lock*) - (cond - ((assv ip32 *fqdn-cache*) => - (lambda (pair) - (release-lock *fqdn-lock*) - (cdr pair))) - (else - (release-lock *fqdn-lock*) - (let ((fqdn (dns-lookup-ip ip32))) - (set! *fqdn-cache* - (cons (cons ip32 fqdn) *fqdn-cache*)) - fqdn)))) - (dns-lookup-ip ip32))) - - -(define (is-fqdn? name) +(define (fqdn? name) (regexp-search? (rx #\.) name)) -(define (maybe-dns-lookup-name name) +(define (maybe-dns-lookup-name name . args) (call-with-current-continuation (lambda (k) (with-handler (lambda (cond more) @@ -1527,9 +1515,9 @@ (k #f) (more))) (lambda () - (dns-lookup-name name)))))) + (dns-lookup-name name args)))))) -(define (maybe-dns-lookup-ip ip-addr) +(define (maybe-dns-lookup-ip ip-addr . args) (call-with-current-continuation (lambda (k) (with-handler (lambda (cond more) @@ -1537,7 +1525,7 @@ (k #f) (more))) (lambda () - (dns-lookup-ip ip-addr)))))) + (apply dns-lookup-ip ip-addr args)))))) (define (domains-for-search) (cond ((assoc 'domain (resolv.conf)) @@ -1548,20 +1536,21 @@ (cdr pair))) (else '()))) -(define (host-fqdn name-or-socket-address) +(define (host-fqdn name-or-socket-address . args) (if (socket-address? name-or-socket-address) - (socket-address->fqdn name-or-socket-address #f) + (apply socket-address->fqdn name-or-socket-address args) (let ((name name-or-socket-address)) (if (is-fqdn? name) name (let lp ((domains (domains-for-search))) (if (null? domains) #f - (cond ((maybe-dns-lookup-name (string-append name "." (car domains))) + (cond ((apply maybe-dns-lookup-name + (string-append name "." (car domains)) args) => (lambda (ip) - (dns-lookup-ip ip))) + (apply dns-lookup-ip ip args))) (else (lp (cdr domains)))))))))) -(define (system-fqdn) - (host-fqdn (system-name))) +(define (system-fqdn . args) + (apply host-fqdn (system-name) args))