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

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

194
scheme/lib/dns.scm
View File

@ -805,12 +805,13 @@
;; #t if message is truncated (could happen via UDP) ;; #t if message is truncated (could happen via UDP)
(define (truncated? reply) (define (truncated? reply)
(let ((trunc (flags:trunc (parse-flags reply)))) (let ((trunc (flags:trunc (parse-flags reply))))
trunc)) (= trunc 1)))
;; connects to nameserver and sends and receives messages. returns the reply. ;; connects to nameserver and sends and receives messages. returns the reply.
;; here: via TCP ;; here: via TCP
(define (send-receive-message-tcp nameserver question) (define (send-receive-message-tcp nameserver question)
(error "tcp doesn't work yet")
(if *debug* (display "send-receive-message\n")) (if *debug* (display "send-receive-message\n"))
(let* ((query question) (let* ((query question)
(reply (reply
@ -839,29 +840,37 @@
(parse reply))) (parse reply)))
;; here: via UDP ;; here: via UDP
(define (send-receive-message-udp nameserver question) (define (send-receive-message-udp nameservers question)
(if *debug* (display "send-receive-message\n")) (if *debug* (display "send-receive-message\n"))
(let* ((query question) (let* ((query question)
(reply (reply
(let ((socket (socket-connect protocol-family/internet (let ((sockets (map (lambda (nameserver)
socket-type/datagram (socket-connect protocol-family/internet
nameserver 53))) socket-type/datagram
(let ((r (socket:inport socket)) nameserver 53))
(w (socket:outport socket))) nameservers)))
(let ((rs (map socket:inport sockets))
(ws (map socket:outport sockets)))
(dynamic-wind (dynamic-wind
(lambda () (lambda ()
'nothing-to-be-done-before) 'nothing-to-be-done-before)
(lambda () (lambda ()
(display (list->string query) w) (let ((query-string (list->string query))
(force-output w) (rsv (list->vector rs)))
(let ((s (read-string/partial 512 r))) ; 512 is the maximum udp-message size (for-each (lambda (w) (display query-string w)) ws)
(string->list s))) (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 () (lambda ()
(close-socket socket))))))) (for-each close-socket sockets)))))))
(reply-acceptable? reply query) (reply-acceptable? reply query)
(if (truncated? reply) (if (truncated? reply)
(send-receive-message-tcp nameserver question) (send-receive-message-tcp nameservers question)
(parse reply)))) (values (parse reply)
(car nameservers); kludge
'(kludge)))))
;;; -- cache ;;; -- cache
@ -895,44 +904,67 @@
(set! minimum (rr:ttl dns-msg)))))))))) (set! minimum (rr:ttl dns-msg))))))))))
(find-shortest-ttl-1 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. ;; makes a dns-query. optional cache-check.
;; returns a dns-message with cache-flag and either cache-data or new received data. ;; 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) (define (dns-query/cache question use-cache? protocol nameservers 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)))))))))
(if use-cache? (if use-cache?
(dns-query-with-cache) (dns-query-with-cache question protocol nameservers tried)
(dns-query))))) (dns-query-no-cache question protocol nameservers tried)))
;; dns and recursion ;; dns and recursion
;; recursion means, if the demanded information is not available from the ;; recursion means, if the demanded information is not available from the
@ -941,38 +973,29 @@
;; this feature is technically optional (RFC 1035). ;; this feature is technically optional (RFC 1035).
;; dns-get-information implements the resovler-side recursion. ;; dns-get-information implements the resovler-side recursion.
;; it returns a dns-message ;; 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")) (if *debug* (display "dns-get-information\n"))
(letrec ((tried (list nameserver)) (let lp ((tried '()) (nss nameservers))
;; with every (even unanswerd) requests authoritative nameservers are sent back (if (null? nss)
;; try-recursive tries to get information from these nameservers (signal 'bad-address)
(try-recursive (receive (dns-msg hit-ns nss-with-no-reply)
(lambda (auth? nss) (dns-query/cache question use-cache? protocol nss tried)
(if (or auth? (null? nss)) (if *debug* (display "dns-get-information:check-success\n"))
(signal 'bad-address) (if (check-answer dns-msg)
(let* ((ns (and (eq? (rr:type (car nss)) 'a) (rr-data-a:ip (rr:data (car nss))))) dns-msg
(dns-msg (if (and ns (let ((auth? (not (zero? (flags:auth (header:flags
(not (member ns tried)) (message:header (dns-message:reply dns-msg))))))))
(set! tried (cons ns tried))) (if auth?
(dns-query/cache question use-cache? protocol ns tried) (signal 'bad-address)
(try-recursive auth? (cdr nss))))) ;; other nameservers names are found in the nameserver-part,
(check-success dns-msg))))) ;; but their ip-adresses are found in the additonal-rrs
;; checks if the answer is useful. returns a dns-message. (let ((other-nameservers
(check-success (filter (lambda (elem) (eq? (rr:type elem) 'a))
(lambda (dns-msg) (message:additionals (dns-message:reply dns-msg)))))
(if *debug* (display "dns-get-information:check-success\n")) (lp (if (not (member hit-ns tried)) (cons hit-ns tried) tried)
(let ((useful-answer? (check-answer dns-msg))) (lset-union equal?
(if useful-answer? nss-with-no-reply
dns-msg (lset-difference equal? other-nameservers tried)))))))))))
(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))))
;; parses the resolv.conf file and returns a list of found nameserver ;; parses the resolv.conf file and returns a list of found nameserver
(define (dns-find-nameserver-list) (define (dns-find-nameserver-list)
@ -1085,8 +1108,8 @@
(simple-lookup-function name (car args)))))) (simple-lookup-function name (car args))))))
;; looks up a hostname, returns an ip. ;; looks up a hostname, returns an ip.
;; (dns-lookup-name <name> [nameserver]) ;; (dns-lookup-name <name> nameservers)
(define (dns-simple-lookup-name name . args) (define (dns-simple-lookup-name name nameservers)
(call-with-current-continuation (call-with-current-continuation
(lambda (exit) (lambda (exit)
(with-handler (with-handler
@ -1102,12 +1125,11 @@
(make-octet-query-message (random 256) name 'a 'in))) (make-octet-query-message (random 256) name 'a 'in)))
(use-cache? #t) (use-cache? #t)
(protocol 'udp) (protocol 'udp)
(nameserver (check-args args))
(check-answer (lambda (dns-msg) (check-answer (lambda (dns-msg)
(let* ((reply (dns-message:reply dns-msg)) (let* ((reply (dns-message:reply dns-msg))
(answers (message:answers reply))) (answers (message:answers reply)))
(not (null? (filter-type answers 'a)))))) (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))) (answers (filter-type (message:answers (dns-message:reply dns-msg)) 'a)))
(rr-data-a:ip (rr:data (car answers))))))))) (rr-data-a:ip (rr:data (car answers)))))))))