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

+ error conditions

This commit is contained in:
cresh 2002-05-21 15:25:09 +00:00
parent 5d357598b1
commit 66208241f5
2 changed files with 342 additions and 227 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

553
dns.scm
View File

@ -6,13 +6,9 @@
; based on the PLT-implementation. ; based on the PLT-implementation.
; ;
; ;
; TODO: -*!!! CHECK-ANSWER !!! ; TODO:
; *(wrong: if check-answer is not successfull, bad hostname is returned)
; *solution: error conditions -> if thrown, return #f
; - test, test, test ; - test, test, test
; - types from newer RFCs (41, unknown) ; - types from newer RFCs (41, unknown)
; -*error conditions
; -*better interface (found or #f)
; - more documentation ; - more documentation
; ;
; ;
@ -42,6 +38,90 @@
(define *debug* #f) (define *debug* #f)
;; --- error conditions
(define-condition-type 'invalid-type '())
(define invalid-type? (condition-predicate 'invalid-type))
(define-condition-type 'invalid-class '())
(define invalid-class? (condition-predicate 'invalid-class))
(define-condition-type 'parse-error '())
(define parse-error? (condition-predicate 'parse))
(define-condition-type 'unexpected-eof-from-server '())
(define unexpected-eof-from-server? (condition-predicate 'unexpected-eof-from-server))
(define-condition-type 'bad-address '())
(define bad-address? (condition-predicate 'bad-address))
(define-condition-type 'no-nameservers '())
(define no-nameservers? (condition-predicate 'no-nameservers))
(define-condition-type 'not-a-hostname '())
(define not-a-hostname? (condition-predicate 'not-a-hostname))
(define-condition-type 'not-a-ip '())
(define not-a-ip? (condition-predicate 'not-a-ip))
(define-condition-type 'dns-format-error '())
(define dns-format-error? (condition-predicate 'dns-format-error))
(define-condition-type 'dns-server-failure '())
(define dns-server-failure? (condition-predicate 'dns-server-failure))
(define-condition-type 'dns-name-error '())
(define dns-name-error? (condition-predicate 'dns-name-error))
(define-condition-type 'dns-not-implemented '())
(define dns-not-implemented? (condition-predicate 'dns-not-implemented))
(define-condition-type 'dns-refused '())
(define dns-refused? (condition-predicate 'dns-refused))
(define-condition-type 'dns-error '(dns-format-error
dns-server-failure
dns-name-error
dns-not-implemented
dns-refused))
(define dns-error? (condition-predicate 'dns-error))
;; called by the error-handlers, prints out error descriptions
(define (dns-error-messages condition more)
(cond
((invalid-type? condition)
(display "make-octet-question: invalid DNS query type\n"))
((invalid-class? condition)
(display "make-octet-question: invalid DNS query class\n"))
((parse-error? condition)
(display "parse: error parsing server message\n"))
((unexpected-eof-from-server? condition)
(display "send-receive-message: unexpected EOF from server\n"))
((bad-address? condition)
(display "dns-get-information: bad address (in combination with query type)\n"))
((no-nameservers? condition)
(display "dns-find-nameserver: no nameservers found in /etc/resolv.conf\n"))
((not-a-hostname? condition)
(display "no hostname given\n"))
((not-a-ip? condition)
(display "no ip given\n"))
((dns-format-error? condition)
(display "error from server: (1) format error\n"))
((dns-server-failure? condition)
(display "error from server: (2) server failure\n"))
((dns-name-error? condition)
(display "error from server: (3) name error\n"))
((dns-not-implemented? condition)
(display "error from server: (4) not implemented\n"))
((dns-refused? condition)
(display "error from server: (5) refused\n"))
(else (more))))
;;; -- globals and types ;;; -- globals and types
;; off ;; off
@ -84,7 +164,7 @@
(define (cossa i l) (define (cossa i l)
(if *debug* (display "cossa\n")) (if *debug* (display "cossa\n"))
(cond (cond
((null? l) 'unknown) ;;(error "dns-message: type not implemented: " i)) ((null? l) 'unknown)
((equal? (cadar l) i) ((equal? (cadar l) i)
(car l)) (car l))
(else (cossa i (cdr l))))) (else (cossa i (cdr l)))))
@ -164,7 +244,7 @@
=> (lambda (match) => (lambda (match)
(loop (match:substring match 2) (append result (list (ascii->char (string->number (match:substring match 1)))))))) (loop (match:substring match 2) (append result (list (ascii->char (string->number (match:substring match 1))))))))
(else (else
(append result (list (ascii->char (string->number s)))))))) (append result (list (ascii->char (string->number s))))))))
;; calculates a "random" number, needed for message-ids ;; calculates a "random" number, needed for message-ids
(define random (define random
@ -292,9 +372,9 @@
(define (make-octet-question name type class) (define (make-octet-question name type class)
(if *debug* (display "make-octet-question\n")) (if *debug* (display "make-octet-question\n"))
(if (not (assoc type types)) (if (not (assoc type types))
(error "make-octet-question: invalid DNS query type ~A" type)) (signal 'invalid-type))
(if (not (assoc class classes)) (if (not (assoc class classes))
(error "make-octet-question: invalid DNS query class ~A" class)) (signal 'invalid-class))
(let* ((qname (name->octets name)) (let* ((qname (name->octets name))
(qtype (number->octet-pair (cadr (assoc type types)))) (qtype (number->octet-pair (cadr (assoc type types))))
@ -516,14 +596,14 @@
((eq? type 'mx) ((eq? type 'mx)
(make-rr-data-mx (octet-pair->number (car data) (cadr data)) (make-rr-data-mx (octet-pair->number (car data) (cadr data))
(call-with-values (call-with-values
(lambda ()(parse-name (cddr data) message)) (lambda ()(parse-name (cddr data) message))
(lambda (name rest) name)))) (lambda (name rest) name))))
((eq? type 'ptr) ((eq? type 'ptr)
(make-rr-data-ptr (call-with-values (make-rr-data-ptr (call-with-values
(lambda () (parse-name data message)) (lambda () (parse-name data message))
(lambda (name rest) name)))) (lambda (name rest) name))))
((eq? type 'soa) ((eq? type 'soa)
(call-with-values (call-with-values
@ -571,16 +651,16 @@
(if *debug* (display "parse-flags\n")) (if *debug* (display "parse-flags\n"))
(let ((v0 (list-ref message 2)) (let ((v0 (list-ref message 2))
(v1 (list-ref message 3))) (v1 (list-ref message 3)))
;; Check for error code: ;; Check for error code:
(let ((rcode (bitwise-and #xf (char->ascii v1))) (let ((rcode (bitwise-and #xf (char->ascii v1)))
(z (arithmetic-shift (bitwise-and 112 (char->ascii v1)) -4)) (z (arithmetic-shift (bitwise-and 112 (char->ascii v1)) -4))
(ra (arithmetic-shift (bitwise-and 64 (char->ascii v1)) -7)) (ra (arithmetic-shift (bitwise-and 64 (char->ascii v1)) -7))
(rd (bitwise-and 1 (char->ascii v0))) (rd (bitwise-and 1 (char->ascii v0)))
(tc (arithmetic-shift (bitwise-and 2 (char->ascii v0)) -1)) (tc (arithmetic-shift (bitwise-and 2 (char->ascii v0)) -1))
(aa (arithmetic-shift (bitwise-and 4 (char->ascii v0)) -2)) (aa (arithmetic-shift (bitwise-and 4 (char->ascii v0)) -2))
(opcode (arithmetic-shift (bitwise-and 120 (char->ascii v0)) -3)) (opcode (arithmetic-shift (bitwise-and 120 (char->ascii v0)) -3))
(qr (arithmetic-shift (bitwise-and 128 (char->ascii v0)) -7))) (qr (arithmetic-shift (bitwise-and 128 (char->ascii v0)) -7)))
(make-flags qr opcode aa tc rd ra z rcode)))) (make-flags qr opcode aa tc rd ra z rcode))))
;; parses a message-header. returns the header. ;; parses a message-header. returns the header.
@ -613,7 +693,7 @@
(lambda () (parse-n parse-rr start message (header:arc header))) (lambda () (parse-n parse-rr start message (header:arc header)))
(lambda (ars start) (lambda (ars start)
(if (not (null? start)) (if (not (null? start))
(error "parse: error parsing server message")) (signal 'parse-error))
(make-message header qds ans nss ars message))))))))))) (make-message header qds ans nss ars message)))))))))))
@ -629,14 +709,13 @@
(display "send-receive-message: bad reply id from server")) (display "send-receive-message: bad reply id from server"))
;; Check for error code: ;; Check for error code:
(let ((rcode (flags:rcode (parse-flags reply)))) (let ((rcode (flags:rcode (parse-flags reply))))
(if (not (zero? 0));rcode)) (if (not (zero? rcode))
(error "send-receive-message: error from server: ~A" (case rcode
(case rcode ((1) (signal 'dns-format-error))
((1) "format error") ((2) (signal 'dns-server-failure))
((2) "server failure") ((3) (signal 'dns-name-error))
((3) "name error") ((4) (signal 'dns-not-implemented))
((4) "not implemented") ((5) (signal 'dns-refused))))))
((5) "refused"))))))
;; #t if message is truncated (could happen via UDP) ;; #t if message is truncated (could happen via UDP)
(define (truncated? reply) (define (truncated? reply)
@ -667,7 +746,7 @@
(let ((len (octet-pair->number a b))) (let ((len (octet-pair->number a b)))
(let ((s (read-string len r))) (let ((s (read-string len r)))
(if (not (= len (string-length s))) (if (not (= len (string-length s)))
(error "send-receive-message: unexpected EOF from server")) (signal 'unexpected-eof-from-server))
(string->list s))))) (string->list s)))))
(lambda () (lambda ()
(close-socket socket))))))) (close-socket socket)))))))
@ -785,8 +864,7 @@
(try-recursive (try-recursive
(lambda (auth? nss) (lambda (auth? nss)
(if (or auth? (null? nss)) (if (or auth? (null? nss))
(error "dns-get-information: bad address (in combination with query-type)" (signal 'bad-address)
(question:name (car (message:questions (parse question)))))
(let* ((ns (and (eq? (rr:type (car nss)) 'a) (rr-data-a:ip (rr:data (car nss))))) (let* ((ns (and (eq? (rr:type (car nss)) 'a) (rr-data-a:ip (rr:data (car nss)))))
(dns-msg (if (and ns (dns-msg (if (and ns
(not (member ns tried)) (not (member ns tried))
@ -820,7 +898,7 @@
(cond (cond
((eof-object? l) ((eof-object? l)
(if (null? ns) (if (null? ns)
(error "dns-find-nameserver-list: no nameserver(s) found in /etc/resolv.conf") (signal 'no-nameservers)
ns)) ns))
((regexp-search (posix-string->regexp "nameserver[ ]+([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+)") l) ((regexp-search (posix-string->regexp "nameserver[ ]+([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+)") l)
=> (lambda (match) => (lambda (match)
@ -833,7 +911,7 @@
(define (dns-find-nameserver) (define (dns-find-nameserver)
(let ((ns (dns-find-nameserver-list))) (let ((ns (dns-find-nameserver-list)))
(if (null? ns) (if (null? ns)
(error "dns-find-nameserver: no nameserver found in /etc/resolv.conf") (signal 'no-nameservers)
(car ns)))) (car ns))))
@ -857,7 +935,7 @@
(enqueue! queue result) (enqueue! queue result)
(display "received reply from ")(display nameserver)(display ": ")(display result)(newline) (display "received reply from ")(display nameserver)(display ": ")(display result)(newline)
(release-lock lock))))) (release-lock lock)))))
(dns-find-nameserver-list)))) (dns-find-nameserver-list))))
(let loop ((count (length nameserver-list))) (let loop ((count (length nameserver-list)))
(obtain-lock lock) (obtain-lock lock)
@ -881,59 +959,80 @@
;; dns-lookup with more options than dns-lookup-* ;; dns-lookup with more options than dns-lookup-*
;; optional: nameserver could be passed to the function. ;; optional: nameserver could be passed to the function.
(define (dns-lookup name type . args) (define (dns-lookup name type . args)
(let* ((ip-string (ip-string->in-addr name)) (call-with-current-continuation
(question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address (lambda (exit)
(make-octet-query-message (random 256) ip-string type 'in) (with-handler
(make-octet-query-message (random 256) name type 'in))) (lambda (condition more)
(use-cache? #t) (dns-error-messages condition more)
(protocol 'udp) (exit #f))
(nameserver (check-args args)) (lambda ()
(check-answer (lambda (dns-msg) #t)) (let* ((ip-string (ip-string->in-addr name))
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer)) (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
(answers (message:answers (dns-message:reply dns-msg)))) (make-octet-query-message (random 256) ip-string type 'in)
(if (not (null? answers)) (make-octet-query-message (random 256) name type 'in)))
(for-each (lambda (x) (show-dns-message x)(newline)) answers) (use-cache? #t)
(display "no answers received - but resolved information in other sections.\n")) (protocol 'udp)
dns-msg)) (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 "no answers received - but resolved information in other sections.\n"))
dns-msg))))))
;; looks up a hostname, returns an ip. ;; looks up a hostname, returns an ip.
;; (dns-lookup-name <name> [nameserver]) ;; (dns-lookup-name <name> [nameserver])
(define (dns-lookup-name name . args) (define (dns-lookup-name name . args)
(let* ((ip-string (ip-string->in-addr name)) (call-with-current-continuation
(question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address (lambda (exit)
(error "dns-lookup-name: no valid hostname, suppose it is an ip") (with-handler
(make-octet-query-message (random 256) name 'a 'in))) (lambda (condition more)
(use-cache? #t) (dns-error-messages condition more)
(protocol 'udp) (exit #f))
(nameserver (check-args args)) (lambda ()
(check-answer (lambda (dns-msg) (let* ((ip-string (ip-string->in-addr name))
(let* ((reply (dns-message:reply dns-msg)) (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
(answers (message:answers reply))) (signal 'not-a-hostname)
(not (null? (filter-type answers 'a)))))) (make-octet-query-message (random 256) name 'a 'in)))
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer)) (use-cache? #t)
(answers (filter-type (message:answers (dns-message:reply dns-msg)) 'a))) (protocol 'udp)
(rr-data-a:ip (rr:data (car answers))))) (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))
(answers (filter-type (message:answers (dns-message:reply dns-msg)) 'a)))
(rr-data-a:ip (rr:data (car answers)))))))))
;; looks up an ip, returns a hostname ;; looks up an ip, returns a hostname
;; (dns-inverse-lookup <name> [nameserver]) ;; (dns-inverse-lookup <name> [nameserver])
(define (dns-inverse-lookup ip . args) (define (dns-inverse-lookup ip . args)
(let* ((ip-string (ip-string->in-addr ip)) (call-with-current-continuation
(question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address (lambda (exit)
(make-octet-query-message (random 256) ip-string 'ptr 'in) (with-handler
(error "dns-inverse-lookup: no valid ip"))) (lambda (condition more)
(use-cache? #t) (dns-error-messages condition more)
(protocol 'udp) (exit #f))
(nameserver (check-args args)) (lambda ()
(check-answer (lambda (dns-msg) (let* ((ip-string (ip-string->in-addr ip))
(let* ((reply (dns-message:reply dns-msg)) (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
(answers (message:answers reply))) (make-octet-query-message (random 256) ip-string 'ptr 'in)
(not (null? (filter-type answers 'ptr)))))) (signal 'not-a-ip)))
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer)) (use-cache? #t)
(answers (filter-type (message:answers (dns-message:reply dns-msg)) 'ptr))) (protocol 'udp)
(rr-data-ptr:name (rr:data (car answers))))) (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 'ptr))))))
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
(answers (filter-type (message:answers (dns-message:reply dns-msg)) 'ptr)))
(rr-data-ptr:name (rr:data (car answers)))))))))
(define dns-lookup-ip dns-inverse-lookup) (define dns-lookup-ip dns-inverse-lookup)
@ -942,27 +1041,34 @@
;; returns a list of nameservers ;; returns a list of nameservers
;; (dns-lookup-nameserver <name> [nameserver]) ;; (dns-lookup-nameserver <name> [nameserver])
(define (dns-lookup-nameserver name . args) (define (dns-lookup-nameserver name . args)
(let* ((ip-string (ip-string->in-addr name)) (call-with-current-continuation
(question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address (lambda (exit)
(error "dns-lookup-name: no valid hostname, suppose it is an ip") (with-handler
(make-octet-query-message (random 256) name 'ns 'in))) (lambda (condition more)
(use-cache? #t) (dns-error-messages condition more)
(protocol 'udp) (exit #f))
(nameserver (check-args args)) (lambda ()
(check-answer (lambda (dns-msg) (let* ((ip-string (ip-string->in-addr name))
(let* ((reply (dns-message:reply dns-msg)) (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
(answers (message:answers reply)) (signal 'not-a-hostname)
(nameservers (message:nameservers reply))) (make-octet-query-message (random 256) name 'ns 'in)))
(or (not (null? (filter-type nameservers 'soa))) (use-cache? #t)
(not (null? (filter-type answers 'ns))))))) (protocol 'udp)
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer)) (nameserver (check-args args))
(reply (dns-message:reply dns-msg)) (check-answer (lambda (dns-msg)
(soa (filter-type (message:nameservers reply) 'soa)) (let* ((reply (dns-message:reply dns-msg))
(nss (filter-type (message:answers reply) 'ns)) (answers (message:answers reply))
(add (filter-type (message:additionals reply) 'a))) (nameservers (message:nameservers reply)))
(if (null? nss) (or (not (null? (filter-type nameservers 'soa)))
(list (dns-lookup-name (rr-data-soa:mname (rr:data (car soa))))) (not (null? (filter-type answers 'ns)))))))
(map (lambda (elem) (rr-data-a:ip (rr:data elem))) add)))) (dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
(reply (dns-message:reply dns-msg))
(soa (filter-type (message:nameservers reply) 'soa))
(nss (filter-type (message:answers reply) 'ns))
(add (filter-type (message:additionals reply) 'a)))
(if (null? nss)
(list (dns-lookup-name (rr-data-soa:mname (rr:data (car soa)))))
(map (lambda (elem) (rr-data-a:ip (rr:data elem))) add))))))))
;; looks up a mail-exchanger for a hostname. ;; looks up a mail-exchanger for a hostname.
@ -971,36 +1077,43 @@
;; implementation based on RFC2821 ;; implementation based on RFC2821
;; (dns-lookup-mail-exchanger <name> [nameserver]) ;; (dns-lookup-mail-exchanger <name> [nameserver])
(define (dns-lookup-mail-exchanger name . args) (define (dns-lookup-mail-exchanger name . args)
(let* ((ip-string (ip-string->in-addr name)) (call-with-current-continuation
(question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address (lambda (exit)
(error "dns-lookup-name: no valid hostname, suppose it is an ip") (with-handler
(make-octet-query-message (random 256) name 'mx 'in))) (lambda (condition more)
(use-cache? #t) (dns-error-messages condition more)
(protocol 'tcp) (exit #f))
(nameserver (check-args args)) (lambda ()
(check-answer (lambda (dns-msg) (let* ((ip-string (ip-string->in-addr name))
(let* ((reply (dns-message:reply dns-msg)) (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
(answers (message:answers reply)) (signal 'not-a-hostname)
(nameservers (message:nameservers reply))) (make-octet-query-message (random 256) name 'mx 'in)))
(or (not (null? (filter-type answers 'mx))) (use-cache? #t)
(not (null? (filter-type answers 'cname))) (protocol 'tcp)
(not (null? (filter-type answers 'a))))))) (nameserver (check-args args))
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer)) (check-answer (lambda (dns-msg)
(reply (dns-message:reply dns-msg)) (let* ((reply (dns-message:reply dns-msg))
(mx (filter-type (message:answers reply) 'mx)) (answers (message:answers reply))
(soa (filter-type (message:nameservers reply) 'soa)) (nameservers (message:nameservers reply)))
(cname (filter-type (message:answers reply) 'cname)) (or (not (null? (filter-type answers 'mx)))
(a (filter-type (message:answers reply) 'a))) (not (null? (filter-type answers 'cname)))
(not (null? (filter-type answers 'a)))))))
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
(reply (dns-message:reply dns-msg))
(mx (filter-type (message:answers reply) 'mx))
(soa (filter-type (message:nameservers reply) 'soa))
(cname (filter-type (message:answers reply) 'cname))
(a (filter-type (message:answers reply) 'a)))
(cond (cond
((not (null? a)) ((not (null? a))
(list (rr-data-a:ip (rr:data (car a))))) (list (rr-data-a:ip (rr:data (car a)))))
((not (null? cname)) ((not (null? cname))
(dns-lookup-mail-exchanger (rr-data-cname:name (rr:data (car cname))))) (dns-lookup-mail-exchanger (rr-data-cname:name (rr:data (car cname)))))
((null? mx) ((null? mx)
(list (rr-data-soa:rname (rr:data (car soa))))) (list (rr-data-soa:rname (rr:data (car soa)))))
(else (else
(map (lambda (elem) (rr-data-mx:exchanger (rr:data elem))) (sort-by-preference mx)))))) (map (lambda (elem) (rr-data-mx:exchanger (rr:data elem))) (sort-by-preference mx))))))))))
@ -1010,99 +1123,99 @@
(let* ((d (let* ((d
(lambda (n s1 s2) (lambda (n s1 s2)
(letrec ((loop (lambda (n) (letrec ((loop (lambda (n)
(if (zero? n) (if (zero? n)
"" ""
(string-append " " (loop (- n 1))))))) (string-append " " (loop (- n 1)))))))
(display (loop n)) (display (loop n))
(display s1) (display s1)
(display ": ") (display ": ")
(display s2) (display s2)
(newline))))) (newline)))))
(cond (cond
((dns-message? dns-msg) ((dns-message? dns-msg)
(begin (begin
(d 0 "DNS-MESSAGE" "") (d 0 "DNS-MESSAGE" "")
(d 1 "QUERY" "")(show-dns-message (dns-message:query dns-msg))(newline) (d 1 "QUERY" "")(show-dns-message (dns-message:query dns-msg))(newline)
(d 1 "REPLY" "")(show-dns-message (dns-message:reply dns-msg))(newline) (d 1 "REPLY" "")(show-dns-message (dns-message:reply dns-msg))(newline)
(d 1 "CACHE?" (if (dns-message:cache? dns-msg) (d 1 "CACHE?" (if (dns-message:cache? dns-msg)
"found in cache" "found in cache"
"not found in cache")) "not found in cache"))
(d 1 "PROTOCOL" (let ((protocol (dns-message:protocol dns-msg))) (d 1 "PROTOCOL" (let ((protocol (dns-message:protocol dns-msg)))
(cond (cond
((eq? protocol 'tcp) "TCP") ((eq? protocol 'tcp) "TCP")
((eq? protocol 'udp) "UDP")))) ((eq? protocol 'udp) "UDP"))))
(d 1 "TRIED-NAMESERVERS" (if (> (length (dns-message:tried-nameservers dns-msg)) 1) (d 1 "TRIED-NAMESERVERS" (if (> (length (dns-message:tried-nameservers dns-msg)) 1)
(begin (begin
(display " had perform recursion: ") (display " had perform recursion: ")
(dns-message:tried-nameservers dns-msg)) (dns-message:tried-nameservers dns-msg))
(begin (begin
(display " without recursion: ") (display " without recursion: ")
(dns-message:tried-nameservers dns-msg)))))) (dns-message:tried-nameservers dns-msg))))))
((message? dns-msg) ((message? dns-msg)
(begin (begin
(d 2 "MESSAGE" "") (d 2 "MESSAGE" "")
(d 3 "Header " "")(show-dns-message (message:header dns-msg)) (d 3 "Header " "")(show-dns-message (message:header dns-msg))
(d 3 "Questions " "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:questions dns-msg)) (d 3 "Questions " "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:questions dns-msg))
(d 3 "Answers " "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:answers dns-msg)) (d 3 "Answers " "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:answers dns-msg))
(d 3 "Nameservers" "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:nameservers dns-msg)) (d 3 "Nameservers" "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:nameservers dns-msg))
(d 3 "Additionals" "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:additionals dns-msg)))) (d 3 "Additionals" "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:additionals dns-msg))))
((header? dns-msg) ((header? dns-msg)
(begin (begin
(d 4 "id" (header:id dns-msg)) (d 4 "id" (header:id dns-msg))
(d 4 "Flags" "")(show-dns-message (header:flags dns-msg)) (d 4 "Flags" "")(show-dns-message (header:flags dns-msg))
(d 4 "question-count " (header:qdc dns-msg)) (d 4 "question-count " (header:qdc dns-msg))
(d 4 "answer-count " (header:anc dns-msg)) (d 4 "answer-count " (header:anc dns-msg))
(d 4 "nameserver-count " (header:nsc dns-msg)) (d 4 "nameserver-count " (header:nsc dns-msg))
(d 4 "additional-count " (header:arc dns-msg)))) (d 4 "additional-count " (header:arc dns-msg))))
((flags? dns-msg) ((flags? dns-msg)
(begin (begin
(d 5 "querytype" (flags:querytype dns-msg)) (d 5 "querytype" (flags:querytype dns-msg))
(d 5 "opcode" (flags:opcode dns-msg)) (d 5 "opcode" (flags:opcode dns-msg))
(d 5 "auth" (flags:auth dns-msg)) (d 5 "auth" (flags:auth dns-msg))
(d 5 "trunc" (flags:trunc dns-msg)) (d 5 "trunc" (flags:trunc dns-msg))
(d 5 "recursiondesired" (flags:recursiondesired dns-msg)) (d 5 "recursiondesired" (flags:recursiondesired dns-msg))
(d 5 "recursionavailable" (flags:recursionavailable dns-msg)) (d 5 "recursionavailable" (flags:recursionavailable dns-msg))
(d 5 "z" (flags:z dns-msg)) (d 5 "z" (flags:z dns-msg))
(d 5 "rcode" (flags:rcode dns-msg)))) (d 5 "rcode" (flags:rcode dns-msg))))
((question? dns-msg) ((question? dns-msg)
(begin (begin
(d 4 "name " (question:name dns-msg)) (d 4 "name " (question:name dns-msg))
(d 4 "type " (question:type dns-msg)) (d 4 "type " (question:type dns-msg))
(d 4 "class" (question:class dns-msg)))) (d 4 "class" (question:class dns-msg))))
((rr? dns-msg) ((rr? dns-msg)
(begin (begin
(d 4 "name " (rr:name dns-msg)) (d 4 "name " (rr:name dns-msg))
(d 4 "type " (rr:type dns-msg)) (d 4 "type " (rr:type dns-msg))
(d 4 "class" (rr:class dns-msg)) (d 4 "class" (rr:class dns-msg))
(d 4 "ttl " (rr:ttl dns-msg)) (d 4 "ttl " (rr:ttl dns-msg))
(d 4 "data " "") (show-dns-message (rr:data dns-msg)))) (d 4 "data " "") (show-dns-message (rr:data dns-msg))))
((rr-data-a? dns-msg) ((rr-data-a? dns-msg)
(d 5 "ip " (rr-data-a:ip dns-msg))) (d 5 "ip " (rr-data-a:ip dns-msg)))
((rr-data-ns? dns-msg) ((rr-data-ns? dns-msg)
(d 5 "name " (rr-data-ns:name dns-msg))) (d 5 "name " (rr-data-ns:name dns-msg)))
((rr-data-cname? dns-msg) ((rr-data-cname? dns-msg)
(d 5 "name " (rr-data-cname:name dns-msg))) (d 5 "name " (rr-data-cname:name dns-msg)))
((rr-data-mx? dns-msg) ((rr-data-mx? dns-msg)
(begin (begin
(d 5 "preference " (rr-data-mx:preference dns-msg)) (d 5 "preference " (rr-data-mx:preference dns-msg))
(d 5 "exchanger " (rr-data-mx:exchanger dns-msg)))) (d 5 "exchanger " (rr-data-mx:exchanger dns-msg))))
((rr-data-ptr? dns-msg) ((rr-data-ptr? dns-msg)
(d 5 "name " (rr-data-ptr:name dns-msg))) (d 5 "name " (rr-data-ptr:name dns-msg)))
((rr-data-soa? dns-msg) ((rr-data-soa? dns-msg)
(begin (begin
(d 5 "mname " (rr-data-soa:mname dns-msg)) (d 5 "mname " (rr-data-soa:mname dns-msg))
(d 5 "rname " (rr-data-soa:rname dns-msg)) (d 5 "rname " (rr-data-soa:rname dns-msg))
(d 5 "serial " (rr-data-soa:serial dns-msg)) (d 5 "serial " (rr-data-soa:serial dns-msg))
(d 5 "refresh " (rr-data-soa:refresh dns-msg)) (d 5 "refresh " (rr-data-soa:refresh dns-msg))
(d 5 "expire " (rr-data-soa:expire dns-msg)) (d 5 "expire " (rr-data-soa:expire dns-msg))
(d 5 "minimum " (rr-data-soa:expire dns-msg)))) (d 5 "minimum " (rr-data-soa:expire dns-msg))))
;; ### ;; ###
((rr-data-hinfo? dns-msg) ((rr-data-hinfo? dns-msg)
(d 5 "data " (rr-data-hinfo:data dns-msg))) (d 5 "data " (rr-data-hinfo:data dns-msg)))
((rr-data-txt? dns-msg) ((rr-data-txt? dns-msg)
(d 5 "text " (rr-data-txt:text dns-msg))) (d 5 "text " (rr-data-txt:text dns-msg)))
((rr-data-wks? dns-msg) ((rr-data-wks? dns-msg)
(d 5 "data " (rr-data-wks:data dns-msg))) (d 5 "data " (rr-data-wks:data dns-msg)))
))) )))

2
modules.scm
View File

@ -485,6 +485,8 @@
defrec-package defrec-package
random random
queues queues
conditions
handle
sort sort
threads threads
locks) locks)