diff --git a/dns.scm b/dns.scm index 34bdbb4..00096ed 100644 --- a/dns.scm +++ b/dns.scm @@ -6,27 +6,31 @@ ; based on the PLT-implementation. ; ; -; TODO: - !!! CHECK-ANSWER !!! -; (wrong: if check-answer is not successfull, bad hostname is returned) +; TODO: -*!!! CHECK-ANSWER !!! +; *(wrong: if check-answer is not successfull, bad hostname is returned) +; *solution: error conditions -> if thrown, return #f ; - test, test, test ; - types from newer RFCs (41) ; - UDP: truncation check -; - error conditions -; - better interface (found or #f) +; -*error conditions +; -*better interface (found or #f) ; - additional type-a processing: force-ip ; - check-answer for each type +; mx: rfc2821 ; - more documentation ; ; ; sample usage: ; -; (dns-lookup-name ) --> -; (dns-lookup-ip ) --> -; (dns-lookup-nameserver ) --> -; (dns-lookup-mail-exchanger ) --> +; (dns-lookup-name [nameserver]) --> +; (dns-lookup-ip [nameserver]) --> +; (dns-lookup-nameserver [nameserver]) --> +; (dns-lookup-mail-exchanger [nameserver]) --> ; -; (dns-lookup ) --> +; (dns-lookup [nameserver]) --> ; (show-dns-message the whole message, human readable +; +; (concurrent-lookup ) @@ -259,9 +263,9 @@ (define (make-octet-question name type class) (if *debug* (display "make-octet-question\n")) (if (not (assoc type types)) - (error "make-octet-question: invalid DNS query type ~a" type)) + (error "make-octet-question: invalid DNS query type ~A" type)) (if (not (assoc class classes)) - (error "make-octet-question: invalid DNS query class ~a" class)) + (error "make-octet-question: invalid DNS query class ~A" class)) (let* ((qname (name->octets name)) (qtype (number->octet-pair (cadr (assoc type types)))) @@ -600,7 +604,7 @@ ;; Check for error code: (let ((rcode (flags:rcode (parse-flags reply)))) (if (not (zero? 0));rcode)) - (error "send-receive-message: error from server: ~a" + (error "send-receive-message: error from server: ~A" (case rcode ((1) "format error") ((2) "server failure") @@ -742,12 +746,13 @@ (define (dns-get-information question use-cache? protocol nameserver check-answer) (if *debug* (display "dns-get-information\n")) (letrec ((tried (list nameserver)) - ;; with every (also unanswerd) requests authoritative nameservers are send back + ;; 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)) - (error "dns-get-information: bad address ~a" (question:name (car (message:questions (parse question))))) + (if (or auth? (null? nss)) + (error "dns-get-information: bad address (in combination with query-type)" + (question:name (car (message:questions (parse question))))) (let* ((ns (and (eq? (rr:type (car nss)) 'a) (ip->string (rr:data (car nss))))) (dns-msg (if (and ns (not (member ns tried)) @@ -765,7 +770,8 @@ (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 (message:additionals (dns-message:reply dns-msg)))) + (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)))) @@ -795,33 +801,137 @@ (car ns)))) -;; -(define (dns-lookup name type) + +;; lookup-queue record for concurrent-lookup +(define-record lookup-queue + lock + cond-lock + queue) + +;; Lock-Conditions +(define-record lock-condition + lock + waiting-locks) + +(define (wait-lock-condition lock-cond) + (let ((waiting-lock (make-lock))) + (obtain-lock waiting-lock) + (set-lock-condition:waiting-locks + lock-cond + (cons waiting-lock + (lock-condition:waiting-locks lock-cond))) + (let ((lock (lock-condition:lock lock-cond))) + (release-lock lock) + (obtain-lock waiting-lock) + (obtain-lock lock)))) + +(define (signal-lock-condition lock-cond) + (let ((waiting-locks (lock-condition:waiting-locks lock-cond))) + (if (not (null? waiting-locks)) + (begin + (set-lock-condition:waiting-locks lock-cond + (cdr waiting-locks)) + (release-lock (car waiting-locks)))))) + +(define (broadcast-lock-condition lock-cond) + (let ((waiting-locks (lock-condition:waiting-locks lock-cond))) + (set-lock-condition:waiting-locks lock-cond '()) + (let loop ((waiting-locks waiting-locks)) + (if (not (null? waiting-locks)) + (begin + (release-lock (car waiting-locks)) + (loop (cdr waiting-locks))))))) + +;; with-lock +(define (with-lock lock thunk) + (obtain-lock lock) + (let ((value (thunk))) + (release-lock lock) + value)) + + +;; concurrent-lookup +;; starts a -lookup to all nameservers in (dns-find-nameserver-list) +(define (concurrent-lookup lookup name) + (let* ((return 'not-terminated-yet) + (lock (make-lock)) + (ccl (make-lookup-queue lock (make-lock-condition lock '()) (make-queue)))) + + (spawn + (lambda () + (display "consumer started \n") + (with-lock lock + (lambda () + (let loop () + (let ((queue (lookup-queue:queue ccl))) + (if (queue-empty? queue) + (begin + (wait-lock-condition (lookup-queue:cond-lock ccl)) + (loop)) + (let ((value (dequeue! queue))) + (set! return value) + value)))))))) + (spawn (lambda () + (for-each (lambda (nameserver) + (spawn + (lambda () + (display nameserver)(display " started\n") + (with-lock lock + (lambda () + (let* ((result (apply lookup (list name nameserver)))) + (enqueue! (lookup-queue:queue ccl) result) + (display nameserver)(display " ")(display result)(newline) + (broadcast-lock-condition (lookup-queue:cond-lock ccl)))))))) + (dns-find-nameserver-list)))) + +;; ### active waiting ? + (let loop () + (if (not (eq? return 'not-terminated-yet)) + return + (loop))))) + +;; checks the arguments of the dns-lookup-* functions. +;; if a nameserver-name is given and not a nameserver-ip +;; (dns-lookup-name nameserver) is called. +(define (check-args args) + (if (null? args) + (dns-find-nameserver) + (let ((nameserver (car args))) + (if (ip? nameserver) + nameserver + (dns-lookup-name nameserver))))) + + +;; dns-lookup with more options than dns-lookup-* +;; optional: nameserver could be passed to the function. +(define (dns-lookup name type . args) (let* ((ip-string (ip-string->in-addr name)) (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address (make-octet-query-message (random 256) ip-string type 'in) (make-octet-query-message (random 256) name type 'in))) (use-cache? #t) (protocol 'udp) - (nameserver (dns-find-nameserver)) + (nameserver (check-args args)) (check-answer (lambda (dns-msg) #t)) (dns-msg (dns-get-information question use-cache? protocol nameserver check-answer)) (answers (message:answers (dns-message:reply dns-msg)))) (if (not (null? answers)) (for-each (lambda (x) (show-dns-message x)(newline)) answers) - (display "sorry, no answers received\n")) + (display "no answers received - but resolved information in other sections.\n")) dns-msg)) -;; looks up a hostname, returns an ip -(define (dns-lookup-name name) + +;; looks up a hostname, returns an ip. +;; (dns-lookup-name [nameserver]) +(define (dns-lookup-name name . args) (let* ((ip-string (ip-string->in-addr name)) (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address (error "dns-lookup-name: no valid hostname, suppose it is an ip") (make-octet-query-message (random 256) name 'a 'in))) (use-cache? #t) (protocol 'udp) - (nameserver (dns-find-nameserver)) + (nameserver (check-args args)) (valid-answers (lambda (answer) (filter (lambda (ans) (eq? (rr:type ans) 'a)) @@ -836,14 +946,15 @@ ;; looks up an ip, returns a hostname -(define (dns-inverse-lookup ip) +;; (dns-inverse-lookup [nameserver]) +(define (dns-inverse-lookup ip . args) (let* ((ip-string (ip-string->in-addr ip)) (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address (make-octet-query-message (random 256) ip-string 'ptr 'in) (error "dns-inverse-lookup: no valid ip"))) (use-cache? #t) (protocol 'udp) - (nameserver (dns-find-nameserver)) + (nameserver (check-args args)) (valid-answers (lambda (answers) (filter (lambda (ans) (eq? (rr:type ans) 'ptr)) @@ -861,14 +972,15 @@ ;; looks up an authoritative nameserver for a hostname ;; returns a nameserver -(define (dns-lookup-nameserver name) +;; (dns-lookup-nameserver [nameserver]) +(define (dns-lookup-nameserver name . args) (let* ((ip-string (ip-string->in-addr name)) (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address (error "dns-lookup-name: no valid hostname, suppose it is an ip") (make-octet-query-message (random 256) name 'ns 'in))) (use-cache? #t) (protocol 'tcp) - (nameserver (dns-find-nameserver)) + (nameserver (check-args args)) (valid-nameservers (lambda (nameservers) (filter (lambda (ns) (eq? (rr:type ns) 'soa)) @@ -879,7 +991,7 @@ (not (null? (valid-nameservers nameservers)))))) (dns-msg (dns-get-information question use-cache? protocol nameserver check-answer)) (nameservers (valid-nameservers (message:nameservers (dns-message:reply dns-msg))))) - (rr-data-soa:mname (rr:data (car nameservers))))) + (dns-lookup-name (rr-data-soa:mname (rr:data (car nameservers)))))) @@ -887,15 +999,16 @@ ;; returns a mail-exchanger ;; if there are no mx-records in the answer-section, ;; the rname of the soa-record is returned. +;; (dns-lookup-mail-exchanger [nameserver]) ;; ### CHECK RFC2821 -(define (dns-lookup-mail-exchanger name) +(define (dns-lookup-mail-exchanger name . args) (let* ((ip-string (ip-string->in-addr name)) (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address (error "dns-lookup-name: no valid hostname, suppose it is an ip") (make-octet-query-message (random 256) name 'mx 'in))) (use-cache? #t) (protocol 'tcp) - (nameserver (dns-find-nameserver)) + (nameserver (check-args args)) (valid-answers (lambda (answers) (filter (lambda (answer) (eq? (rr:type answer) 'mx)) diff --git a/modules.scm b/modules.scm index 83218db..0efc335 100644 --- a/modules.scm +++ b/modules.scm @@ -778,6 +778,7 @@ dns-lookup-ip dns-lookup-nameserver dns-lookup-mail-exchanger + concurrent-lookup show-dns-message dns-find-nameserver dns-find-nameserver-list)) @@ -791,5 +792,8 @@ formats signals defrec-package - random) + random + queues + threads + locks) (files dns))