Start of rewrite using select.
This commit is contained in:
mainzelm
parent
4c3bde22fa
commit
6cc2305e6b
|
|
@ -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 <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)))))))))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue