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

added better multiple answers processing and rr-data-types

This commit is contained in:
cresh 2002-04-17 12:12:58 +00:00
parent 6f9f67f484
commit 48a0a95a4a
1 changed files with 129 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

139
dns.scm
View File

@ -8,6 +8,15 @@
; 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
; - more documentation
;;; should debug-msgs be printed out?
@ -55,7 +64,7 @@
(define (cossa i l)
(if *debug* (display "cossa\n"))
(cond
((null? l) #f)
((null? l) (error "dns-message: type not implemented: " i))
((equal? (cadar l) i)
(car l))
(else (cossa i (cdr l)))))
@ -381,33 +390,75 @@
(cdr start)
(cons (car start) accum)))))))))))
;;; -- rr-data-type records
(define-record rr-data-a
ip)
(define-record rr-data-ns
name)
(define-record rr-data-cname
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 :-)
(define-record rr-data-hinfo
data)
(define-record rr-data-mx
preference
exchange)
(define-record rr-data-ptr
name)
(define-record rr-data-soa
mname
rname
serial
refresh
retry
expire
minimum)
;; ### same as hinfo
(define-record rr-data-txt
text)
;; ### same as hinfo and txt
(define-record rr-data-wks
data)
;;
(define (parse-rr-data type class data message)
(if *debug* (display "parse-rr-data\n"))
(cond
((eq? type 'a)
(list (ip->string data)))
(make-rr-data-a (ip->string data)))
((eq? type 'ns)
(list (call-with-values
(make-rr-data-ns (call-with-values
(lambda () (parse-name data message))
(lambda (name rest) name))))
((eq? type 'cname)
(list (call-with-values
(make-rr-data-cname (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))
(make-rr-data-mx (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
(make-rr-data-ptr (call-with-values
(lambda () (parse-name data message))
(lambda (name rest) name))))
@ -428,13 +479,16 @@
(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)))))))))))
(make-rr-data-soa mname rname serial refresh retry expire minimum)))))))))))
((eq? type 'hinfo)
(make-rr-data-hinfo (list->string data)))
((eq? type 'txt)
(list (list->string data)))
(make-rr-data-txt (list->string data)))
((eq? type 'wks)
(list data))
(make-rr-data-wks data))
(else (list data))))
@ -559,6 +613,28 @@
(define (dns-clear-cache)
(set! cache (make-string-table)))
;; searches in a dns-msg for the shortest ttl. this is needed for cache-management.
(define (find-shortest-ttl dns-msg)
(if *debug* (display "find-shortest-ttl\n"))
(letrec ((minimum #f)
(find-shortest-ttl-1
(lambda (dns-msg)
(cond
((dns-message? dns-msg)
(find-shortest-ttl-1 (dns-message:reply dns-msg)))
((message? dns-msg)
(for-each (lambda (x) (find-shortest-ttl-1 x)) (message:answers dns-msg))
(for-each (lambda (x) (find-shortest-ttl-1 x)) (message:nameservers dns-msg))
(for-each (lambda (x) (find-shortest-ttl-1 x)) (message:additionals dns-msg))
minimum)
((rr? dns-msg)
(cond
((not minimum) (set! minimum (rr:ttl dns-msg)))
(else
(if (and (not minimum) (> minimum (rr:ttl dns-msg)))
(set! minimum (rr:ttl dns-msg))))))))))
(find-shortest-ttl-1 dns-msg)))
;; 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)
@ -585,11 +661,7 @@
(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)))
(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)
@ -664,7 +736,7 @@
(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))
(for-each (lambda (x) (show-dns-message x)(newline)) answers)
(display "sorry, no answers received\n"))
dns-msg))
@ -739,7 +811,36 @@
(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)))))))
(d 4 "data " "") (show-dns-message (rr:data dns-msg))))
((rr-data-a? dns-msg)
(d 5 "ip " (rr-data-a:ip dns-msg)))
((rr-data-ns? dns-msg)
(d 5 "name " (rr-data-ns:name dns-msg)))
((rr-data-cname? dns-msg)
(d 5 "name " (rr-data-cname:name dns-msg)))
((rr-data-mx? dns-msg)
(begin
(d 5 "preference " (rr-data-mx:preference dns-msg))
(d 5 "exchange " (rr-data-mx:exchange dns-msg))))
((rr-data-ptr? dns-msg)
(d 5 "name " (rr-data-ptr:name dns-msg)))
((rr-data-soa? dns-msg)
(begin
(d 5 "mname " (rr-data-soa:mname dns-msg))
(d 5 "rname " (rr-data-soa:rname dns-msg))
(d 5 "serial " (rr-data-soa:serial dns-msg))
(d 5 "refresh " (rr-data-soa:refresh dns-msg))
(d 5 "expire " (rr-data-soa:expire dns-msg))
(d 5 "minimum " (rr-data-soa:expire dns-msg))))
;; ###
((rr-data-hinfo? dns-msg)
(d 5 "data " (rr-data-hinfo:data dns-msg)))
((rr-data-txt? dns-msg)
(d 5 "text " (rr-data-txt:text dns-msg)))
((rr-data-wks? dns-msg)
(d 5 "data " (rr-data-wks:data dns-msg)))
)))