diff --git a/dns.scm b/dns.scm index 616c32c..1cc90c1 100644 --- a/dns.scm +++ b/dns.scm @@ -10,13 +10,9 @@ ; *(wrong: if check-answer is not successfull, bad hostname is returned) ; *solution: error conditions -> if thrown, return #f ; - test, test, test -; - types from newer RFCs (41) -; - UDP: truncation check +; - types from newer RFCs (41, unknown) ; -*error conditions ; -*better interface (found or #f) -; - additional type-a processing: force-ip -; - check-answer for each type -; mx: rfc2821 ; - more documentation ; ; @@ -24,13 +20,21 @@ ; ; (dns-lookup-name [nameserver]) --> ; (dns-lookup-ip [nameserver]) --> -; (dns-lookup-nameserver [nameserver]) --> -; (dns-lookup-mail-exchanger [nameserver]) --> +; (dns-lookup-nameserver [nameserver]) --> +; (dns-lookup-mail-exchanger [nameserver]) --> ; ; (dns-lookup [nameserver]) --> ; (show-dns-message the whole message, human readable ; ; (concurrent-lookup ) +; +; some lookups return a hostname (e.g. mx). +; many applications need instead of a hostname a ip address. +; force-ip and force-ip-list guarantee that a ip address is +; returned. +; +; (force-ip ) --> +; (force-ip-list ) --> @@ -48,7 +52,8 @@ ;; message types (define types - '((a 1) ; a host address + '((unknown 0); types, which are not yet implemented + (a 1) ; a host address (ns 2) ; an authoritative name server (md 3) ; (obsolete) (mf 4) ; (obsolete) @@ -61,7 +66,7 @@ (wks 11) ; a well known service description (ptr 12) ; a domain name pointer (hinfo 13) ; host information - (minfo 14) ; mailbox or mail list information + (minfo 14) ; (experimental) (mx 15) ; mail exchange (txt 16))) ; text strings @@ -79,7 +84,7 @@ (define (cossa i l) (if *debug* (display "cossa\n")) (cond - ((null? l) (error "dns-message: type not implemented: " i)) + ((null? l) 'unknown) ;;(error "dns-message: type not implemented: " i)) ((equal? (cadar l) i) (car l)) (else (cossa i (cdr l))))) @@ -211,6 +216,30 @@ (= count 3) (string-append s "." result "in-addr.arpa"))))))) +;; filters types in a list of rrs +(define (filter-type list type) + (if *debug* (display "ip-string->in-addr\n")) + (filter (lambda (rr) + (eq? (rr:type rr) type)) + list)) + +;; sorts a mx-rr-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)))))) + + +;; returns a IP if available (additonal type-a processing) +(define (force-ip name) + (let loop ((result (dns-lookup-name name))) + (if (ip? result) + result + (loop (dns-lookup-name result))))) + +;; returns a list of IPs (additional type-a processing) +(define (force-ip-list names) + (map (lambda (elem) (force-ip elem)) names)) ;;; -- message constructors: encode to octet-messages @@ -439,10 +468,7 @@ name) ;; ### -;; hinfo not correctly implemented: -;; don't know how the fields in this record, haven't found any example yet -;; try (dns-lookup 'hinfo) with several names, if you find a name -;; which delivers a hinfo-answer, please tell me :-) +;; hinfo not correctly implemented, trying to find examples (define-record rr-data-hinfo data) @@ -612,6 +638,12 @@ ((4) "not implemented") ((5) "refused")))))) +;; #t if message is truncated (could happen via UDP) +(define (truncated? reply) + (let ((trunc (flags:trunc (parse-flags reply)))) + trunc)) + + ;; connects to nameserver and sends and receives messages. returns the reply. ;; here: via TCP (define (send-receive-message-tcp nameserver question) @@ -663,7 +695,9 @@ (lambda () (close-socket socket))))))) (reply-acceptable? reply query) - (parse reply))) + (if (truncated? reply) + (send-receive-message-tcp nameserver question) + (parse reply)))) ;;; -- cache @@ -753,7 +787,7 @@ (if (or auth? (null? nss)) (error "dns-get-information: bad address (in combination with query-type)" (question:name (car (message:questions (parse question))))) - (let* ((ns (and (eq? (rr:type (car nss)) 'a) (ip->string (rr:data (car nss))))) + (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)) (set! tried (cons ns tried))) @@ -811,7 +845,6 @@ (lock (make-lock)) (queue (make-queue)) (nameserver-list (dns-find-nameserver-list))) - (obtain-lock lock) @@ -819,14 +852,13 @@ (for-each (lambda (nameserver) (spawn (lambda () - (display nameserver)(display " started\n") + (display "query sent to ")(display nameserver)(display " \n") (let* ((result (apply lookup (list name nameserver)))) (enqueue! queue result) - (display nameserver)(display " ")(display result)(newline) + (display "received reply from ")(display nameserver)(display ": ")(display result)(newline) (release-lock lock))))) (dns-find-nameserver-list)))) - (display "Consumer started\n") (let loop ((count (length nameserver-list))) (obtain-lock lock) (let ((result (dequeue! queue))) @@ -876,16 +908,12 @@ (use-cache? #t) (protocol 'udp) (nameserver (check-args args)) - (valid-answers (lambda (answer) - (filter (lambda (ans) - (eq? (rr:type ans) 'a)) - answer))) (check-answer (lambda (dns-msg) (let* ((reply (dns-message:reply dns-msg)) (answers (message:answers reply))) - (not (null? (valid-answers answers)))))) + (not (null? (filter-type answers 'a)))))) (dns-msg (dns-get-information question use-cache? protocol nameserver check-answer)) - (answers (valid-answers (message:answers (dns-message:reply dns-msg))))) + (answers (filter-type (message:answers (dns-message:reply dns-msg)) 'a))) (rr-data-a:ip (rr:data (car answers))))) @@ -899,23 +927,19 @@ (use-cache? #t) (protocol 'udp) (nameserver (check-args args)) - (valid-answers (lambda (answers) - (filter (lambda (ans) - (eq? (rr:type ans) 'ptr)) - answers))) (check-answer (lambda (dns-msg) (let* ((reply (dns-message:reply dns-msg)) (answers (message:answers reply))) - (not (null? (valid-answers answers)))))) + (not (null? (filter-type answers 'ptr)))))) (dns-msg (dns-get-information question use-cache? protocol nameserver check-answer)) - (answers (valid-answers (message:answers (dns-message:reply dns-msg))))) + (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) ;; looks up an authoritative nameserver for a hostname -;; returns a nameserver +;; returns a list of nameservers ;; (dns-lookup-nameserver [nameserver]) (define (dns-lookup-nameserver name . args) (let* ((ip-string (ip-string->in-addr name)) @@ -923,28 +947,29 @@ (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 'tcp) + (protocol 'udp) (nameserver (check-args args)) - (valid-nameservers (lambda (nameservers) - (filter (lambda (ns) - (eq? (rr:type ns) 'soa)) - nameservers))) (check-answer (lambda (dns-msg) (let* ((reply (dns-message:reply dns-msg)) + (answers (message:answers reply)) (nameservers (message:nameservers reply))) - (not (null? (valid-nameservers nameservers)))))) + (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)) - (nameservers (valid-nameservers (message:nameservers (dns-message:reply dns-msg))))) - (dns-lookup-name (rr-data-soa:mname (rr:data (car nameservers)))))) - + (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. -;; returns a mail-exchanger +;; returns a list of mail-exchanger, sorted by their preference ;; if there are no mx-records in the answer-section, -;; the rname of the soa-record is returned. +;; implementation based on RFC2821 ;; (dns-lookup-mail-exchanger [nameserver]) -;; ### CHECK RFC2821 (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 @@ -953,36 +978,29 @@ (use-cache? #t) (protocol 'tcp) (nameserver (check-args args)) - (valid-answers (lambda (answers) - (filter (lambda (answer) - (eq? (rr:type answer) 'mx)) - answers))) - (valid-nameservers (lambda (nameservers) - (filter (lambda (ns) - (eq? (rr:type ns) 'soa)) - nameservers))) (check-answer (lambda (dns-msg) (let* ((reply (dns-message:reply dns-msg)) (answers (message:answers reply)) (nameservers (message:nameservers reply))) - (or (not (null? (valid-answers answers))) - (not (null? (valid-nameservers nameservers))))))) + (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)) - (answers (valid-answers (message:answers (dns-message:reply dns-msg)))) - (nameservers (valid-nameservers (message:nameservers (dns-message:reply dns-msg))))) - - (if (null? answers) - (rr-data-soa:rname (rr:data (car nameservers))) - (let loop ((answers (cdr answers)) - (preference (rr-data-mx:preference (rr:data (car answers)))) - (exchanger (rr-data-mx:exchanger (rr:data (car answers))))) - (if (null? answers) - exchanger - (let ((new-preference (rr-data-mx:preference (rr:data (car answers))))) - (if (<= preference new-preference) - (loop (cdr answers) preference exchanger) - (loop (cdr answers) new-preference (rr-data-mx:exchanger (rr:data (car answers))))))))))) + (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)))))) diff --git a/modules.scm b/modules.scm index 61760c4..685fb3f 100644 --- a/modules.scm +++ b/modules.scm @@ -469,6 +469,8 @@ dns-lookup-mail-exchanger concurrent-lookup show-dns-message + force-ip + force-ip-list dns-find-nameserver dns-find-nameserver-list)) @@ -483,6 +485,7 @@ defrec-package random queues + sort threads locks) (files dns))