+ error conditions
This commit is contained in:
cresh
parent
5d357598b1
commit
66208241f5
567
dns.scm
567
dns.scm
|
|
@ -6,13 +6,9 @@
|
|||
; based on the PLT-implementation.
|
||||
;
|
||||
;
|
||||
; TODO: -*!!! CHECK-ANSWER !!!
|
||||
; *(wrong: if check-answer is not successfull, bad hostname is returned)
|
||||
; *solution: error conditions -> if thrown, return #f
|
||||
; TODO:
|
||||
; - test, test, test
|
||||
; - types from newer RFCs (41, unknown)
|
||||
; -*error conditions
|
||||
; -*better interface (found or #f)
|
||||
; - more documentation
|
||||
;
|
||||
;
|
||||
|
|
@ -42,6 +38,90 @@
|
|||
(define *debug* #f)
|
||||
|
||||
|
||||
;; --- error conditions
|
||||
(define-condition-type 'invalid-type '())
|
||||
(define invalid-type? (condition-predicate 'invalid-type))
|
||||
|
||||
(define-condition-type 'invalid-class '())
|
||||
(define invalid-class? (condition-predicate 'invalid-class))
|
||||
|
||||
(define-condition-type 'parse-error '())
|
||||
(define parse-error? (condition-predicate 'parse))
|
||||
|
||||
(define-condition-type 'unexpected-eof-from-server '())
|
||||
(define unexpected-eof-from-server? (condition-predicate 'unexpected-eof-from-server))
|
||||
|
||||
(define-condition-type 'bad-address '())
|
||||
(define bad-address? (condition-predicate 'bad-address))
|
||||
|
||||
(define-condition-type 'no-nameservers '())
|
||||
(define no-nameservers? (condition-predicate 'no-nameservers))
|
||||
|
||||
(define-condition-type 'not-a-hostname '())
|
||||
(define not-a-hostname? (condition-predicate 'not-a-hostname))
|
||||
|
||||
(define-condition-type 'not-a-ip '())
|
||||
(define not-a-ip? (condition-predicate 'not-a-ip))
|
||||
|
||||
|
||||
(define-condition-type 'dns-format-error '())
|
||||
(define dns-format-error? (condition-predicate 'dns-format-error))
|
||||
|
||||
(define-condition-type 'dns-server-failure '())
|
||||
(define dns-server-failure? (condition-predicate 'dns-server-failure))
|
||||
|
||||
(define-condition-type 'dns-name-error '())
|
||||
(define dns-name-error? (condition-predicate 'dns-name-error))
|
||||
|
||||
(define-condition-type 'dns-not-implemented '())
|
||||
(define dns-not-implemented? (condition-predicate 'dns-not-implemented))
|
||||
|
||||
(define-condition-type 'dns-refused '())
|
||||
(define dns-refused? (condition-predicate 'dns-refused))
|
||||
|
||||
|
||||
(define-condition-type 'dns-error '(dns-format-error
|
||||
dns-server-failure
|
||||
dns-name-error
|
||||
dns-not-implemented
|
||||
dns-refused))
|
||||
|
||||
(define dns-error? (condition-predicate 'dns-error))
|
||||
|
||||
|
||||
;; called by the error-handlers, prints out error descriptions
|
||||
(define (dns-error-messages condition more)
|
||||
(cond
|
||||
((invalid-type? condition)
|
||||
(display "make-octet-question: invalid DNS query type\n"))
|
||||
((invalid-class? condition)
|
||||
(display "make-octet-question: invalid DNS query class\n"))
|
||||
((parse-error? condition)
|
||||
(display "parse: error parsing server message\n"))
|
||||
((unexpected-eof-from-server? condition)
|
||||
(display "send-receive-message: unexpected EOF from server\n"))
|
||||
((bad-address? condition)
|
||||
(display "dns-get-information: bad address (in combination with query type)\n"))
|
||||
((no-nameservers? condition)
|
||||
(display "dns-find-nameserver: no nameservers found in /etc/resolv.conf\n"))
|
||||
((not-a-hostname? condition)
|
||||
(display "no hostname given\n"))
|
||||
((not-a-ip? condition)
|
||||
(display "no ip given\n"))
|
||||
((dns-format-error? condition)
|
||||
(display "error from server: (1) format error\n"))
|
||||
((dns-server-failure? condition)
|
||||
(display "error from server: (2) server failure\n"))
|
||||
((dns-name-error? condition)
|
||||
(display "error from server: (3) name error\n"))
|
||||
((dns-not-implemented? condition)
|
||||
(display "error from server: (4) not implemented\n"))
|
||||
((dns-refused? condition)
|
||||
(display "error from server: (5) refused\n"))
|
||||
(else (more))))
|
||||
|
||||
|
||||
|
||||
;;; -- globals and types
|
||||
|
||||
;; off
|
||||
|
|
@ -84,7 +164,7 @@
|
|||
(define (cossa i l)
|
||||
(if *debug* (display "cossa\n"))
|
||||
(cond
|
||||
((null? l) 'unknown) ;;(error "dns-message: type not implemented: " i))
|
||||
((null? l) 'unknown)
|
||||
((equal? (cadar l) i)
|
||||
(car l))
|
||||
(else (cossa i (cdr l)))))
|
||||
|
|
@ -164,7 +244,7 @@
|
|||
=> (lambda (match)
|
||||
(loop (match:substring match 2) (append result (list (ascii->char (string->number (match:substring match 1))))))))
|
||||
(else
|
||||
(append result (list (ascii->char (string->number s))))))))
|
||||
(append result (list (ascii->char (string->number s))))))))
|
||||
|
||||
;; calculates a "random" number, needed for message-ids
|
||||
(define random
|
||||
|
|
@ -292,9 +372,9 @@
|
|||
(define (make-octet-question name type class)
|
||||
(if *debug* (display "make-octet-question\n"))
|
||||
(if (not (assoc type types))
|
||||
(error "make-octet-question: invalid DNS query type ~A" type))
|
||||
(signal 'invalid-type))
|
||||
(if (not (assoc class classes))
|
||||
(error "make-octet-question: invalid DNS query class ~A" class))
|
||||
(signal 'invalid-class))
|
||||
|
||||
(let* ((qname (name->octets name))
|
||||
(qtype (number->octet-pair (cadr (assoc type types))))
|
||||
|
|
@ -308,7 +388,7 @@
|
|||
(append
|
||||
(make-std-octet-query-header id 1)
|
||||
(make-octet-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)
|
||||
|
|
@ -516,15 +596,15 @@
|
|||
|
||||
((eq? type 'mx)
|
||||
(make-rr-data-mx (octet-pair->number (car data) (cadr data))
|
||||
(call-with-values
|
||||
(lambda ()(parse-name (cddr data) message))
|
||||
(lambda (name rest) name))))
|
||||
(call-with-values
|
||||
(lambda ()(parse-name (cddr data) message))
|
||||
(lambda (name rest) name))))
|
||||
|
||||
((eq? type 'ptr)
|
||||
(make-rr-data-ptr (call-with-values
|
||||
(lambda () (parse-name data message))
|
||||
(lambda (name rest) name))))
|
||||
|
||||
(lambda () (parse-name data message))
|
||||
(lambda (name rest) name))))
|
||||
|
||||
((eq? type 'soa)
|
||||
(call-with-values
|
||||
(lambda () (parse-name data message))
|
||||
|
|
@ -571,16 +651,16 @@
|
|||
(if *debug* (display "parse-flags\n"))
|
||||
(let ((v0 (list-ref message 2))
|
||||
(v1 (list-ref message 3)))
|
||||
;; Check for error code:
|
||||
(let ((rcode (bitwise-and #xf (char->ascii v1)))
|
||||
(z (arithmetic-shift (bitwise-and 112 (char->ascii v1)) -4))
|
||||
(ra (arithmetic-shift (bitwise-and 64 (char->ascii v1)) -7))
|
||||
(rd (bitwise-and 1 (char->ascii v0)))
|
||||
(tc (arithmetic-shift (bitwise-and 2 (char->ascii v0)) -1))
|
||||
(aa (arithmetic-shift (bitwise-and 4 (char->ascii v0)) -2))
|
||||
(opcode (arithmetic-shift (bitwise-and 120 (char->ascii v0)) -3))
|
||||
(qr (arithmetic-shift (bitwise-and 128 (char->ascii v0)) -7)))
|
||||
(make-flags qr opcode aa tc rd ra z rcode))))
|
||||
;; Check for error code:
|
||||
(let ((rcode (bitwise-and #xf (char->ascii v1)))
|
||||
(z (arithmetic-shift (bitwise-and 112 (char->ascii v1)) -4))
|
||||
(ra (arithmetic-shift (bitwise-and 64 (char->ascii v1)) -7))
|
||||
(rd (bitwise-and 1 (char->ascii v0)))
|
||||
(tc (arithmetic-shift (bitwise-and 2 (char->ascii v0)) -1))
|
||||
(aa (arithmetic-shift (bitwise-and 4 (char->ascii v0)) -2))
|
||||
(opcode (arithmetic-shift (bitwise-and 120 (char->ascii v0)) -3))
|
||||
(qr (arithmetic-shift (bitwise-and 128 (char->ascii v0)) -7)))
|
||||
(make-flags qr opcode aa tc rd ra z rcode))))
|
||||
|
||||
|
||||
;; parses a message-header. returns the header.
|
||||
|
|
@ -593,7 +673,7 @@
|
|||
(ns-count (octet-pair->number (list-ref message 8) (list-ref message 9)))
|
||||
(ar-count (octet-pair->number (list-ref message 10) (list-ref message 11))))
|
||||
(make-header id flags qd-count an-count ns-count ar-count)))
|
||||
|
||||
|
||||
|
||||
;; parses a message. returns the parsed message.
|
||||
(define (parse message)
|
||||
|
|
@ -613,7 +693,7 @@
|
|||
(lambda () (parse-n parse-rr start message (header:arc header)))
|
||||
(lambda (ars start)
|
||||
(if (not (null? start))
|
||||
(error "parse: error parsing server message"))
|
||||
(signal 'parse-error))
|
||||
(make-message header qds ans nss ars message)))))))))))
|
||||
|
||||
|
||||
|
|
@ -629,14 +709,13 @@
|
|||
(display "send-receive-message: bad reply id from server"))
|
||||
;; Check for error code:
|
||||
(let ((rcode (flags:rcode (parse-flags reply))))
|
||||
(if (not (zero? 0));rcode))
|
||||
(error "send-receive-message: error from server: ~A"
|
||||
(case rcode
|
||||
((1) "format error")
|
||||
((2) "server failure")
|
||||
((3) "name error")
|
||||
((4) "not implemented")
|
||||
((5) "refused"))))))
|
||||
(if (not (zero? rcode))
|
||||
(case rcode
|
||||
((1) (signal 'dns-format-error))
|
||||
((2) (signal 'dns-server-failure))
|
||||
((3) (signal 'dns-name-error))
|
||||
((4) (signal 'dns-not-implemented))
|
||||
((5) (signal 'dns-refused))))))
|
||||
|
||||
;; #t if message is truncated (could happen via UDP)
|
||||
(define (truncated? reply)
|
||||
|
|
@ -661,13 +740,13 @@
|
|||
(lambda ()
|
||||
(display (list->string (add-size-tag query)) w)
|
||||
(force-output w)
|
||||
|
||||
|
||||
(let ((a (read-char r))
|
||||
(b (read-char r)))
|
||||
(let ((len (octet-pair->number a b)))
|
||||
(let ((s (read-string len r)))
|
||||
(if (not (= len (string-length s)))
|
||||
(error "send-receive-message: unexpected EOF from server"))
|
||||
(signal 'unexpected-eof-from-server))
|
||||
(string->list s)))))
|
||||
(lambda ()
|
||||
(close-socket socket)))))))
|
||||
|
|
@ -785,8 +864,7 @@
|
|||
(try-recursive
|
||||
(lambda (auth? nss)
|
||||
(if (or auth? (null? nss))
|
||||
(error "dns-get-information: bad address (in combination with query-type)"
|
||||
(question:name (car (message:questions (parse question)))))
|
||||
(signal 'bad-address)
|
||||
(let* ((ns (and (eq? (rr:type (car nss)) 'a) (rr-data-a:ip (rr:data (car nss)))))
|
||||
(dns-msg (if (and ns
|
||||
(not (member ns tried))
|
||||
|
|
@ -820,7 +898,7 @@
|
|||
(cond
|
||||
((eof-object? l)
|
||||
(if (null? ns)
|
||||
(error "dns-find-nameserver-list: no nameserver(s) found in /etc/resolv.conf")
|
||||
(signal 'no-nameservers)
|
||||
ns))
|
||||
((regexp-search (posix-string->regexp "nameserver[ ]+([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+)") l)
|
||||
=> (lambda (match)
|
||||
|
|
@ -833,7 +911,7 @@
|
|||
(define (dns-find-nameserver)
|
||||
(let ((ns (dns-find-nameserver-list)))
|
||||
(if (null? ns)
|
||||
(error "dns-find-nameserver: no nameserver found in /etc/resolv.conf")
|
||||
(signal 'no-nameservers)
|
||||
(car ns))))
|
||||
|
||||
|
||||
|
|
@ -857,7 +935,7 @@
|
|||
(enqueue! queue result)
|
||||
(display "received reply from ")(display nameserver)(display ": ")(display result)(newline)
|
||||
(release-lock lock)))))
|
||||
(dns-find-nameserver-list))))
|
||||
(dns-find-nameserver-list))))
|
||||
|
||||
(let loop ((count (length nameserver-list)))
|
||||
(obtain-lock lock)
|
||||
|
|
@ -865,7 +943,7 @@
|
|||
(if (or result (= 1 (length nameserver-list)))
|
||||
result
|
||||
(loop (- count 1)))))))
|
||||
|
||||
|
||||
;; checks the arguments of the dns-lookup-* functions.
|
||||
;; if a nameserver-name is given and not a nameserver-ip
|
||||
;; (dns-lookup-name nameserver) is called.
|
||||
|
|
@ -881,59 +959,80 @@
|
|||
;; dns-lookup with more options than dns-lookup-*
|
||||
;; optional: nameserver could be passed to the function.
|
||||
(define (dns-lookup name type . args)
|
||||
(let* ((ip-string (ip-string->in-addr name))
|
||||
(question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
|
||||
(make-octet-query-message (random 256) ip-string type 'in)
|
||||
(make-octet-query-message (random 256) name type 'in)))
|
||||
(use-cache? #t)
|
||||
(protocol 'udp)
|
||||
(nameserver (check-args args))
|
||||
(check-answer (lambda (dns-msg) #t))
|
||||
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
|
||||
(answers (message:answers (dns-message:reply dns-msg))))
|
||||
(if (not (null? answers))
|
||||
(for-each (lambda (x) (show-dns-message x)(newline)) answers)
|
||||
(display "no answers received - but resolved information in other sections.\n"))
|
||||
dns-msg))
|
||||
(call-with-current-continuation
|
||||
(lambda (exit)
|
||||
(with-handler
|
||||
(lambda (condition more)
|
||||
(dns-error-messages condition more)
|
||||
(exit #f))
|
||||
(lambda ()
|
||||
(let* ((ip-string (ip-string->in-addr name))
|
||||
(question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
|
||||
(make-octet-query-message (random 256) ip-string type 'in)
|
||||
(make-octet-query-message (random 256) name type 'in)))
|
||||
(use-cache? #t)
|
||||
(protocol 'udp)
|
||||
(nameserver (check-args args))
|
||||
(check-answer (lambda (dns-msg) #t))
|
||||
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
|
||||
(answers (message:answers (dns-message:reply dns-msg))))
|
||||
(if (not (null? answers))
|
||||
(for-each (lambda (x) (show-dns-message x)(newline)) answers)
|
||||
(display "no answers received - but resolved information in other sections.\n"))
|
||||
dns-msg))))))
|
||||
|
||||
|
||||
|
||||
;; looks up a hostname, returns an ip.
|
||||
;; (dns-lookup-name <name> [nameserver])
|
||||
(define (dns-lookup-name name . args)
|
||||
(let* ((ip-string (ip-string->in-addr name))
|
||||
(question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
|
||||
(error "dns-lookup-name: no valid hostname, suppose it is an ip")
|
||||
(make-octet-query-message (random 256) name 'a 'in)))
|
||||
(use-cache? #t)
|
||||
(protocol 'udp)
|
||||
(nameserver (check-args args))
|
||||
(check-answer (lambda (dns-msg)
|
||||
(let* ((reply (dns-message:reply dns-msg))
|
||||
(answers (message:answers reply)))
|
||||
(not (null? (filter-type answers 'a))))))
|
||||
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
|
||||
(answers (filter-type (message:answers (dns-message:reply dns-msg)) 'a)))
|
||||
(rr-data-a:ip (rr:data (car answers)))))
|
||||
(call-with-current-continuation
|
||||
(lambda (exit)
|
||||
(with-handler
|
||||
(lambda (condition more)
|
||||
(dns-error-messages condition more)
|
||||
(exit #f))
|
||||
(lambda ()
|
||||
(let* ((ip-string (ip-string->in-addr name))
|
||||
(question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
|
||||
(signal 'not-a-hostname)
|
||||
(make-octet-query-message (random 256) name 'a 'in)))
|
||||
(use-cache? #t)
|
||||
(protocol 'udp)
|
||||
(nameserver (check-args args))
|
||||
(check-answer (lambda (dns-msg)
|
||||
(let* ((reply (dns-message:reply dns-msg))
|
||||
(answers (message:answers reply)))
|
||||
(not (null? (filter-type answers 'a))))))
|
||||
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
|
||||
(answers (filter-type (message:answers (dns-message:reply dns-msg)) 'a)))
|
||||
(rr-data-a:ip (rr:data (car answers)))))))))
|
||||
|
||||
|
||||
;; looks up an ip, returns a hostname
|
||||
;; (dns-inverse-lookup <name> [nameserver])
|
||||
(define (dns-inverse-lookup ip . args)
|
||||
(let* ((ip-string (ip-string->in-addr ip))
|
||||
(question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
|
||||
(make-octet-query-message (random 256) ip-string 'ptr 'in)
|
||||
(error "dns-inverse-lookup: no valid ip")))
|
||||
(use-cache? #t)
|
||||
(protocol 'udp)
|
||||
(nameserver (check-args args))
|
||||
(check-answer (lambda (dns-msg)
|
||||
(let* ((reply (dns-message:reply dns-msg))
|
||||
(answers (message:answers reply)))
|
||||
(not (null? (filter-type answers 'ptr))))))
|
||||
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
|
||||
(answers (filter-type (message:answers (dns-message:reply dns-msg)) 'ptr)))
|
||||
(rr-data-ptr:name (rr:data (car answers)))))
|
||||
(call-with-current-continuation
|
||||
(lambda (exit)
|
||||
(with-handler
|
||||
(lambda (condition more)
|
||||
(dns-error-messages condition more)
|
||||
(exit #f))
|
||||
(lambda ()
|
||||
(let* ((ip-string (ip-string->in-addr ip))
|
||||
(question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
|
||||
(make-octet-query-message (random 256) ip-string 'ptr 'in)
|
||||
(signal 'not-a-ip)))
|
||||
(use-cache? #t)
|
||||
(protocol 'udp)
|
||||
(nameserver (check-args args))
|
||||
(check-answer (lambda (dns-msg)
|
||||
(let* ((reply (dns-message:reply dns-msg))
|
||||
(answers (message:answers reply)))
|
||||
(not (null? (filter-type answers 'ptr))))))
|
||||
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
|
||||
(answers (filter-type (message:answers (dns-message:reply dns-msg)) 'ptr)))
|
||||
(rr-data-ptr:name (rr:data (car answers)))))))))
|
||||
|
||||
(define dns-lookup-ip dns-inverse-lookup)
|
||||
|
||||
|
|
@ -942,27 +1041,34 @@
|
|||
;; returns a list of nameservers
|
||||
;; (dns-lookup-nameserver <name> [nameserver])
|
||||
(define (dns-lookup-nameserver name . args)
|
||||
(let* ((ip-string (ip-string->in-addr name))
|
||||
(question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
|
||||
(error "dns-lookup-name: no valid hostname, suppose it is an ip")
|
||||
(make-octet-query-message (random 256) name 'ns 'in)))
|
||||
(use-cache? #t)
|
||||
(protocol 'udp)
|
||||
(nameserver (check-args args))
|
||||
(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 'soa)))
|
||||
(not (null? (filter-type answers 'ns)))))))
|
||||
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
|
||||
(reply (dns-message:reply dns-msg))
|
||||
(soa (filter-type (message:nameservers reply) 'soa))
|
||||
(nss (filter-type (message:answers reply) 'ns))
|
||||
(add (filter-type (message:additionals reply) '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))))
|
||||
(call-with-current-continuation
|
||||
(lambda (exit)
|
||||
(with-handler
|
||||
(lambda (condition more)
|
||||
(dns-error-messages condition more)
|
||||
(exit #f))
|
||||
(lambda ()
|
||||
(let* ((ip-string (ip-string->in-addr name))
|
||||
(question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
|
||||
(signal 'not-a-hostname)
|
||||
(make-octet-query-message (random 256) name 'ns 'in)))
|
||||
(use-cache? #t)
|
||||
(protocol 'udp)
|
||||
(nameserver (check-args args))
|
||||
(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 'soa)))
|
||||
(not (null? (filter-type answers 'ns)))))))
|
||||
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
|
||||
(reply (dns-message:reply dns-msg))
|
||||
(soa (filter-type (message:nameservers reply) 'soa))
|
||||
(nss (filter-type (message:answers reply) 'ns))
|
||||
(add (filter-type (message:additionals reply) '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))))))))
|
||||
|
||||
|
||||
;; looks up a mail-exchanger for a hostname.
|
||||
|
|
@ -971,36 +1077,43 @@
|
|||
;; implementation based on RFC2821
|
||||
;; (dns-lookup-mail-exchanger <name> [nameserver])
|
||||
(define (dns-lookup-mail-exchanger name . args)
|
||||
(let* ((ip-string (ip-string->in-addr name))
|
||||
(question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
|
||||
(error "dns-lookup-name: no valid hostname, suppose it is an ip")
|
||||
(make-octet-query-message (random 256) name 'mx 'in)))
|
||||
(use-cache? #t)
|
||||
(protocol 'tcp)
|
||||
(nameserver (check-args args))
|
||||
(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 'mx)))
|
||||
(not (null? (filter-type answers 'cname)))
|
||||
(not (null? (filter-type answers 'a)))))))
|
||||
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
|
||||
(reply (dns-message:reply dns-msg))
|
||||
(mx (filter-type (message:answers reply) 'mx))
|
||||
(soa (filter-type (message:nameservers reply) 'soa))
|
||||
(cname (filter-type (message:answers reply) 'cname))
|
||||
(a (filter-type (message:answers reply) 'a)))
|
||||
(call-with-current-continuation
|
||||
(lambda (exit)
|
||||
(with-handler
|
||||
(lambda (condition more)
|
||||
(dns-error-messages condition more)
|
||||
(exit #f))
|
||||
(lambda ()
|
||||
(let* ((ip-string (ip-string->in-addr name))
|
||||
(question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
|
||||
(signal 'not-a-hostname)
|
||||
(make-octet-query-message (random 256) name 'mx 'in)))
|
||||
(use-cache? #t)
|
||||
(protocol 'tcp)
|
||||
(nameserver (check-args args))
|
||||
(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 'mx)))
|
||||
(not (null? (filter-type answers 'cname)))
|
||||
(not (null? (filter-type answers 'a)))))))
|
||||
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
|
||||
(reply (dns-message:reply dns-msg))
|
||||
(mx (filter-type (message:answers reply) 'mx))
|
||||
(soa (filter-type (message:nameservers reply) 'soa))
|
||||
(cname (filter-type (message:answers reply) 'cname))
|
||||
(a (filter-type (message:answers reply) '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 (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))))))))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -1010,99 +1123,99 @@
|
|||
(let* ((d
|
||||
(lambda (n s1 s2)
|
||||
(letrec ((loop (lambda (n)
|
||||
(if (zero? n)
|
||||
""
|
||||
(string-append " " (loop (- n 1)))))))
|
||||
(if (zero? n)
|
||||
""
|
||||
(string-append " " (loop (- n 1)))))))
|
||||
(display (loop n))
|
||||
(display s1)
|
||||
(display ": ")
|
||||
(display s2)
|
||||
(newline)))))
|
||||
|
||||
(cond
|
||||
((dns-message? dns-msg)
|
||||
(begin
|
||||
(d 0 "DNS-MESSAGE" "")
|
||||
(d 1 "QUERY" "")(show-dns-message (dns-message:query dns-msg))(newline)
|
||||
(d 1 "REPLY" "")(show-dns-message (dns-message:reply dns-msg))(newline)
|
||||
(d 1 "CACHE?" (if (dns-message:cache? dns-msg)
|
||||
"found in cache"
|
||||
"not found in cache"))
|
||||
(d 1 "PROTOCOL" (let ((protocol (dns-message:protocol dns-msg)))
|
||||
(cond
|
||||
((eq? protocol 'tcp) "TCP")
|
||||
((eq? protocol 'udp) "UDP"))))
|
||||
(d 1 "TRIED-NAMESERVERS" (if (> (length (dns-message:tried-nameservers dns-msg)) 1)
|
||||
(begin
|
||||
(display " had perform recursion: ")
|
||||
(dns-message:tried-nameservers dns-msg))
|
||||
(begin
|
||||
(display " without recursion: ")
|
||||
(dns-message:tried-nameservers dns-msg))))))
|
||||
((message? dns-msg)
|
||||
(begin
|
||||
(d 2 "MESSAGE" "")
|
||||
(d 3 "Header " "")(show-dns-message (message:header dns-msg))
|
||||
(d 3 "Questions " "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:questions dns-msg))
|
||||
(d 3 "Answers " "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:answers dns-msg))
|
||||
(d 3 "Nameservers" "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:nameservers dns-msg))
|
||||
(d 3 "Additionals" "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:additionals dns-msg))))
|
||||
((header? dns-msg)
|
||||
(begin
|
||||
(d 4 "id" (header:id dns-msg))
|
||||
(d 4 "Flags" "")(show-dns-message (header:flags dns-msg))
|
||||
(d 4 "question-count " (header:qdc dns-msg))
|
||||
(d 4 "answer-count " (header:anc dns-msg))
|
||||
(d 4 "nameserver-count " (header:nsc dns-msg))
|
||||
(d 4 "additional-count " (header:arc dns-msg))))
|
||||
((flags? dns-msg)
|
||||
(begin
|
||||
(d 5 "querytype" (flags:querytype dns-msg))
|
||||
(d 5 "opcode" (flags:opcode dns-msg))
|
||||
(d 5 "auth" (flags:auth dns-msg))
|
||||
(d 5 "trunc" (flags:trunc dns-msg))
|
||||
(d 5 "recursiondesired" (flags:recursiondesired dns-msg))
|
||||
(d 5 "recursionavailable" (flags:recursionavailable dns-msg))
|
||||
(d 5 "z" (flags:z dns-msg))
|
||||
(d 5 "rcode" (flags:rcode dns-msg))))
|
||||
((question? dns-msg)
|
||||
(begin
|
||||
(d 4 "name " (question:name dns-msg))
|
||||
(d 4 "type " (question:type dns-msg))
|
||||
(d 4 "class" (question:class dns-msg))))
|
||||
((rr? dns-msg)
|
||||
(begin
|
||||
(d 4 "name " (rr:name dns-msg))
|
||||
(d 4 "type " (rr:type dns-msg))
|
||||
(d 4 "class" (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)
|
||||
(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)
|
||||
(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))))
|
||||
;; ###
|
||||
((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)))
|
||||
|
||||
)))
|
||||
|
||||
(cond
|
||||
((dns-message? dns-msg)
|
||||
(begin
|
||||
(d 0 "DNS-MESSAGE" "")
|
||||
(d 1 "QUERY" "")(show-dns-message (dns-message:query dns-msg))(newline)
|
||||
(d 1 "REPLY" "")(show-dns-message (dns-message:reply dns-msg))(newline)
|
||||
(d 1 "CACHE?" (if (dns-message:cache? dns-msg)
|
||||
"found in cache"
|
||||
"not found in cache"))
|
||||
(d 1 "PROTOCOL" (let ((protocol (dns-message:protocol dns-msg)))
|
||||
(cond
|
||||
((eq? protocol 'tcp) "TCP")
|
||||
((eq? protocol 'udp) "UDP"))))
|
||||
(d 1 "TRIED-NAMESERVERS" (if (> (length (dns-message:tried-nameservers dns-msg)) 1)
|
||||
(begin
|
||||
(display " had perform recursion: ")
|
||||
(dns-message:tried-nameservers dns-msg))
|
||||
(begin
|
||||
(display " without recursion: ")
|
||||
(dns-message:tried-nameservers dns-msg))))))
|
||||
((message? dns-msg)
|
||||
(begin
|
||||
(d 2 "MESSAGE" "")
|
||||
(d 3 "Header " "")(show-dns-message (message:header dns-msg))
|
||||
(d 3 "Questions " "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:questions dns-msg))
|
||||
(d 3 "Answers " "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:answers dns-msg))
|
||||
(d 3 "Nameservers" "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:nameservers dns-msg))
|
||||
(d 3 "Additionals" "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:additionals dns-msg))))
|
||||
((header? dns-msg)
|
||||
(begin
|
||||
(d 4 "id" (header:id dns-msg))
|
||||
(d 4 "Flags" "")(show-dns-message (header:flags dns-msg))
|
||||
(d 4 "question-count " (header:qdc dns-msg))
|
||||
(d 4 "answer-count " (header:anc dns-msg))
|
||||
(d 4 "nameserver-count " (header:nsc dns-msg))
|
||||
(d 4 "additional-count " (header:arc dns-msg))))
|
||||
((flags? dns-msg)
|
||||
(begin
|
||||
(d 5 "querytype" (flags:querytype dns-msg))
|
||||
(d 5 "opcode" (flags:opcode dns-msg))
|
||||
(d 5 "auth" (flags:auth dns-msg))
|
||||
(d 5 "trunc" (flags:trunc dns-msg))
|
||||
(d 5 "recursiondesired" (flags:recursiondesired dns-msg))
|
||||
(d 5 "recursionavailable" (flags:recursionavailable dns-msg))
|
||||
(d 5 "z" (flags:z dns-msg))
|
||||
(d 5 "rcode" (flags:rcode dns-msg))))
|
||||
((question? dns-msg)
|
||||
(begin
|
||||
(d 4 "name " (question:name dns-msg))
|
||||
(d 4 "type " (question:type dns-msg))
|
||||
(d 4 "class" (question:class dns-msg))))
|
||||
((rr? dns-msg)
|
||||
(begin
|
||||
(d 4 "name " (rr:name dns-msg))
|
||||
(d 4 "type " (rr:type dns-msg))
|
||||
(d 4 "class" (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)
|
||||
(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)
|
||||
(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))))
|
||||
;; ###
|
||||
((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)))
|
||||
|
||||
)))
|
||||
|
|
|
|||
|
|
@ -485,6 +485,8 @@
|
|||
defrec-package
|
||||
random
|
||||
queues
|
||||
conditions
|
||||
handle
|
||||
sort
|
||||
threads
|
||||
locks)
|
||||
|
|
|
|||
Loading…
Reference in New Issue