From 6cc2305e6b60226bc3405be5a7cd1fea2eb0cd64 Mon Sep 17 00:00:00 2001 From: mainzelm Date: Tue, 19 Nov 2002 22:41:37 +0000 Subject: [PATCH] Start of rewrite using select. --- scheme/lib/dns.scm | 194 +++++++++++++++++++++++++-------------------- 1 file changed, 108 insertions(+), 86 deletions(-) diff --git a/scheme/lib/dns.scm b/scheme/lib/dns.scm index 14f811f..ab0bcbd 100644 --- a/scheme/lib/dns.scm +++ b/scheme/lib/dns.scm @@ -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 - socket-type/datagram - nameserver 53))) - (let ((r (socket:inport socket)) - (w (socket:outport socket))) + (let ((sockets (map (lambda (nameserver) + (socket-connect protocol-family/internet + socket-type/datagram + 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))))))) - (reply-acceptable? reply query) - (if (truncated? reply) - (send-receive-message-tcp nameserver question) - (parse reply)))) + (for-each close-socket sockets))))))) + (reply-acceptable? reply query) + (if (truncated? 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))) + +(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)))) + (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)))) + 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 + (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 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))) - (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))))))))) +(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)) - (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) - (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 (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)))) - - + (let lp ((tried '()) (nss nameservers)) + (if (null? nss) + (signal 'bad-address) + (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")) + (if (check-answer dns-msg) + 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 + (let ((other-nameservers + (filter (lambda (elem) (eq? (rr:type elem) 'a)) + (message:additionals (dns-message:reply dns-msg))))) + (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 [nameserver]) -(define (dns-simple-lookup-name name . args) +;; (dns-lookup-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)))))))))