scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

dns-lookup-nameserver revised, 

dns-lookup-mailexchanger now implements RFC 2821,
added force-ip and force-ip-list.
This commit is contained in:
cresh 2002-05-21 10:03:21 +00:00
parent 3573dcc613
commit 5d357598b1
2 changed files with 90 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

156
dns.scm
View File

@ -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 <name> [nameserver]) --> <ip>
; (dns-lookup-ip <ip> [nameserver]) --> <name>
; (dns-lookup-nameserver <name> [nameserver]) --> <ip of authoritative nameserver>
; (dns-lookup-mail-exchanger <name> [nameserver]) --> <mail-exchanger>
; (dns-lookup-nameserver <name> [nameserver]) --> <list of ips of authoritative nameservers>
; (dns-lookup-mail-exchanger <name> [nameserver]) --> <list of names of mail-exchangers>
;
; (dns-lookup <name/ip> <type> [nameserver]) --> <dns-message>
; (show-dns-message <dns-message) --> the whole message, human readable
;
; (concurrent-lookup <dns-lookup-*> <name>)
;
; 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 <name>) --> <ip>
; (force-ip-list <list of names>) --> <list of ips>
@ -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 <name> '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 <name> [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 <name> [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))))))

3
modules.scm
View File

@ -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))