From 6f9f67f484cfd03b6b32064e7a3b5b33d5ed0233 Mon Sep 17 00:00:00 2001 From: cresh Date: Mon, 15 Apr 2002 14:16:02 +0000 Subject: [PATCH] complete revision of the PLT-dns-resolver. it nearly fully implements the rfc1035: - resolver-side recursion - cache - following types: a, ns, cname, hinfo, mx, ptr, soa, txt - in-addr.arpa (get hostname by ip) each dns-lookup returns a dns-message record. --- dns.scm | 826 ++++++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 627 insertions(+), 199 deletions(-) diff --git a/dns.scm b/dns.scm index a9b5963..db7459b 100644 --- a/dns.scm +++ b/dns.scm @@ -1,100 +1,317 @@ -;; open string-table big-util(?) ascii format signals random +; +; dns.scm +; +; Implementation of the RFC1035 +; domain names - implementation and specification +; based on the PLT-implementation. +; +; Marcus Crestani +; Copyright (c) 2002 Marcus Crestani +; + +;;; should debug-msgs be printed out? +(define *debug* #f) + + +;;; -- globals and types + +;; off (define *nul* (ascii->char 0)) + +;; on (define *on* (ascii->char 1)) +;; message types (define types - '((a 1) - (ns 2) - (md 3) - (mf 4) - (cname 5) - (soa 6) - (mb 7) - (mg 8) - (mr 9) - (null 10) - (wks 11) - (ptr 12) - (hinfo 13) - (minfo 14) - (mx 15) - (txt 16))) + '((a 1) ; a host address + (ns 2) ; an authoritative name server + (md 3) ; (obsolete) + (mf 4) ; (obsolete) + (cname 5) ; the canonical name for an alias + (soa 6) ; marks the start of a zone of authority + (mb 7) ; (experimental) + (mg 8) ; (experimental) + (mr 9) ; (experimental) + (null 10) ; (experimental) + (wks 11) ; a well known service description + (ptr 12) ; a domain name pointer + (hinfo 13) ; host information + (minfo 14) ; mailbox or mail list information + (mx 15) ; mail exchange + (txt 16))) ; text strings +;; message classes (define classes - '((in 1) - (cs 2) - (ch 3) - (hs 4))) + '((in 1) ; the Internet + (cs 2) ; (obsolete) + (ch 3) ; the CHAOS class + (hs 4))) ; Hesoid + +;;; -- useful stuff + +;; assoc the other way round (define (cossa i l) + (if *debug* (display "cossa\n")) (cond ((null? l) #f) ((equal? (cadar l) i) (car l)) (else (cossa i (cdr l))))) +;; encodes numbers (16bit) to octets (define (number->octet-pair n) + (if *debug* (display "number->octet-pair\n")) (list (ascii->char (arithmetic-shift n -8)) (ascii->char (modulo n 256)))) +;; decodes octets to numbers (16bit) (define (octet-pair->number a b) + (if *debug* (display "octet-pair->number\n")) (+ (arithmetic-shift (char->ascii a) 8) (char->ascii b))) +;; encodes numbers (32bit) to octets, needed for ttl +(define (number->octet-quad n) + (if *debug* (display "number->octet-quad\n")) + (list (ascii->char (arithmetic-shift n -24)) + (ascii->char (modulo (arithmetic-shift n -16) 256)) + (ascii->char (modulo (arithmetic-shift n -8) 256)) + (ascii->char (modulo n 256)))) + +;; decodes octets to numbers, needed for 32bit ttl (define (octet-quad->number a b c d) + (if *debug* (display "octet-quad->number\n")) (+ (arithmetic-shift (char->ascii a) 24) (arithmetic-shift (char->ascii b) 16) (arithmetic-shift (char->ascii c) 8) (char->ascii d))) +;; encodes a domain-name string to octets (define (name->octets s) (define (encode-portion s) (cons (ascii->char (string-length s)) (string->list s))) + (if *debug* (display "name->octets\n")) (let loop ((s s)) (cond - ((string-match "^([^.]*)\\.(.*)" s) + ((regexp-search (posix-string->regexp "^([^.]*)\\.(.*)") s) => (lambda (match) (append (encode-portion (match:substring match 1)) (loop (match:substring match 2))))) (else - (append - (encode-portion s) - (list *nul*)))))) - -(define (make-std-query-header id question-count) - (append - (number->octet-pair id) - (list *on* *nul*) ; Opcode & flags (recusive flag set) - (number->octet-pair question-count) - (number->octet-pair 0) - (number->octet-pair 0) - (number->octet-pair 0))) - -(define (make-query id name type class) - (append - (make-std-query-header id 1) - (name->octets name) - (number->octet-pair (cadr (assoc type types))) - (number->octet-pair (cadr (assoc class classes))))) + (if (= 0 (string-length s)) + (list *nul*) + (append + (encode-portion s) + (list *nul*))))))) +;; for tcp: message has to be tagged with its length (define (add-size-tag m) + (if *debug* (display "add-size-tag\n")) (append (number->octet-pair (length m)) m)) -(define (rr-data rr) - (cadddr (cdr rr))) +;; converts an octeted-ip to an human readable ip-string +(define (ip->string s) + (if *debug* (display "ip->string\n")) + (format #f + "~a.~a.~a.~a" + (char->ascii (list-ref s 0)) + (char->ascii (list-ref s 1)) + (char->ascii (list-ref s 2)) + (char->ascii (list-ref s 3)))) -(define (rr-type rr) - (cadr rr)) +;; converts an ip-string to octets +(define (string->ip s) + (if *debug* (display "string->ip\n")) + (let loop ((s s) + (result '())) + (cond + ((regexp-search (posix-string->regexp "^([^.]*)\\.(.*)") s) + => (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)))))))) -(define (rr-name rr) - (car rr)) +;; calculates a "random" number, needed for message-ids +(define random + (let ((crank (make-random (modulo (time) (- (expt 2 27) 1))))) + (lambda (limit) + (quotient (* (modulo (crank) 314159265) + limit) + 314159265)))) -(define (parse-name start reply) +;; returns a in-addr.arpa name-string or #f (needed to resolver hostname by ip) +(define (ip-string->in-addr s) + (if *debug* (display "ip-string->in-addr\n")) + (let loop ((s s) + (count 0) + (result "")) + (cond + ((regexp-search (posix-string->regexp "^([^.]*)\\.(.*)") s) + => (lambda (match) + (let* ((portion (match:substring match 1)) + (number (string->number portion))) + (if (and number (< number 256)) + (loop (match:substring match 2) (+ count 1) (string-append portion "." result)) + #f)))) + (else + (let ((number (string->number s))) + (and number + (< number 256) + (= count 3) + (string-append s "." result "in-addr.arpa"))))))) + + + +;;; -- message constructors: encode to octet-messages + +;; makes an message header +(define (make-octet-header id qr opcode aa tc rd ra z rcode qdcount ancount nscount arcount) + (if *debug* (display "make-octet-header\n")) + (let* ((header-id (number->octet-pair id)) + (header-flags (list + (ascii->char (+ (arithmetic-shift qr 7) + (arithmetic-shift opcode 3) + (arithmetic-shift aa 2) + (arithmetic-shift tc 1) + rd)) + (ascii->char (+ (arithmetic-shift ra 7) + (arithmetic-shift z 4) + rcode)))) + (header-qdcount (number->octet-pair qdcount)) + (header-ancount (number->octet-pair ancount)) + (header-nscount (number->octet-pair nscount)) + (header-arcount (number->octet-pair arcount))) + (append header-id + header-flags + header-qdcount + header-ancount + header-nscount + header-arcount))) + + +;; a standard query header, usefull for most queries +(define (make-std-octet-query-header id question-count) + (if *debug* (display "make-std-octet-query-header\n")) + (let* ((qr 0) ; querytype: query 0, response 1 + (opcode 0) ; opcode: query 0, iquery 1 (OBSOLETE), status 2 + (aa 0) ; authorative answer (in answers only) + (tc 0) ; truncation (size matters only with UDP) + (rd 1) ; recursion desired: nameserver pursues the query recursivly (optional) + (ra 0) ; recursion available (in answers only) + (z 0) ; future use + (rcode 0) ; response code: error conditions (in answers only) + (qdcount question-count) + (ancount 0) ; answer count (in answers only) + (nscount 0) ; name server resources (in answers only) + (arcount 0)) ; additional records (in answers only) + + (make-octet-header id qr opcode aa tc rd ra z rcode qdcount ancount nscount arcount))) + + +;; makes a question (name, type, class) +(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)) + (if (not (assoc class classes)) + (error "make-octet-question: invalid DNS query class ~a" class)) + + (let* ((qname (name->octets name)) + (qtype (number->octet-pair (cadr (assoc type types)))) + (qclass (number->octet-pair (cadr (assoc class classes))))) + (append qname qtype qclass))) + + +;; makes a query-message (header and question only) +(define (make-octet-query-message id name type class) + (if *debug* (display "make-octet-query-message\n")) + (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) + (if *debug* (display "make-octet-rr\n")) + (let* ((name (name->octets name)) + (type (number->octet-pair (cadr (assoc type types)))) + (class (number->octet-pair (cadr (assoc class classes)))) + (ttl (number->octet-quad ttl)) + (rdlength (number->octet-pair (length rdata))) + (rdata rdata)) + (append name type class ttl rdlength rdata))) + + + +;;; -- parsed message records + +;;; -- dns-message: complete data-structure of an dns-lookup +(define-record dns-message + query + reply + cache? + tried-nameservers) + +;; message +(define-record message + header + questions + answers + nameservers + additionals + source) + +;; header +(define-record header + id + flags + qdc + anc + nsc + arc) + +;; flags +(define-record flags + querytype + opcode + auth + trunc + recursiondesired + recursionavailable + z + rcode) + +;; question +(define-record question + name + type + class) + +;; rr +(define-record rr + name + type + class + ttl + data) + +;; cache +(define-record cache + answer + ttl + time) + +;;; -- message parser + +;; parses a domain-name in an message. returns the name and the rest of the message. +(define (parse-name start message) + (if *debug* (display "parse-name\n")) (let ((v (char->ascii (car start)))) (cond ((zero? v) @@ -108,7 +325,7 @@ (cond ((zero? len) (call-with-values - (lambda () (parse-name start reply)) + (lambda () (parse-name start message)) (lambda (s start) (let ((s0 (list->string (reverse! accum)))) (values (if s @@ -123,13 +340,27 @@ (let ((offset (+ (arithmetic-shift (bitwise-and #x3f v) 8) (char->ascii (cadr start))))) (call-with-values - (lambda () (parse-name (list-tail reply offset) reply)) + (lambda () (parse-name (list-tail message offset) message)) (lambda (s ignore-start) (values s (cddr start))))))))) -(define (parse-rr start reply) +;; parses a question in a message. returns the question and the rest of the message. +(define (parse-question start message) + (if *debug* (display "parse-question\n")) (call-with-values - (lambda () (parse-name start reply)) + (lambda () (parse-name start message)) + (lambda (name start) + (let ((type (car (cossa (octet-pair->number (car start) (cadr start)) types))) + (start (cddr start))) + (let ((class (car (cossa (octet-pair->number (car start) (cadr start)) classes))) + (start (cddr start))) + (values (make-question name type class) start)))))) + +;; parses a resourcerecord in a message. returns the rr and the rest of the message. +(define (parse-rr start message) + (if *debug* (display "parse-rr\n")) + (call-with-values + (lambda () (parse-name start message)) (lambda (name start) (let ((type (car (cossa (octet-pair->number (car start) (cadr start)) types))) (start (cddr start))) @@ -140,50 +371,160 @@ (start (cddddr start))) (let ((len (octet-pair->number (car start) (cadr start))) (start (cddr start))) - ; Extract next len bytes for data: + ;; Extract next len bytes of data: (let loop ((len len) (start start) (accum '())) (if (zero? len) - (values (list name type class ttl (reverse! accum)) - start) + (values (make-rr name type class ttl (parse-rr-data type class (reverse! accum) message)) start) (loop (- len 1) (cdr start) (cons (car start) accum))))))))))) -(define (parse-ques start reply) - (call-with-values - (lambda () (parse-name start reply)) - (lambda (name start) - (let ((type (car (cossa (octet-pair->number (car start) (cadr start)) types))) - (start (cddr start))) - (let ((class (car (cossa (octet-pair->number (car start) (cadr start)) classes))) - (start (cddr start))) - (values (list name type class) start)))))) +(define (parse-rr-data type class data message) + (if *debug* (display "parse-rr-data\n")) + (cond + ((eq? type 'a) + (list (ip->string data))) + + ((eq? type 'ns) + (list (call-with-values + (lambda () (parse-name data message)) + (lambda (name rest) name)))) -(define (parse-n parse start reply n) + ((eq? type 'cname) + (list (call-with-values + (lambda () (parse-name data message)) + (lambda (name rest) name)))) + + ((eq? type 'hinfo) + (list (list->string data))) + + ((eq? type 'mx) + (list (octet-pair->number (car data) (cadr data)) + (call-with-values + (lambda ()(parse-name (cddr data) message)) + (lambda (name rest) name)))) + + ((eq? type 'ptr) + (list (call-with-values + (lambda () (parse-name data message)) + (lambda (name rest) name)))) + + ((eq? type 'soa) + (call-with-values + (lambda () (parse-name data message)) + (lambda (mname rest) + (call-with-values + (lambda () (parse-name rest message)) + (lambda (rname rest) + (let ((serial (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest))) + (rest (cddddr rest))) + (let ((refresh (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest))) + (rest (cddddr rest))) + (let ((retry (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest))) + (rest (cddddr rest))) + (let ((expire (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest))) + (rest (cddddr rest))) + (let ((minimum (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest))) + (rest (cddddr rest))) + (list mname rname serial refresh retry expire minimum))))))))))) + + ((eq? type 'txt) + (list (list->string data))) + + ((eq? type 'wks) + (list data)) + + (else (list data)))) + +;; parses n-times a message with parse. returns a list of parse-returns. +(define (parse-n parse start message n) + (if *debug* (display "parse-n\n")) (let loop ((n n) (start start) (accum '())) (if (zero? n) (values (reverse! accum) start) (call-with-values - (lambda () (parse start reply)) + (lambda () (parse start message)) (lambda (rr start) (loop (- n 1) start (cons rr accum))))))) -(define random - (let ((crank (make-random (modulo (time) (- (expt 2 27) 1))))) - (lambda (limit) - (quotient (* (modulo (crank) 314159265) - limit) - 314159265)))) +;; parses a message-headers flags. returns the flags. +(define (parse-flags message) + (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)))) -(define (dns-query nameserver addr type class) - (if (not (assoc type types)) - (error "dns-query: invalid DNS query type ~a" type)) - (if (not (assoc class classes)) - (error "dns-query: invalid DNS query class ~a" class)) - (let* ((query (make-query (random 256) addr type class)) +;; parses a message-header. returns the header. +(define (parse-header message) + (if *debug* (display "parse-header\n")) + (let ((id (octet-pair->number (list-ref message 0) (list-ref message 1))) + (flags (parse-flags message)) + (qd-count (octet-pair->number (list-ref message 4) (list-ref message 5))) + (an-count (octet-pair->number (list-ref message 6) (list-ref message 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) + (if *debug* (display "parse\n")) + (let* ((header (parse-header message)) + (start (list-tail message 12))) + (call-with-values + (lambda () (parse-n parse-question start message (header:qdc header))) + (lambda (qds start) + (call-with-values + (lambda () (parse-n parse-rr start message (header:anc header))) + (lambda (ans start) + (call-with-values + (lambda () (parse-n parse-rr start message (header:nsc header))) + (lambda (nss start) + (call-with-values + (lambda () (parse-n parse-rr start message (header:arc header))) + (lambda (ars start) + (if (not (null? start)) + (error "parse: error parsing server message")) + (make-message header qds ans nss ars message))))))))))) + + + +;;; -- send, receive and validate message + +;; checks if the received reply is valid. returns #t or error-msg. +(define (reply-acceptable? reply query) + (if *debug* (display "reply-acceptable?\n")) + ;; Check correct id + (if (not (and (char=? (car reply) (car query)) + (char=? (cadr reply) (cadr query)))) + (error "send-receive-message: bad reply id from server")) + ;; Check for error code: + (let ((rcode (flags:rcode (parse-flags reply)))) + (if (not (zero? 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")))))) + +;; connects to nameserver and sends and receives messages. returns the reply. +(define (send-receive-message nameserver question) + (if *debug* (display "send-receive-message\n")) + (let* ((query question) (reply (let ((socket (socket-connect protocol-family/internet socket-type/stream @@ -192,7 +533,7 @@ (w (socket:outport socket))) (dynamic-wind (lambda () - 'fick-dich-ins-knie) + 'nothing-to-be-done-before) (lambda () (display (list->string (add-size-tag query)) w) (force-output w) @@ -202,135 +543,97 @@ (let ((len (octet-pair->number a b))) (let ((s (read-string len r))) (if (not (= len (string-length s))) - (error "dns-query: unexpected EOF from server")) + (error "send-receive-message: unexpected EOF from server")) (string->list s))))) (lambda () (close-socket socket))))))) + (reply-acceptable? reply query) + (parse reply))) - ;; First two bytes must match sent message id: - (if (not (and (char=? (car reply) (car query)) - (char=? (cadr reply) (cadr query)))) - (error "dns-query: bad reply id from server")) - - (let ((v0 (caddr reply)) - (v1 (cadddr reply))) - ;; Check for error code: - (let ((rcode (bitwise-and #xf (char->ascii v1)))) - (if (not (zero? rcode)) - (error "dns-query: error from server: ~a" - (case rcode - ((1) "format error") - ((2) "server failure") - ((3) "name error") - ((4) "not implemented") - ((5) "refused"))))) - - (let ((qd-count (octet-pair->number (list-ref reply 4) (list-ref reply 5))) - (an-count (octet-pair->number (list-ref reply 6) (list-ref reply 7))) - (ns-count (octet-pair->number (list-ref reply 8) (list-ref reply 9))) - (ar-count (octet-pair->number (list-ref reply 10) (list-ref reply 11)))) - - (let ((start (list-tail reply 12))) - (call-with-values - (lambda () (parse-n parse-ques start reply qd-count)) - (lambda (qds start) - (call-with-values - (lambda () (parse-n parse-rr start reply an-count)) - (lambda (ans start) - (call-with-values - (lambda () (parse-n parse-rr start reply ns-count)) - (lambda (nss start) - (call-with-values - (lambda () (parse-n parse-rr start reply ar-count)) - (lambda (ars start) - (if (not (null? start)) - (error "dns-query: error parsing server reply")) - (values (positive? (bitwise-and #x4 (char->ascii v0))) - qds ans nss ars reply)))))))))))))) +;;; -- cache +;; creates the cache, an emoty string-table (define cache (make-string-table)) -(define (dns-query/cache nameserver addr type class) - (let ((key (format #f "~a;~a;~a;~a" nameserver addr type class))) - (cond - ((table-ref cache key) - => (lambda (v) - (apply values v))) - (else - (call-with-values - (lambda () (dns-query nameserver addr type class)) - (lambda (auth? qds ans nss ars reply) - (table-set! cache key (list auth? qds ans nss ars reply)) - (values auth? qds ans nss ars reply))))))) -(define (ip->string s) - (format #f - "~a.~a.~a.~a" - (char->ascii (list-ref s 0)) - (char->ascii (list-ref s 1)) - (char->ascii (list-ref s 2)) - (char->ascii (list-ref s 3)))) +;; resets the cache +(define (dns-clear-cache) + (set! cache (make-string-table))) -(define (try-forwarding k nameserver) - (let loop ((nameserver nameserver) - (tried (list nameserver))) - ;; Normally the recursion is done for us, but it's technically optional - (call-with-values - (lambda () (k nameserver)) - (lambda (v ars auth?) - (or v - (and (not auth?) - (let* ((ns (any - (lambda (ar) - (and (eq? (rr-type ar) 'a) - (ip->string (rr-data ar)))) - ars))) - (and ns - (not (member ns tried)) - (loop ns (cons ns tried)))))))))) +;; makes a dns-query. optional cache-check. +;; returns a dns-message with cache-flag and either cache-data or new received data. +(define (dns-query/cache question use-cache? nameserver tried) + (if *debug* (display "dns-query/cache\n")) + (let ((dns-query + (lambda () + (if *debug* (display "dns-query/cache:dns-query\n")) + (make-dns-message (parse question) (send-receive-message nameserver question) #f (reverse tried)))) ; returns new retrieved data + (dns-query-with-cache + (lambda () + (if *debug* (display "dns-query/cache:dns-query-with-cache\n")) + (let* ((qds (message:questions (parse question))) + ;; cache-key relevant data + (name (question:name (car qds))) + (type (question:type (car qds))) + (class (question:class (car qds))) + (key (format #f "~a;~a;~a;~a" nameserver name type class)) + (found-data (table-ref cache key))) + (cond + ((and found-data + ;; checks if cached-data is still valid + (< (time) (+ (cache:time found-data) (cache:ttl found-data)))) + (make-dns-message (parse question) (cache:answer found-data) #t (reverse tried))) ; returns the cached-data + (else + (let ((reply-msg (send-receive-message nameserver question))) + (if *debug* (display "write to cache\n")) + (table-set! cache key (make-cache reply-msg + (if (null? (message:answers reply-msg)) + 0 + (rr:ttl (car (message:answers reply-msg)))) + (time))) + (make-dns-message (parse question) reply-msg #f (reverse tried))))))))) ; returns new retrieved data and updates cache + (if use-cache? + (dns-query-with-cache) + (dns-query)))) -(define (dns-get-address nameserver addr) - (or (try-forwarding - (lambda (nameserver) - (call-with-values - (lambda () (dns-query/cache nameserver addr 'a 'in)) - (lambda (auth? qds ans nss ars reply) - (values (and (positive? (length ans)) - (let ((s (rr-data (car ans)))) - (ip->string s))) - ars auth?)))) - nameserver) - (error "dns-get-address: bad address ~a" addr))) +;; dns and recursion +;; recursion means, if the demanded information is not available from the +;; nameserver, another nameserver (usualy an authority) has to be contacted. +;; normally the recursion is done for us by the nameserver istself, but +;; this feature is technically optional (RFC 1035). +;; dns-get-information implements the resovler-side recursion. +;; it returns a dns-message +(define (dns-get-information question use-cache? nameserver check-answer) + (if *debug* (display "dns-get-information\n")) + (letrec ((tried (list nameserver)) + ;; with every (also unanswerd) requests authoritative nameservers are send back + ;; try-recursive tries to get information from these nameservers + (try-recursive + (lambda (auth? nss) + (if (or auth? (null? nss)) + (error "dns-get-information: bad address ~a" (question:name (car (message:questions (parse question))))) + (let* ((ns (and (eq? (rr:type (car nss)) 'a) (ip->string (rr:data (car nss))))) + (dns-msg (if (and ns + (not (member ns tried)) + (set! tried (cons ns tried))) + (dns-query/cache question use-cache? ns tried) + (try-recursive auth? (cdr nss))))) + (check-success dns-msg))))) + ;; checks if the answer is useful. returns a dns-message. + (check-success + (lambda (dns-msg) + (if *debug* (display "dns-get-information:check-success\n")) + (let ((useful-answer? (check-answer dns-msg))) + (if useful-answer? + dns-msg + (let ((auth? (not (zero? (flags:auth (header:flags (message:header (dns-message:reply dns-msg))))))) + ;; other nameservers names are found in the nameserver-part, + ;; but their ip-adresses are found in the additonal-rrs + (other-nameservers (message:additionals (dns-message:reply dns-msg)))) + (try-recursive auth? other-nameservers))))))) + (check-success (dns-query/cache question use-cache? nameserver tried)))) -(define (dns-get-mail-exchanger nameserver addr) - (or (try-forwarding - (lambda (nameserver) - (call-with-values - (lambda () (dns-query/cache nameserver addr 'mx 'in)) - (lambda (auth? qds ans nss ars reply) - (values (let loop ((ans ans) - (best-pref 99999) ; this is enough - (exchanger #f)) - (cond - ((null? ans) - (or exchanger - ;; Does 'soa mean that the input address is fine? - (and (any? (lambda (ns) - (eq? (rr-type ns) 'soa)) - nss) - addr))) - (else - (let ((d (rr-data (car ans)))) - (let ((pref (octet-pair->number (car d) (cadr d)))) - (if (< pref best-pref) - (call-with-values - (lambda () (parse-name (cddr d) reply)) - (lambda (name start) - (loop (cdr ans) pref name))) - (loop (cdr ans) best-pref exchanger))))))) - ars auth?)))) - nameserver) - (error "dns-get-mail-exchanger: bad address"))) +;; parses the resolv.conf file and returns the first found nameserver (define (dns-find-nameserver) (with-input-from-file "/etc/resolv.conf" (lambda () @@ -339,11 +642,136 @@ (cond ((eof-object? l) #f) - ((string-match "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) (match:substring match 1))) (else (loop)))))))) +(define (dns-lookup name type) + (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) + (nameserver (dns-find-nameserver)) + (check-answer (lambda (dns-msg) (if *debug* (display "check-answer\n")) #t)) +;; ### type-a-queries should provide at least one answer +; (let* ((reply (dns-message:reply dns-msg)) +; (answers (message:answers reply))) +; (positive? (length answers)))))) + (dns-msg (dns-get-information question use-cache? nameserver check-answer)) + (answers (message:answers (dns-message:reply dns-msg)))) + (if (not (null? answers)) + (show-dns-message (car answers)) + (display "sorry, no answers received\n")) + dns-msg)) + + + + + +;;; pretty-prints a dns-msg +(define (show-dns-message dns-msg) + (let* ((d + (lambda (n s1 s2) + (letrec ((loop (lambda (n) + (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 "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 " (rr:data dns-msg))))))) + + + + +;; plt stuff, to examine how they resolved mx-records +; +;(define (dns-get-mail-exchanger nameserver addr) +; (or (try-forwarding +; (lambda (nameserver) +; (call-with-values +; (lambda () (dns-query/cache nameserver addr 'mx 'in)) +; (lambda (cache? auth? qds ans nss ars reply) +; (values (let loop ((ans ans) +; (best-pref 99999) ; this is enough +; (exchanger #f)) +; (cond +; ((null? ans) +; (or exchanger +; ;; Does 'soa mean that the input address is fine? +; (and (any? (lambda (ns) +; (eq? (rr:type ns) 'soa)) +; nss) +; addr))) +; (else +; (let ((d (rr:data (car ans)))) +; (let ((pref (octet-pair->number (car d) (cadr d)))) +; (if (< pref best-pref) +; (call-with-values +; (lambda () (parse-name (cddr d) reply)) +; (lambda (name start) +; (loop (cdr ans) pref name))) +; (loop (cdr ans) best-pref exchanger))))))) +; ars auth?)))) +; nameserver) +; (error "dns-get-mail-exchanger: bad address")))