added UDP transportation, made changes in the interface
This commit is contained in:
cresh
parent
87e3cb0c84
commit
831555ba83
344
dns.scm
344
dns.scm
|
|
@ -5,17 +5,28 @@
|
|||
; domain names - implementation and specification
|
||||
; based on the PLT-implementation.
|
||||
;
|
||||
; Marcus Crestani <crestani@informatik.uni-tuebingen.de>
|
||||
; Copyright (c) 2002 Marcus Crestani
|
||||
;
|
||||
; TODO: - test, test, test
|
||||
; - types from newer RFCs
|
||||
; - UDP (therefore abstract the transportation)
|
||||
; - better interface
|
||||
; - check answer for each type
|
||||
; TODO: - !!! CHECK-ANSWER !!!
|
||||
; (wrong: if check-answer is not successfull, bad hostname is returned)
|
||||
; - test, test, test
|
||||
; - types from newer RFCs (41)
|
||||
; - UDP: truncation check
|
||||
; - error conditions
|
||||
; - better interface (found or #f)
|
||||
; - additional type-a processing: force-ip
|
||||
; - check-answer for each type
|
||||
; - more documentation
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
; sample usage:
|
||||
;
|
||||
; (dns-lookup-name <name>) --> <ip>
|
||||
; (dns-lookup-ip <ip>) --> <name>
|
||||
; (dns-lookup-nameserver <name>) --> <authoritative nameserver>
|
||||
; (dns-lookup-mail-exchanger <name>) --> <mail-exchanger>
|
||||
;
|
||||
; (dns-lookup <name/ip> <type>) --> <dns-message>
|
||||
; (show-dns-message <dns-message) --> the whole message, human readable
|
||||
|
||||
|
||||
|
||||
|
|
@ -154,7 +165,28 @@
|
|||
limit)
|
||||
314159265))))
|
||||
|
||||
;; returns a in-addr.arpa name-string or #f (needed to resolver hostname by ip)
|
||||
;; checks if a string is a ip
|
||||
(define (ip? s)
|
||||
(if *debug* (display "ip-string->in-addr\n"))
|
||||
(let loop ((s s)
|
||||
(count 0))
|
||||
(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))
|
||||
#f))))
|
||||
(else
|
||||
(let ((number (string->number s)))
|
||||
(and number
|
||||
(< number 256)
|
||||
(= count 3)
|
||||
#t))))))
|
||||
|
||||
|
||||
;; returns a in-addr.arpa name-string or #f (needed to resolve hostname by ip)
|
||||
(define (ip-string->in-addr s)
|
||||
(if *debug* (display "ip-string->in-addr\n"))
|
||||
(let loop ((s s)
|
||||
|
|
@ -265,6 +297,7 @@
|
|||
query
|
||||
reply
|
||||
cache?
|
||||
protocol
|
||||
tried-nameservers)
|
||||
|
||||
;; message
|
||||
|
|
@ -411,7 +444,7 @@
|
|||
|
||||
(define-record rr-data-mx
|
||||
preference
|
||||
exchange)
|
||||
exchanger)
|
||||
|
||||
(define-record rr-data-ptr
|
||||
name)
|
||||
|
|
@ -563,10 +596,10 @@
|
|||
;; 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"))
|
||||
(display "send-receive-message: bad reply id from server"))
|
||||
;; Check for error code:
|
||||
(let ((rcode (flags:rcode (parse-flags reply))))
|
||||
(if (not (zero? rcode))
|
||||
(if (not (zero? 0));rcode))
|
||||
(error "send-receive-message: error from server: ~a"
|
||||
(case rcode
|
||||
((1) "format error")
|
||||
|
|
@ -576,7 +609,8 @@
|
|||
((5) "refused"))))))
|
||||
|
||||
;; connects to nameserver and sends and receives messages. returns the reply.
|
||||
(define (send-receive-message nameserver question)
|
||||
;; here: via TCP
|
||||
(define (send-receive-message-tcp nameserver question)
|
||||
(if *debug* (display "send-receive-message\n"))
|
||||
(let* ((query question)
|
||||
(reply
|
||||
|
|
@ -604,6 +638,30 @@
|
|||
(reply-acceptable? reply query)
|
||||
(parse reply)))
|
||||
|
||||
;; here: via UDP
|
||||
(define (send-receive-message-udp nameserver question)
|
||||
(if *debug* (display "send-receive-message\n"))
|
||||
(let* ((query question)
|
||||
(reply
|
||||
(let ((socket (socket-connect protocol-family/internet
|
||||
socket-type/datagram
|
||||
nameserver 53)))
|
||||
(let ((r (socket:inport socket))
|
||||
(w (socket:outport socket)))
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
'nothing-to-be-done-before)
|
||||
(lambda ()
|
||||
(display (list->string query) w)
|
||||
(force-output w)
|
||||
(let ((s (read-string/partial 512 r))) ; 512 is the maximum udp-message size
|
||||
(string->list s)))
|
||||
(lambda ()
|
||||
(close-socket socket)))))))
|
||||
(reply-acceptable? reply query)
|
||||
(parse reply)))
|
||||
|
||||
|
||||
;;; -- cache
|
||||
|
||||
;; creates the cache, an emoty string-table
|
||||
|
|
@ -637,35 +695,42 @@
|
|||
|
||||
;; 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)
|
||||
(define (dns-query/cache question use-cache? protocol 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 (find-shortest-ttl 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))))
|
||||
(let ((send-receive-message
|
||||
(cond
|
||||
((eq? protocol 'tcp) send-receive-message-tcp)
|
||||
((eq? protocol 'udp) send-receive-message-udp))))
|
||||
(let ((dns-query
|
||||
(lambda ()
|
||||
(if *debug* (display "dns-query/cache:dns-query\n"))
|
||||
;; returns new retrieved data
|
||||
(make-dns-message (parse question) (send-receive-message nameserver question) #f protocol (reverse tried))))
|
||||
(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))))
|
||||
;; returns cached data
|
||||
(make-dns-message (parse question) (cache:answer found-data) #t protocol (reverse tried)))
|
||||
(else
|
||||
(let ((reply-msg (send-receive-message nameserver question)))
|
||||
(if *debug* (display "write to cache\n"))
|
||||
(table-set! cache key (make-cache reply-msg (find-shortest-ttl reply-msg) (time)))
|
||||
;; returns new retrieved data and updates cache
|
||||
(make-dns-message (parse question) reply-msg #f protocol (reverse tried)))))))))
|
||||
(if use-cache?
|
||||
(dns-query-with-cache)
|
||||
(dns-query)))))
|
||||
|
||||
;; dns and recursion
|
||||
;; recursion means, if the demanded information is not available from the
|
||||
|
|
@ -674,7 +739,7 @@
|
|||
;; 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)
|
||||
(define (dns-get-information question use-cache? protocol nameserver check-answer)
|
||||
(if *debug* (display "dns-get-information\n"))
|
||||
(letrec ((tried (list nameserver))
|
||||
;; with every (also unanswerd) requests authoritative nameservers are send back
|
||||
|
|
@ -687,7 +752,7 @@
|
|||
(dns-msg (if (and ns
|
||||
(not (member ns tried))
|
||||
(set! tried (cons ns tried)))
|
||||
(dns-query/cache question use-cache? ns tried)
|
||||
(dns-query/cache question use-cache? protocol ns tried)
|
||||
(try-recursive auth? (cdr nss)))))
|
||||
(check-success dns-msg)))))
|
||||
;; checks if the answer is useful. returns a dns-message.
|
||||
|
|
@ -702,60 +767,166 @@
|
|||
;; 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))))
|
||||
(check-success (dns-query/cache question use-cache? protocol nameserver tried))))
|
||||
|
||||
|
||||
;; parses the resolv.conf file and returns the first found nameserver
|
||||
(define (dns-find-nameserver)
|
||||
|
||||
;; parses the resolv.conf file and returns a list of found nameserver
|
||||
(define (dns-find-nameserver-list)
|
||||
(with-input-from-file "/etc/resolv.conf"
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(let loop ((ns '()))
|
||||
(let ((l (read-line)))
|
||||
(cond
|
||||
((eof-object? l)
|
||||
#f)
|
||||
ns)
|
||||
((regexp-search (posix-string->regexp "nameserver[ ]+([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+)") l)
|
||||
=> (lambda (match)
|
||||
(match:substring match 1)))
|
||||
(loop (append ns (list (match:substring match 1))))))
|
||||
(else
|
||||
(loop))))))))
|
||||
(loop ns))))))))
|
||||
|
||||
|
||||
;; returns the first found nameserver
|
||||
(define (dns-find-nameserver)
|
||||
(let ((ns (dns-find-nameserver-list)))
|
||||
(if (null? ns)
|
||||
(error "dns-find-nameserver: no nameserver found in /etc/resolv.conf")
|
||||
(car ns))))
|
||||
|
||||
|
||||
;;
|
||||
(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)
|
||||
(protocol 'udp)
|
||||
(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))
|
||||
(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 "sorry, no answers received\n"))
|
||||
dns-msg))
|
||||
|
||||
|
||||
;; looks up a hostname, returns an ip
|
||||
(define (dns-lookup-name name)
|
||||
(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 (dns-find-nameserver))
|
||||
(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))))))
|
||||
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
|
||||
(answers (valid-answers (message:answers (dns-message:reply dns-msg)))))
|
||||
(rr-data-a:ip (rr:data (car answers)))))
|
||||
|
||||
|
||||
;; looks up an ip, returns a hostname
|
||||
(define (dns-inverse-lookup ip)
|
||||
(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 (dns-find-nameserver))
|
||||
(check-answer (lambda (dns-msg) (if *debug* (display "check-answer\n"))
|
||||
(let* ((reply (dns-message:reply dns-msg))
|
||||
(answers (message:answers reply)))
|
||||
(not (null? answers)))))
|
||||
(dns-msg (dns-get-information question use-cache? nameserver check-answer))
|
||||
(answers (message:answers (dns-message:reply dns-msg))))
|
||||
(if (not (null? answers))
|
||||
(rr-data-ptr:name (rr:data (car answers)))
|
||||
#f)))
|
||||
(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))))))
|
||||
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
|
||||
(answers (valid-answers (message:answers (dns-message:reply dns-msg)))))
|
||||
(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
|
||||
(define (dns-lookup-nameserver name)
|
||||
(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 'tcp)
|
||||
(nameserver (dns-find-nameserver))
|
||||
(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))
|
||||
(nameservers (message:nameservers reply)))
|
||||
(not (null? (valid-nameservers nameservers))))))
|
||||
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
|
||||
(nameservers (valid-nameservers (message:nameservers (dns-message:reply dns-msg)))))
|
||||
(rr-data-soa:mname (rr:data (car nameservers)))))
|
||||
|
||||
|
||||
|
||||
;; looks up a mail-exchanger for a hostname.
|
||||
;; returns a mail-exchanger
|
||||
;; if there are no mx-records in the answer-section,
|
||||
;; the rname of the soa-record is returned.
|
||||
;; ### CHECK RFC2821
|
||||
(define (dns-lookup-mail-exchanger name)
|
||||
(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 (dns-find-nameserver))
|
||||
(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)))))))
|
||||
(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)))))))))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -782,6 +953,10 @@
|
|||
(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: ")
|
||||
|
|
@ -836,7 +1011,7 @@
|
|||
((rr-data-mx? dns-msg)
|
||||
(begin
|
||||
(d 5 "preference " (rr-data-mx:preference dns-msg))
|
||||
(d 5 "exchange " (rr-data-mx:exchange 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)
|
||||
|
|
@ -856,38 +1031,3 @@
|
|||
(d 5 "data " (rr-data-wks: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")))
|
||||
|
|
|
|||
|
|
@ -769,13 +769,18 @@
|
|||
|
||||
|
||||
;; dns.scm is a module to resolve hostnames and ip-addresses.
|
||||
;; it implements the rfc1035
|
||||
;; it implements the rfc1035.
|
||||
(define-interface dns-interface
|
||||
(export dns-clear-cache
|
||||
dns-lookup
|
||||
dns-lookup-name
|
||||
dns-inverse-lookup
|
||||
dns-lookup-ip
|
||||
dns-lookup-nameserver
|
||||
dns-lookup-mail-exchanger
|
||||
show-dns-message
|
||||
dns-find-nameserver))
|
||||
dns-find-nameserver
|
||||
dns-find-nameserver-list))
|
||||
|
||||
(define-structure dns dns-interface
|
||||
(open scheme
|
||||
|
|
|
|||
Loading…
Reference in New Issue