+ rr-X -> resource-record-X
+ removed separate cache mapping IPs to FQDNs
This commit is contained in:
mainzelm
parent
a4f7e6f337
commit
e2697605f6
|
|
@ -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 <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 <name> [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 <name> [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 <name> [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))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue