From 5f3582d017b8c7904f4126b98fd48425bdde1972 Mon Sep 17 00:00:00 2001 From: mainzelm Date: Mon, 25 Nov 2002 16:47:00 +0000 Subject: [PATCH] + Reworked condition signalling + TCP almost works + Cleanup --- scheme/lib/dns.scm | 563 +++++++++++++++++++++------------------------ 1 file changed, 258 insertions(+), 305 deletions(-) diff --git a/scheme/lib/dns.scm b/scheme/lib/dns.scm index ab0bcbd..283a97d 100644 --- a/scheme/lib/dns.scm +++ b/scheme/lib/dns.scm @@ -113,6 +113,9 @@ (define-condition-type 'no-nameservers '(dns-error)) (define no-nameservers? (condition-predicate 'no-nameservers)) +(define-condition-type 'bad-nameserver '(dns-error)) +(define bad-nameserver? (condition-predicate 'bad-nameserver)) + (define-condition-type 'not-a-hostname '(dns-error)) (define not-a-hostname? (condition-predicate 'not-a-hostname)) @@ -139,38 +142,42 @@ (define-condition-type 'dns-refused '(dns-server-error)) (define dns-refused? (condition-predicate 'dns-refused)) +(define (dns-error condition . stuff) + (apply signal condition (dns-error->string condition) stuff)) -;; called by the error-handlers, prints out error descriptions -(define (dns-error-messages condition more) - (display "dns-error: ") - (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)))) +(define (dns-error->string condition) + (string-append + "dns-error: " + (case condition + ((invalid-type) + "make-octet-question: invalid DNS query type") + ((invalid-class) + "make-octet-question: invalid DNS query class") + ((parse-error) + "parse: error parsing server message") + ((unexpected-eof-from-server) + "send-receive-message: unexpected EOF from server") + ((bad-address) + "dns-get-information: bad address (in combination with query type)") + ((no-nameservers) + "dns-find-nameserver: no nameservers found in /etc/resolv.conf") + ((bad-nameserver) + "send-receive-message: nameserver refused connection") + ((not-a-hostname) + "no hostname given") + ((not-a-ip) + "no ip given") + ((dns-format-error) + "error from server: (1) format error") + ((dns-server-failure) + "error from server: (2) server failure") + ((dns-name-error) + "error from server: (3) name error") + ((dns-not-implemented) + "error from server: (4) not implemented") + ((dns-refused) + "error from server: (5) refused") + (else (error "Unknown dns-error" condition))))) ;;; -- globals and types @@ -457,9 +464,9 @@ (define (make-octet-question name type class) (if *debug* (display "make-octet-question\n")) (if (not (assoc type types)) - (signal 'invalid-type)) + (dns-error 'invalid-type)) (if (not (assoc class classes)) - (signal 'invalid-class)) + (dns-error 'invalid-class)) (let* ((qname (name->octets name)) (qtype (number->octet-pair (cadr (assoc type types)))) @@ -778,7 +785,7 @@ (lambda () (parse-n parse-rr start message (header:arc header))) (lambda (ars start) (if (not (null? start)) - (signal 'parse-error)) + (dns-error 'parse-error)) (make-message header qds ans nss ars message))))))))))) @@ -796,86 +803,114 @@ (let ((rcode (flags:rcode (parse-flags reply)))) (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)))))) + ((1) (dns-error 'dns-format-error)) + ((2) (dns-error 'dns-server-failure)) + ((3) (dns-error 'dns-name-error)) + ((4) (dns-error 'dns-not-implemented)) + ((5) (dns-error 'dns-refused)))))) ;; #t if message is truncated (could happen via UDP) (define (truncated? reply) (let ((trunc (flags:trunc (parse-flags reply)))) (= trunc 1))) - ;; connects to nameserver and sends and receives messages. returns the reply. ;; here: via TCP -(define (send-receive-message-tcp nameserver question) - (error "tcp doesn't work yet") - (if *debug* (display "send-receive-message\n")) - (let* ((query question) - (reply - (let ((socket (socket-connect protocol-family/internet - socket-type/stream - nameserver 53))) - (let ((r (socket:inport socket)) - (w (socket:outport socket))) - (dynamic-wind - (lambda () - 'nothing-to-be-done-before) - (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))) - (signal 'unexpected-eof-from-server)) - (string->list s))))) - (lambda () - (close-socket socket))))))) +(define (send-receive-message-tcp nameservers query) + (receive (reply hit-ns other-nss) + (let ((sockets (map (lambda (nameserver) + (let ((sock (create-socket protocol-family/internet + socket-type/stream)) + (addr (internet-address->socket-address + nameserver 53))) + ;; we ignore the return value and select + ;; unconditionally later + (connect-socket-no-wait sock addr) + sock)) + nameservers))) + (let* ((ws (map socket:outport sockets)) + (wsv (list->vector ws)) + (wport-nameserver-alist (map cons ws nameservers)) + (wport-socket-alist (map cons ws sockets))) + (dynamic-wind + (lambda () #f) + (lambda () + (receive (ignore-r write-ready ignore-e) + ;;; TODO this should circumvent the buffer + (select '#() wsv '#()) + (let* ((w (vector-ref write-ready 0)) + (hit-ns (cdr (assoc w wport-nameserver-alist))) + (sock (cdr (assoc w wport-socket-alist)))) + (if (not (connect-socket-successful? sock)) + (dns-error 'bad-nameserver hit-ns)) + (let ((query-string (list->string query)) + (r (socket:inport sock))) + (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))) + (dns-error 'unexpected-eof-from-server)) + (values (string->list s) + hit-ns + (delete hit-ns nameservers))))))))) + (lambda () + (for-each close-socket sockets))))) (reply-acceptable? reply query) - (parse reply))) + (values (parse reply) + hit-ns + other-nss))) ;; here: via UDP -(define (send-receive-message-udp nameservers question) +(define (send-receive-message-udp nameservers query) (if *debug* (display "send-receive-message\n")) - (let* ((query question) - (reply - (let ((sockets (map (lambda (nameserver) - (socket-connect protocol-family/internet - socket-type/datagram - nameserver 53)) - nameservers))) - (let ((rs (map socket:inport sockets)) - (ws (map socket:outport sockets))) - (dynamic-wind - (lambda () - 'nothing-to-be-done-before) - (lambda () - (let ((query-string (list->string query)) - (rsv (list->vector rs))) - (for-each (lambda (w) (display query-string w)) ws) - (for-each force-output ws) - (receive (read-ready ignore-w ignore-e) - (select rsv '#() '#()) - (let ((r (vector-ref read-ready 0))) - (string->list (read-string/partial 512 r)))))) ; 512 is the maximum udp-message size - (lambda () - (for-each close-socket sockets))))))) - (reply-acceptable? reply query) - (if (truncated? reply) - (send-receive-message-tcp nameservers question) - (values (parse reply) - (car nameservers); kludge - '(kludge))))) + (receive (reply hit-ns other-nss) + (let ((sockets (map (lambda (nameserver) + (let ((sock (create-socket protocol-family/internet + socket-type/datagram)) + (addr (internet-address->socket-address + nameserver 53))) + (connect-socket sock addr) + sock)) + nameservers))) + (let ((rs (map socket:inport sockets)) + (ws (map socket:outport sockets))) + (dynamic-wind + (lambda () + 'nothing-to-be-done-before) + (lambda () + (let ((query-string (list->string query)) + (rsv (list->vector rs)) + (rport-nameserver-alist (map cons rs nameservers)) + (rport-socket-alist (map cons rs sockets))) + (for-each (lambda (w) (display query-string w)) ws) + (for-each force-output ws) + (receive (read-ready ignore-w ignore-e) + ;;; TODO this should circumvent the buffer + (select rsv '#() '#()) + (let* ((r (vector-ref read-ready 0)) + (hit-ns (cdr (assoc r rport-nameserver-alist)))) + (if (not (connect-socket-successful? (cdr (assoc r rport-socket-alist)))) + (dns-error 'bad-nameserver hit-ns)) + ;;; 512 is the maximum udp-message size: + (values (string->list (read-string/partial 512 r)) + hit-ns + (delete hit-ns nameservers)))))) + (lambda () + (for-each close-socket sockets))))) + (reply-acceptable? reply query) + (if (truncated? reply) + (send-receive-message-tcp nameservers query) + (values (parse reply) + hit-ns + other-nss)))) ;;; -- cache -;; creates the cache, an emoty string-table +;; creates the cache, an empty string-table (define cache (make-string-table)) ;; resets the cache @@ -932,7 +967,7 @@ (values (make-dns-message (parse question) dns-msg #f protocol (reverse tried)) hit-ns - nss-with-no-reply)))) + nss-with-no-reply))) (define (dns-query-with-cache question protocol nameservers tried) (let ((qds (message:questions (parse question)))) @@ -940,7 +975,8 @@ (if (null? ns) (receive (reply-msg hit-ns nss-with-no-reply) (send-receive-message nameservers question protocol) - (update-cache! (make-key qds hit-ns) (make-cache reply-msg (find-shortest-ttl reply-msg) (time))) + (update-cache! (make-key qds hit-ns) + (make-cache reply-msg (find-shortest-ttl reply-msg) (time))) ;; returns new retrieved data and updates cache (values (make-dns-message (parse question) reply-msg #f protocol (reverse tried)) hit-ns @@ -974,19 +1010,20 @@ ;; dns-get-information implements the resovler-side recursion. ;; it returns a dns-message (define (dns-get-information question use-cache? protocol nameservers check-answer) - (if *debug* (display "dns-get-information\n")) (let lp ((tried '()) (nss nameservers)) (if (null? nss) - (signal 'bad-address) + (dns-error 'bad-address) (receive (dns-msg hit-ns nss-with-no-reply) (dns-query/cache question use-cache? protocol nss tried) - (if *debug* (display "dns-get-information:check-success\n")) (if (check-answer dns-msg) dns-msg - (let ((auth? (not (zero? (flags:auth (header:flags - (message:header (dns-message:reply dns-msg)))))))) + (let ((auth? (not + (zero? + (flags:auth (header:flags + (message:header + (dns-message:reply dns-msg)))))))) (if auth? - (signal 'bad-address) + (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 @@ -1006,9 +1043,11 @@ (cond ((eof-object? l) (if (null? ns) - (signal 'no-nameservers) + (dns-error 'no-nameservers) ns)) - ((regexp-search (posix-string->regexp "nameserver[ ]+([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+)") l) + ((regexp-search + (posix-string->regexp + "nameserver[ ]+([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+)") l) => (lambda (match) (loop (append ns (list (ip-string->address32 (match:substring match 1))))))) (else @@ -1019,240 +1058,152 @@ (define (dns-find-nameserver) (let ((ns (dns-find-nameserver-list))) (if (null? ns) - (signal 'no-nameservers) + (dns-error 'no-nameservers) (car ns)))) - -;; concurrent-lookup -;; starts a -lookup to all nameservers in (dns-find-nameserver-list) -(define (concurrent-lookup lookup name nameservers) - (let* ((return 'no-value) - (lock (make-lock)) - (queue (make-queue)) - (nameserver-list (map (lambda (nameserver) - (if (address32? nameserver) - (address32->ip-string nameserver) - nameserver)) - nameservers))) - - (obtain-lock lock) - - (spawn (lambda () - (for-each (lambda (nameserver) - (spawn - (lambda () - ;(display "query sent to ")(display nameserver)(display " \n") - (let* ((result (apply lookup (list name nameserver)))) - (enqueue! queue result) - ;(display "received reply from ")(display nameserver)(display ": ")(display result)(newline) - (release-lock lock))))) - nameserver-list))) - - (obtain-lock lock) - (let loop ((count (length nameserver-list))) - (if (not (queue-empty? queue)) - (let ((result (dequeue! queue))) - (if (or result (= 1 (length nameserver-list))) - result - (loop (- count 1)))))))) - -;; checks the arguments of the simple lookup functions. +;; checks 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) (if (null? args) - (address32->ip-string (dns-find-nameserver) ) - (let ((nameserver (car args))) - (cond - ((ip-string? nameserver) nameserver) - ((address32? nameserver) (address32->ip-string nameserver)) - (else (address32->ip-string (dns-lookup-name nameserver))))))) - + (dns-find-nameserver-list) + (map (lambda (nameserver) + (cond + ((address32? nameserver) nameserver) + ((ip-string? nameserver) (ip-string->address32 nameserver)) + (else (dns-lookup-name nameserver (dns-find-nameserver-list))))) + (car args)))) ;; dns-lookup with more options than dns-lookup-* -;; optional: nameserver could be passed to the function. -(define (dns-lookup name type . args) - (call-with-current-continuation - (lambda (exit) - (with-handler - (lambda (condition more) - (dns-error-messages condition more) - (exit #f)) - (lambda () - (let* ((ip-string (if (address32? name) +(define (dns-lookup name type . nameservers) + (let* ((maybe-ip-string (if (address32? name) (ip-string->in-addr (address32->ip-string name)) (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)))))) + (question (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address + (make-octet-query-message (random 256) maybe-ip-string type 'in) + (make-octet-query-message (random 256) name type 'in))) + (use-cache? #t) + (protocol 'udp) + (nameservers (check-args nameservers)) + (check-answer (lambda (dns-msg) #t)) + (dns-msg (dns-get-information question use-cache? protocol nameservers check-answer)) + (answers (message:answers (dns-message:reply dns-msg)))) + (if (not (null? answers)) + (for-each (lambda (x) (show-dns-message x)(newline)) answers) + ;;; TODO remove display + (display "no answers received - but resolved information in other sections.\n")) + dns-msg)) -;; returns a lookup-function with concurrent-flag -(define (make-lookup-function simple-lookup-function) - (lambda (name . args) - (if (null? args) - (simple-lookup-function name) - (if (list? (car args)) - (concurrent-lookup simple-lookup-function name (car args)) - (simple-lookup-function name (car args)))))) - ;; looks up a hostname, returns an ip. ;; (dns-lookup-name nameservers) -(define (dns-simple-lookup-name name nameservers) - (call-with-current-continuation - (lambda (exit) - (with-handler - (lambda (condition more) - (dns-error-messages condition more) - (exit #f)) - (lambda () - (let* ((ip-string (if (address32? name) +(define (dns-lookup-name name . nameservers) + (let* ((maybe-ip-string (if (address32? name) (ip-string->in-addr (address32->ip-string name)) (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) - (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 nameservers check-answer)) - (answers (filter-type (message:answers (dns-message:reply dns-msg)) 'a))) - (rr-data-a:ip (rr:data (car answers))))))))) - -(define dns-lookup-name (make-lookup-function dns-simple-lookup-name)) + (question (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address + (dns-error 'not-a-hostname) + (make-octet-query-message (random 256) name 'a '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 'a)))))) + (dns-msg (dns-get-information question use-cache? protocol nameservers 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 [nameserver]) -(define (dns-simple-lookup-ip ip . args) - (call-with-current-continuation - (lambda (exit) - (with-handler - (lambda (condition more) - (dns-error-messages condition more) - (exit #f)) - (lambda () - (let* ((ip-string (if (address32? ip) +(define (dns-lookup-ip ip . nameservers) + (let* ((maybe-ip-string (if (address32? ip) (ip-string->in-addr (address32->ip-string ip)) (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 (make-lookup-function dns-simple-lookup-ip)) + (question (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address + (make-octet-query-message (random 256) maybe-ip-string 'ptr '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 'ptr)))))) + (dns-msg (dns-get-information question use-cache? protocol nameservers check-answer)) + (answers (filter-type (message:answers (dns-message:reply dns-msg)) 'ptr))) + (rr-data-ptr:name (rr:data (car answers))))) (define dns-inverse-lookup dns-lookup-ip) - ;; looks up an authoritative nameserver for a hostname ;; returns a list of nameservers ;; (dns-lookup-nameserver [nameserver]) -(define (dns-simple-lookup-nameserver name . args) - (call-with-current-continuation - (lambda (exit) - (with-handler - (lambda (condition more) - (dns-error-messages condition more) - (exit #f)) - (lambda () - (let* ((ip-string (if (address32? name) +(define (dns-lookup-nameserver name . nameservers) + (let* ((maybe-ip-string (if (address32? name) (ip-string->in-addr (address32->ip-string name)) (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)))))))) - -(define dns-lookup-nameserver (make-lookup-function dns-simple-lookup-nameserver)) - + (question (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address + (dns-error 'not-a-hostname) + (make-octet-query-message (random 256) name 'ns '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 'soa))) + (not (null? (filter-type answers 'ns))))))) + (dns-msg (dns-get-information question use-cache? protocol nameservers 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. ;; returns a list of mail-exchanger, sorted by their preference ;; if there are no mx-records in the answer-section, ;; implementation based on RFC2821 ;; (dns-lookup-mail-exchanger [nameserver]) -(define (dns-simple-lookup-mail-exchanger name . args) - (call-with-current-continuation - (lambda (exit) - (with-handler - (lambda (condition more) - (dns-error-messages condition more) - (exit #f)) - (lambda () - (let* ((ip-string (if (address32? name) - (ip-string->in-addr (address32->ip-string name)) - (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)))))))))) - -(define dns-lookup-mail-exchanger (make-lookup-function dns-simple-lookup-mail-exchanger)) +(define (dns-lookup-mail-exchanger name . nameservers) + (let* ((ip-string (if (address32? name) + (ip-string->in-addr (address32->ip-string name)) + (ip-string->in-addr name))) + (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address + (dns-error 'not-a-hostname) + (make-octet-query-message (random 256) name 'mx '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 'mx))) + (not (null? (filter-type answers 'cname))) + (not (null? (filter-type answers 'a))))))) + (dns-msg (dns-get-information question use-cache? protocol nameservers 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)))))) ;;; pretty-prints a dns-msg (define (show-dns-message dns-msg) @@ -1381,6 +1332,7 @@ fqdn)))) (dns-lookup-ip ip32))) +;;; TODO THIS USES gethostbyname (define (host-fqdn name-or-socket-address) (if (socket-address? name-or-socket-address) (socket-address->fqdn name-or-socket-address #f) @@ -1390,6 +1342,7 @@ (host-info name-or-socket-address))) #f))) +;;; TODO THIS USES gethostbyname (define (system-fqdn) (internet-address->fqdn (car (host-info:addresses (host-info (system-name)))) #t))