scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

+ rr-X -> resource-record-X 

+ removed separate cache mapping IPs to FQDNs
This commit is contained in:
mainzelm 2003-02-10 08:04:17 +00:00
parent a4f7e6f337
commit e2697605f6
1 changed files with 278 additions and 289 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

565
scheme/lib/dns.scm
View File

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