Start of rewrite using select.

This commit is contained in:
mainzelm 2002-11-19 22:41:37 +00:00
parent 4c3bde22fa
commit 6cc2305e6b
1 changed files with 108 additions and 86 deletions

View File

@ -805,12 +805,13 @@
;; #t if message is truncated (could happen via UDP)
(define (truncated? reply)
(let ((trunc (flags:trunc (parse-flags reply))))
trunc))
(= 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
@ -839,29 +840,37 @@
(parse reply)))
;; here: via UDP
(define (send-receive-message-udp nameserver question)
(define (send-receive-message-udp nameservers question)
(if *debug* (display "send-receive-message\n"))
(let* ((query question)
(reply
(let ((socket (socket-connect protocol-family/internet
(let ((sockets (map (lambda (nameserver)
(socket-connect protocol-family/internet
socket-type/datagram
nameserver 53)))
(let ((r (socket:inport socket))
(w (socket:outport socket)))
nameserver 53))
nameservers)))
(let ((rs (map socket:inport sockets))
(ws (map socket:outport sockets)))
(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)))
(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 ()
(close-socket socket)))))))
(for-each close-socket sockets)))))))
(reply-acceptable? reply query)
(if (truncated? reply)
(send-receive-message-tcp nameserver question)
(parse reply))))
(send-receive-message-tcp nameservers question)
(values (parse reply)
(car nameservers); kludge
'(kludge)))))
;;; -- cache
@ -895,44 +904,67 @@
(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? protocol nameserver tried)
(if *debug* (display "dns-query/cache\n"))
(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)))
(define (make-key qds nameserver)
(let*;; 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))
(class (question:class (car qds))))
(format #f "~a;~a;~a;~a" nameserver name type class)))
(define (lookup-cache qds nameserver)
(let* ((key (make-key qds nameserver))
(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)))
found-data)
(else #f))))
(define (update-cache! key entry)
(table-set! cache key entry))
(define (dns-query-no-cache question protocol nameservers tried)
;; returns new retrieved data
(receive (dns-msg hit-ns nss-with-no-reply)
(send-receive-message nameservers question protocol)
(values
(make-dns-message (parse question) dns-msg #f protocol (reverse tried))
hit-ns
nss-with-no-reply))))
(define (dns-query-with-cache question protocol nameservers tried)
(let ((qds (message:questions (parse question))))
(let lp ((ns nameservers))
(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)))
;; returns new retrieved data and updates cache
(make-dns-message (parse question) reply-msg #f protocol (reverse tried)))))))))
(values (make-dns-message (parse question) reply-msg #f protocol (reverse tried))
hit-ns
nss-with-no-reply))
(cond ((lookup-cache qds (car ns))
=> (lambda (found-data)
;; returns cached data
(values (make-dns-message (parse question) (cache:answer found-data) #t protocol '())
#f
nameservers)))
(else (lp (cdr ns))))))))
(define (send-receive-message nameservers question protocol)
((cond
((eq? protocol 'tcp) send-receive-message-tcp)
((eq? protocol 'udp) send-receive-message-udp))
nameservers question))
;; 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? protocol nameservers tried)
(if use-cache?
(dns-query-with-cache)
(dns-query)))))
(dns-query-with-cache question protocol nameservers tried)
(dns-query-no-cache question protocol nameservers tried)))
;; dns and recursion
;; recursion means, if the demanded information is not available from the
@ -941,38 +973,29 @@
;; 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? protocol nameserver check-answer)
(define (dns-get-information question use-cache? protocol nameservers check-answer)
(if *debug* (display "dns-get-information\n"))
(letrec ((tried (list nameserver))
;; with every (even unanswerd) requests authoritative nameservers are sent back
;; try-recursive tries to get information from these nameservers
(try-recursive
(lambda (auth? nss)
(if (or auth? (null? nss))
(let lp ((tried '()) (nss nameservers))
(if (null? nss)
(signal 'bad-address)
(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)))
(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.
(check-success
(lambda (dns-msg)
(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"))
(let ((useful-answer? (check-answer dns-msg)))
(if useful-answer?
(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)
;; other nameservers names are found in the nameserver-part,
;; but their ip-adresses are found in the additonal-rrs
(other-nameservers (filter (lambda (elem) (eq? (rr:type elem) 'a))
(let ((other-nameservers
(filter (lambda (elem) (eq? (rr:type elem) 'a))
(message:additionals (dns-message:reply dns-msg)))))
(try-recursive auth? other-nameservers)))))))
(check-success (dns-query/cache question use-cache? protocol nameserver tried))))
(lp (if (not (member hit-ns tried)) (cons hit-ns tried) tried)
(lset-union equal?
nss-with-no-reply
(lset-difference equal? other-nameservers tried)))))))))))
;; parses the resolv.conf file and returns a list of found nameserver
(define (dns-find-nameserver-list)
@ -1085,8 +1108,8 @@
(simple-lookup-function name (car args))))))
;; looks up a hostname, returns an ip.
;; (dns-lookup-name <name> [nameserver])
(define (dns-simple-lookup-name name . args)
;; (dns-lookup-name <name> nameservers)
(define (dns-simple-lookup-name name nameservers)
(call-with-current-continuation
(lambda (exit)
(with-handler
@ -1102,12 +1125,11 @@
(make-octet-query-message (random 256) name 'a '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)))
(not (null? (filter-type answers 'a))))))
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
(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)))))))))