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

Replaced define-record by define-record-type

This commit is contained in:
mainzelm 2003-01-15 12:17:54 +00:00
parent 3f398e3ba7
commit f9474b7a16
2 changed files with 208 additions and 175 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

381
scheme/lib/dns.scm
View File

@ -385,14 +385,14 @@
;; filters types in a list of rrs ;; filters types in a list of rrs
(define (filter-type list type) (define (filter-type list type)
(filter (lambda (rr) (filter (lambda (rr)
(eq? (rr:type rr) type)) (eq? (rr-type rr) type))
list)) list))
;; sorts a mx-rr-list by preference. needed for dns-lookup-mail-exchanger. ;; sorts a mx-rr-list by preference. needed for dns-lookup-mail-exchanger.
(define (sort-by-preference mx-list) (define (sort-by-preference mx-list)
(sort-list mx-list (sort-list mx-list
(lambda (a b) (lambda (a b)
(< (rr-data-mx:preference (rr:data a)) (rr-data-mx:preference (rr:data b)))))) (< (rr-data-mx-preference (rr-data a)) (rr-data-mx-preference (rr-data b))))))
;; returns a IP if available (additonal type-a processing) ;; returns a IP if available (additonal type-a processing)
@ -486,61 +486,76 @@
;;; -- parsed message records ;;; -- parsed message records
;;; -- dns-message: complete data-structure of an dns-lookup ;;; -- dns-message: complete data-structure of an dns-lookup
(define-record dns-message (define-record-type dns-message :dns-message
query (make-dns-message query reply cache? protocol tried-nameservers)
reply dns-message?
cache? (query dns-message-query)
protocol (reply dns-message-reply)
tried-nameservers) (cache? dns-message-cache?)
(protocol dns-message-protocol)
(tried-nameservers dns-message-tried-nameservers))
;; message ;; message
(define-record message (define-record-type message :message
header (make-message header questions answers nameservers additionals source)
questions message?
answers (header message-header)
nameservers (questions message-questions)
additionals (answers message-answers)
source) (nameservers message-nameservers)
(additionals message-additionals)
(source message-source))
;; header ;; header
(define-record header (define-record-type header :header
id (make-header id flags qdc anc nsc arc)
flags header?
qdc (id header-id)
anc (flags header-flags)
nsc (qdc header-qdc)
arc) (anc header-anc)
(nsc header-nsc)
(arc header-arc))
;; flags ;; flags
(define-record flags (define-record-type flags :flags
querytype (make-flags querytype opcode auth trunc recursiondesired recursionavailable
opcode z rcode)
auth flags?
trunc (querytype flags-querytype)
recursiondesired (opcode flags-opcode)
recursionavailable (auth flags-auth)
z (trunc flags-trunc)
rcode) (recursiondesired flags-recursiondesired)
(recursionavailable flags-recursionavailable)
(z flags-z)
(rcode flags-rcode))
;; question ;; question
(define-record question (define-record-type question :question
name (make-question name type class)
type question?
class) (name question-name)
(type question-type)
(class question-class))
;; rr ;;type rr
(define-record rr (define-record-type rr :rr
name (make-rr name type class ttl data)
type rr?
class (name rr-name)
ttl (type rr-type)
data) (class rr-class)
(ttl rr-ttl)
(data rr-data))
;; cache ;; cache
(define-record cache (define-record-type cache :cache
answer (make-cache answer ttl time)
ttl cache?
time) (answer cache-answer)
(ttl cache-ttl)
(time cache-time))
;;; -- message parser ;;; -- message parser
@ -615,43 +630,61 @@
;;; -- rr-data-type records ;;; -- rr-data-type records
(define-record rr-data-a (define-record-type rr-data-a :rr-data-a
ip) (make-rr-data-a ip)
rr-data-a?
(ip rr-data-a-ip))
(define-record rr-data-ns (define-record-type rr-data-ns :rr-data-ns
name) (make-rr-data-ns name)
rr-data-ns?
(name rr-data-ns-name))
(define-record rr-data-cname (define-record-type rr-data-cname :rr-data-cname
name) (make-rr-data-cname name)
rr-data-cname?
(name rr-data-cname-name))
;; ### ;; ###
;; hinfo not correctly implemented, trying to find examples ;; hinfo not correctly implemented, trying to find examples
(define-record rr-data-hinfo (define-record-type rr-data-hinfo :rr-data-hinfo
data) (make-rr-data-hinfo data)
rr-data-hinfo?
(data rr-data-hinfo-data))
(define-record rr-data-mx (define-record-type rr-data-mx :rr-data-mx
preference (make-rr-data-mx preference exchanger)
exchanger) rr-data-mx?
(preference rr-data-mx-preference)
(exchanger rr-data-mx-exchanger))
(define-record rr-data-ptr (define-record-type rr-data-ptr :rr-data-ptr
name) (make-rr-data-ptr name)
rr-data-ptr?
(name rr-data-ptr-name))
(define-record rr-data-soa (define-record-type rr-data-soa :rr-data-soa
mname (make-rr-data-soa mname rname serial refresh retry expire minimum)
rname rr-data-soa?
serial (mname rr-data-soa-mname)
refresh (rname rr-data-soa-rname)
retry (serial rr-data-soa-serial)
expire (refresh rr-data-soa-refresh)
minimum) (retry rr-data-soa-retry)
(expire rr-data-soa-expire)
(minimum rr-data-soa-minimum))
;; ### same as hinfo ;; ### same as hinfo
(define-record rr-data-txt (define-record-type rr-data-txt :rr-data-txt
text) (make-rr-data-txt text)
rr-data-txt?
(text rr-data-txt-text))
;; ### same as hinfo and txt ;; ### same as hinfo and txt
(define-record rr-data-wks (define-record-type rr-data-wks :rr-data-wks
data) (make-rr-data-wks data)
rr-data-wks?
(data rr-data-wks-data))
;; ;;
@ -753,16 +786,16 @@
(let* ((header (parse-header message)) (let* ((header (parse-header message))
(start (list-tail message 12))) (start (list-tail message 12)))
(call-with-values (call-with-values
(lambda () (parse-n parse-question start message (header:qdc header))) (lambda () (parse-n parse-question start message (header-qdc header)))
(lambda (qds start) (lambda (qds start)
(call-with-values (call-with-values
(lambda () (parse-n parse-rr start message (header:anc header))) (lambda () (parse-n parse-rr start message (header-anc header)))
(lambda (ans start) (lambda (ans start)
(call-with-values (call-with-values
(lambda () (parse-n parse-rr start message (header:nsc header))) (lambda () (parse-n parse-rr start message (header-nsc header)))
(lambda (nss start) (lambda (nss start)
(call-with-values (call-with-values
(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))
(dns-error 'parse-error)) (dns-error 'parse-error))
@ -779,7 +812,7 @@
(char=? (cadr reply) (cadr query)))) (char=? (cadr reply) (cadr query))))
(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? rcode)) (if (not (zero? rcode))
(case rcode (case rcode
((1) (dns-error 'dns-format-error)) ((1) (dns-error 'dns-format-error))
@ -790,7 +823,7 @@
;; #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 1))) (= trunc 1)))
;; connects to nameserver and sends and receives messages. returns the reply. ;; connects to nameserver and sends and receives messages. returns the reply.
@ -897,26 +930,26 @@
(lambda (dns-msg) (lambda (dns-msg)
(cond (cond
((dns-message? dns-msg) ((dns-message? dns-msg)
(find-shortest-ttl-1 (dns-message:reply dns-msg))) (find-shortest-ttl-1 (dns-message-reply dns-msg)))
((message? dns-msg) ((message? dns-msg)
(for-each (lambda (x) (find-shortest-ttl-1 x)) (message:answers dns-msg)) (for-each (lambda (x) (find-shortest-ttl-1 x)) (message-answers dns-msg))
(for-each (lambda (x) (find-shortest-ttl-1 x)) (message:nameservers dns-msg)) (for-each (lambda (x) (find-shortest-ttl-1 x)) (message-nameservers dns-msg))
(for-each (lambda (x) (find-shortest-ttl-1 x)) (message:additionals dns-msg)) (for-each (lambda (x) (find-shortest-ttl-1 x)) (message-additionals dns-msg))
minimum) minimum)
((rr? dns-msg) ((rr? dns-msg)
(cond (cond
((not minimum) (set! minimum (rr:ttl dns-msg))) ((not minimum) (set! minimum (rr-ttl dns-msg)))
(else (else
(if (and (not minimum) (> minimum (rr:ttl dns-msg))) (if (and (not minimum) (> minimum (rr-ttl dns-msg)))
(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) (define (make-key qds nameserver)
(let*;; cache-key relevant data (let*;; cache-key relevant data
((name (question:name (car qds))) ((name (question-name (car qds)))
(type (question:type (car qds))) (type (question-type (car qds)))
(class (question:class (car qds)))) (class (question-class (car qds))))
(format #f "~a;~a;~a;~a" nameserver name type class))) (format #f "~a;~a;~a;~a" nameserver name type class)))
(define (lookup-cache qds nameserver) (define (lookup-cache qds nameserver)
@ -925,7 +958,7 @@
(cond (cond
((and found-data ((and found-data
;; checks if cached-data is still valid ;; checks if cached-data is still valid
(< (time) (+ (cache:time found-data) (cache:ttl found-data)))) (< (time) (+ (cache-time found-data) (cache-ttl found-data))))
found-data) found-data)
(else #f)))) (else #f))))
@ -942,7 +975,7 @@
nss-with-no-reply))) nss-with-no-reply)))
(define (dns-query-with-cache question protocol nameservers tried) (define (dns-query-with-cache question protocol nameservers tried)
(let ((qds (message:questions (parse question)))) (let ((qds (message-questions (parse question))))
(let lp ((ns nameservers)) (let lp ((ns nameservers))
(if (null? ns) (if (null? ns)
(receive (reply-msg hit-ns nss-with-no-reply) (receive (reply-msg hit-ns nss-with-no-reply)
@ -956,7 +989,7 @@
(cond ((lookup-cache qds (car ns)) (cond ((lookup-cache qds (car ns))
=> (lambda (found-data) => (lambda (found-data)
;; returns cached data ;; returns cached data
(values (make-dns-message (parse question) (cache:answer found-data) #t protocol '()) (values (make-dns-message (parse question) (cache-answer found-data) #t protocol '())
#f #f
nameservers))) nameservers)))
(else (lp (cdr ns)))))))) (else (lp (cdr ns))))))))
@ -991,16 +1024,16 @@
dns-msg dns-msg
(let ((auth? (not (let ((auth? (not
(zero? (zero?
(flags:auth (header:flags (flags-auth (header-flags
(message:header (message-header
(dns-message:reply dns-msg)))))))) (dns-message-reply dns-msg))))))))
(if auth? (if auth?
(dns-error 'bad-address) (dns-error 'bad-address)
;; other nameservers names are found in the nameserver-part, ;; other nameservers names are found in the nameserver-part,
;; but their ip-adresses are found in the additonal-rrs ;; but their ip-adresses are found in the additonal-rrs
(let ((other-nameservers (let ((other-nameservers
(filter (lambda (elem) (eq? (rr:type elem) 'a)) (filter (lambda (elem) (eq? (rr-type elem) 'a))
(message:additionals (dns-message:reply dns-msg))))) (message-additionals (dns-message-reply dns-msg)))))
(lp (if (not (member hit-ns tried)) (cons hit-ns tried) tried) (lp (if (not (member hit-ns tried)) (cons hit-ns tried) tried)
(lset-union equal? (lset-union equal?
nss-with-no-reply nss-with-no-reply
@ -1205,7 +1238,7 @@
(nameservers (check-args nameservers)) (nameservers (check-args nameservers))
(check-answer (lambda (dns-msg) #t)) (check-answer (lambda (dns-msg) #t))
(dns-msg (dns-get-information question use-cache? protocol nameservers check-answer)) (dns-msg (dns-get-information question use-cache? protocol nameservers check-answer))
(answers (message:answers (dns-message:reply dns-msg)))) (answers (message-answers (dns-message-reply dns-msg))))
(if (not (null? answers)) (if (not (null? answers))
(for-each (lambda (x) (show-dns-message x)(newline)) answers) (for-each (lambda (x) (show-dns-message x)(newline)) answers)
;;; TODO remove display ;;; TODO remove display
@ -1226,12 +1259,12 @@
(protocol 'udp) (protocol 'udp)
(nameservers (check-args nameservers)) (nameservers (check-args nameservers))
(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 nameservers 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)))))
;; looks up an ip, returns a hostname ;; looks up an ip, returns a hostname
;; (dns-inverse-lookup <name> [nameserver]) ;; (dns-inverse-lookup <name> [nameserver])
@ -1246,12 +1279,12 @@
(protocol 'udp) (protocol 'udp)
(nameservers (check-args nameservers)) (nameservers (check-args nameservers))
(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 'ptr)))))) (not (null? (filter-type answers 'ptr))))))
(dns-msg (dns-get-information question use-cache? protocol nameservers check-answer)) (dns-msg (dns-get-information question use-cache? protocol nameservers check-answer))
(answers (filter-type (message:answers (dns-message:reply dns-msg)) 'ptr))) (answers (filter-type (message-answers (dns-message-reply dns-msg)) 'ptr)))
(rr-data-ptr:name (rr:data (car answers))))) (rr-data-ptr-name (rr-data (car answers)))))
(define dns-inverse-lookup dns-lookup-ip) (define dns-inverse-lookup dns-lookup-ip)
@ -1269,19 +1302,19 @@
(protocol 'udp) (protocol 'udp)
(nameservers (check-args nameservers)) (nameservers (check-args nameservers))
(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))
(nameservers (message:nameservers reply))) (nameservers (message-nameservers reply)))
(or (not (null? (filter-type nameservers 'soa))) (or (not (null? (filter-type nameservers 'soa)))
(not (null? (filter-type answers 'ns))))))) (not (null? (filter-type answers 'ns)))))))
(dns-msg (dns-get-information question use-cache? protocol nameservers check-answer)) (dns-msg (dns-get-information question use-cache? protocol nameservers check-answer))
(reply (dns-message:reply dns-msg)) (reply (dns-message-reply dns-msg))
(soa (filter-type (message:nameservers reply) 'soa)) (soa (filter-type (message-nameservers reply) 'soa))
(nss (filter-type (message:answers reply) 'ns)) (nss (filter-type (message-answers reply) 'ns))
(add (filter-type (message:additionals reply) 'a))) (add (filter-type (message-additionals reply) 'a)))
(if (null? nss) (if (null? nss)
(list (dns-lookup-name (rr-data-soa:mname (rr:data (car soa))))) (list (dns-lookup-name (rr-data-soa-mname (rr-data (car soa)))))
(map (lambda (elem) (rr-data-a:ip (rr:data elem))) add)))) (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.
;; returns a list of mail-exchanger, sorted by their preference ;; returns a list of mail-exchanger, sorted by their preference
@ -1299,28 +1332,28 @@
(protocol 'tcp) (protocol 'tcp)
(nameservers (check-args nameservers)) (nameservers (check-args nameservers))
(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))
(nameservers (message:nameservers reply))) (nameservers (message-nameservers reply)))
(or (not (null? (filter-type answers 'mx))) (or (not (null? (filter-type answers 'mx)))
(not (null? (filter-type answers 'cname))) (not (null? (filter-type answers 'cname)))
(not (null? (filter-type answers 'a))))))) (not (null? (filter-type answers 'a)))))))
(dns-msg (dns-get-information question use-cache? protocol nameservers check-answer)) (dns-msg (dns-get-information question use-cache? protocol nameservers check-answer))
(reply (dns-message:reply dns-msg)) (reply (dns-message-reply dns-msg))
(mx (filter-type (message:answers reply) 'mx)) (mx (filter-type (message-answers reply) 'mx))
(soa (filter-type (message:nameservers reply) 'soa)) (soa (filter-type (message-nameservers reply) 'soa))
(cname (filter-type (message:answers reply) 'cname)) (cname (filter-type (message-answers reply) 'cname))
(a (filter-type (message:answers reply) 'a))) (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))))))
;;; pretty-prints a dns-msg ;;; pretty-prints a dns-msg
(define (show-dns-message dns-msg) (define (show-dns-message dns-msg)
@ -1340,87 +1373,87 @@
((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
scheme/packages.scm
View File

@ -445,7 +445,7 @@
ascii ascii
formats formats
signals signals
defrec-package define-record-types
random random
queues queues
conditions conditions