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

added concurrent-lookup, made some minor changes

This commit is contained in:
cresh 2002-05-06 17:15:22 +00:00
parent 831555ba83
commit a766574fd1
2 changed files with 148 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

171
dns.scm
View File

@ -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 <name>) --> <ip>
; (dns-lookup-ip <ip>) --> <name>
; (dns-lookup-nameserver <name>) --> <authoritative nameserver>
; (dns-lookup-mail-exchanger <name>) --> <mail-exchanger>
; (dns-lookup-name <name> [nameserver]) --> <ip>
; (dns-lookup-ip <ip> [nameserver]) --> <name>
; (dns-lookup-nameserver <name> [nameserver]) --> <ip of authoritative nameserver>
; (dns-lookup-mail-exchanger <name> [nameserver]) --> <mail-exchanger>
;
; (dns-lookup <name/ip> <type>) --> <dns-message>
; (dns-lookup <name/ip> <type> [nameserver]) --> <dns-message>
; (show-dns-message <dns-message) --> the whole message, human readable
;
; (concurrent-lookup <dns-lookup-*> <name>)
@ -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)))))
(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>-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 <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 <name> [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 <name> [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 <name> [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))

6
modules.scm
View File

@ -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))