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
(define (filter-type list type)
(filter (lambda (rr)
(eq? (rr:type rr) type))
(eq? (rr-type rr) type))
list))
;; sorts a mx-rr-list by preference. needed for dns-lookup-mail-exchanger.
(define (sort-by-preference mx-list)
(sort-list mx-list
(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)
@ -486,61 +486,76 @@
;;; -- parsed message records
;;; -- dns-message: complete data-structure of an dns-lookup
(define-record dns-message
query
reply
cache?
protocol
tried-nameservers)
(define-record-type dns-message :dns-message
(make-dns-message query reply cache? protocol tried-nameservers)
dns-message?
(query dns-message-query)
(reply dns-message-reply)
(cache? dns-message-cache?)
(protocol dns-message-protocol)
(tried-nameservers dns-message-tried-nameservers))
;; message
(define-record message
header
questions
answers
nameservers
additionals
source)
(define-record-type message :message
(make-message header questions answers nameservers additionals source)
message?
(header message-header)
(questions message-questions)
(answers message-answers)
(nameservers message-nameservers)
(additionals message-additionals)
(source message-source))
;; header
(define-record header
id
flags
qdc
anc
nsc
arc)
(define-record-type header :header
(make-header id flags qdc anc nsc arc)
header?
(id header-id)
(flags header-flags)
(qdc header-qdc)
(anc header-anc)
(nsc header-nsc)
(arc header-arc))
;; flags
(define-record flags
querytype
opcode
auth
trunc
recursiondesired
recursionavailable
z
rcode)
(define-record-type flags :flags
(make-flags querytype opcode auth trunc recursiondesired recursionavailable
z rcode)
flags?
(querytype flags-querytype)
(opcode flags-opcode)
(auth flags-auth)
(trunc flags-trunc)
(recursiondesired flags-recursiondesired)
(recursionavailable flags-recursionavailable)
(z flags-z)
(rcode flags-rcode))
;; question
(define-record question
name
type
class)
(define-record-type question :question
(make-question name type class)
question?
(name question-name)
(type question-type)
(class question-class))
;; rr
(define-record rr
name
type
class
ttl
data)
;;type rr
(define-record-type rr :rr
(make-rr name type class ttl data)
rr?
(name rr-name)
(type rr-type)
(class rr-class)
(ttl rr-ttl)
(data rr-data))
;; cache
(define-record cache
answer
ttl
time)
(define-record-type cache :cache
(make-cache answer ttl time)
cache?
(answer cache-answer)
(ttl cache-ttl)
(time cache-time))
;;; -- message parser
@ -615,43 +630,61 @@
;;; -- rr-data-type records
(define-record rr-data-a
ip)
(define-record-type rr-data-a :rr-data-a
(make-rr-data-a ip)
rr-data-a?
(ip rr-data-a-ip))
(define-record rr-data-ns
name)
(define-record-type rr-data-ns :rr-data-ns
(make-rr-data-ns name)
rr-data-ns?
(name rr-data-ns-name))
(define-record rr-data-cname
name)
(define-record-type rr-data-cname :rr-data-cname
(make-rr-data-cname name)
rr-data-cname?
(name rr-data-cname-name))
;; ###
;; hinfo not correctly implemented, trying to find examples
(define-record rr-data-hinfo
data)
(define-record-type rr-data-hinfo :rr-data-hinfo
(make-rr-data-hinfo data)
rr-data-hinfo?
(data rr-data-hinfo-data))
(define-record rr-data-mx
preference
exchanger)
(define-record-type rr-data-mx :rr-data-mx
(make-rr-data-mx preference exchanger)
rr-data-mx?
(preference rr-data-mx-preference)
(exchanger rr-data-mx-exchanger))
(define-record rr-data-ptr
name)
(define-record-type rr-data-ptr :rr-data-ptr
(make-rr-data-ptr name)
rr-data-ptr?
(name rr-data-ptr-name))
(define-record rr-data-soa
mname
rname
serial
refresh
retry
expire
minimum)
(define-record-type rr-data-soa :rr-data-soa
(make-rr-data-soa mname rname serial refresh retry expire minimum)
rr-data-soa?
(mname rr-data-soa-mname)
(rname rr-data-soa-rname)
(serial rr-data-soa-serial)
(refresh rr-data-soa-refresh)
(retry rr-data-soa-retry)
(expire rr-data-soa-expire)
(minimum rr-data-soa-minimum))
;; ### same as hinfo
(define-record rr-data-txt
text)
(define-record-type rr-data-txt :rr-data-txt
(make-rr-data-txt text)
rr-data-txt?
(text rr-data-txt-text))
;; ### same as hinfo and txt
(define-record rr-data-wks
data)
(define-record-type rr-data-wks :rr-data-wks
(make-rr-data-wks data)
rr-data-wks?
(data rr-data-wks-data))
;;
@ -753,16 +786,16 @@
(let* ((header (parse-header message))
(start (list-tail message 12)))
(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)
(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)
(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)
(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)
(if (not (null? start))
(dns-error 'parse-error))
@ -779,7 +812,7 @@
(char=? (cadr reply) (cadr query))))
(display "send-receive-message: bad reply id from server"))
;; Check for error code:
(let ((rcode (flags:rcode (parse-flags reply))))
(let ((rcode (flags-rcode (parse-flags reply))))
(if (not (zero? rcode))
(case rcode
((1) (dns-error 'dns-format-error))
@ -790,7 +823,7 @@
;; #t if message is truncated (could happen via UDP)
(define (truncated? reply)
(let ((trunc (flags:trunc (parse-flags reply))))
(let ((trunc (flags-trunc (parse-flags reply))))
(= trunc 1)))
;; connects to nameserver and sends and receives messages. returns the reply.
@ -897,26 +930,26 @@
(lambda (dns-msg)
(cond
((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)
(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:additionals 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-additionals dns-msg))
minimum)
((rr? dns-msg)
(cond
((not minimum) (set! minimum (rr:ttl dns-msg)))
((not minimum) (set! minimum (rr-ttl dns-msg)))
(else
(if (and (not minimum) (> minimum (rr:ttl dns-msg)))
(set! minimum (rr:ttl dns-msg))))))))))
(if (and (not minimum) (> minimum (rr-ttl dns-msg)))
(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))))
((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)
@ -925,7 +958,7 @@
(cond
((and found-data
;; 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)
(else #f))))
@ -942,7 +975,7 @@
nss-with-no-reply)))
(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))
(if (null? ns)
(receive (reply-msg hit-ns nss-with-no-reply)
@ -956,7 +989,7 @@
(cond ((lookup-cache qds (car ns))
=> (lambda (found-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
nameservers)))
(else (lp (cdr ns))))))))
@ -991,16 +1024,16 @@
dns-msg
(let ((auth? (not
(zero?
(flags:auth (header:flags
(message:header
(dns-message:reply dns-msg))))))))
(flags-auth (header-flags
(message-header
(dns-message-reply dns-msg))))))))
(if auth?
(dns-error '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)))))
(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
@ -1205,7 +1238,7 @@
(nameservers (check-args nameservers))
(check-answer (lambda (dns-msg) #t))
(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))
(for-each (lambda (x) (show-dns-message x)(newline)) answers)
;;; TODO remove display
@ -1226,12 +1259,12 @@
(protocol 'udp)
(nameservers (check-args nameservers))
(check-answer (lambda (dns-msg)
(let* ((reply (dns-message:reply dns-msg))
(answers (message:answers reply)))
(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 nameservers check-answer))
(answers (filter-type (message:answers (dns-message:reply dns-msg)) 'a)))
(rr-data-a:ip (rr:data (car answers)))))
(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
;; (dns-inverse-lookup <name> [nameserver])
@ -1246,12 +1279,12 @@
(protocol 'udp)
(nameservers (check-args nameservers))
(check-answer (lambda (dns-msg)
(let* ((reply (dns-message:reply dns-msg))
(answers (message:answers reply)))
(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 nameservers check-answer))
(answers (filter-type (message:answers (dns-message:reply dns-msg)) 'ptr)))
(rr-data-ptr:name (rr:data (car answers)))))
(answers (filter-type (message-answers (dns-message-reply dns-msg)) 'ptr)))
(rr-data-ptr-name (rr-data (car answers)))))
(define dns-inverse-lookup dns-lookup-ip)
@ -1269,19 +1302,19 @@
(protocol 'udp)
(nameservers (check-args nameservers))
(check-answer (lambda (dns-msg)
(let* ((reply (dns-message:reply dns-msg))
(answers (message:answers reply))
(nameservers (message:nameservers reply)))
(let* ((reply (dns-message-reply dns-msg))
(answers (message-answers reply))
(nameservers (message-nameservers reply)))
(or (not (null? (filter-type nameservers 'soa)))
(not (null? (filter-type answers 'ns)))))))
(dns-msg (dns-get-information question use-cache? protocol nameservers 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)))
(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))))
(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.
;; returns a list of mail-exchanger, sorted by their preference
@ -1299,28 +1332,28 @@
(protocol 'tcp)
(nameservers (check-args nameservers))
(check-answer (lambda (dns-msg)
(let* ((reply (dns-message:reply dns-msg))
(answers (message:answers reply))
(nameservers (message:nameservers reply)))
(let* ((reply (dns-message-reply dns-msg))
(answers (message-answers reply))
(nameservers (message-nameservers reply)))
(or (not (null? (filter-type answers 'mx)))
(not (null? (filter-type answers 'cname)))
(not (null? (filter-type answers 'a)))))))
(dns-msg (dns-get-information question use-cache? protocol nameservers 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)))
(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
((not (null? a))
(list (rr-data-a:ip (rr:data (car a)))))
(list (rr-data-a-ip (rr-data (car a)))))
((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)
(list (rr-data-soa:rname (rr:data (car soa)))))
(list (rr-data-soa-rname (rr-data (car soa)))))
(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
(define (show-dns-message dns-msg)
@ -1340,87 +1373,87 @@
((dns-message? dns-msg)
(begin
(d 0 "DNS-MESSAGE" "")
(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 "CACHE?" (if (dns-message:cache? dns-msg)
(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 "CACHE?" (if (dns-message-cache? dns-msg)
"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
((eq? protocol 'tcp) "TCP")
((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
(display " had perform recursion: ")
(dns-message:tried-nameservers dns-msg))
(dns-message-tried-nameservers dns-msg))
(begin
(display " without recursion: ")
(dns-message:tried-nameservers dns-msg))))))
(dns-message-tried-nameservers dns-msg))))))
((message? dns-msg)
(begin
(d 2 "MESSAGE" "")
(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 "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 "Additionals" "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:additionals 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 "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 "Additionals" "")(for-each (lambda (x) (show-dns-message x)(newline)) (message-additionals dns-msg))))
((header? dns-msg)
(begin
(d 4 "id" (header:id dns-msg))
(d 4 "Flags" "")(show-dns-message (header:flags dns-msg))
(d 4 "question-count " (header:qdc dns-msg))
(d 4 "answer-count " (header:anc dns-msg))
(d 4 "nameserver-count " (header:nsc dns-msg))
(d 4 "additional-count " (header:arc dns-msg))))
(d 4 "id" (header-id dns-msg))
(d 4 "Flags" "")(show-dns-message (header-flags dns-msg))
(d 4 "question-count " (header-qdc dns-msg))
(d 4 "answer-count " (header-anc dns-msg))
(d 4 "nameserver-count " (header-nsc dns-msg))
(d 4 "additional-count " (header-arc dns-msg))))
((flags? dns-msg)
(begin
(d 5 "querytype" (flags:querytype dns-msg))
(d 5 "opcode" (flags:opcode dns-msg))
(d 5 "auth" (flags:auth dns-msg))
(d 5 "trunc" (flags:trunc dns-msg))
(d 5 "recursiondesired" (flags:recursiondesired dns-msg))
(d 5 "recursionavailable" (flags:recursionavailable dns-msg))
(d 5 "z" (flags:z dns-msg))
(d 5 "rcode" (flags:rcode dns-msg))))
(d 5 "querytype" (flags-querytype dns-msg))
(d 5 "opcode" (flags-opcode dns-msg))
(d 5 "auth" (flags-auth dns-msg))
(d 5 "trunc" (flags-trunc dns-msg))
(d 5 "recursiondesired" (flags-recursiondesired dns-msg))
(d 5 "recursionavailable" (flags-recursionavailable dns-msg))
(d 5 "z" (flags-z dns-msg))
(d 5 "rcode" (flags-rcode dns-msg))))
((question? dns-msg)
(begin
(d 4 "name " (question:name dns-msg))
(d 4 "type " (question:type dns-msg))
(d 4 "class" (question:class dns-msg))))
(d 4 "name " (question-name dns-msg))
(d 4 "type " (question-type dns-msg))
(d 4 "class" (question-class dns-msg))))
((rr? dns-msg)
(begin
(d 4 "name " (rr:name dns-msg))
(d 4 "type " (rr:type dns-msg))
(d 4 "class" (rr:class dns-msg))
(d 4 "ttl " (rr:ttl dns-msg))
(d 4 "data " "") (show-dns-message (rr:data dns-msg))))
(d 4 "name " (rr-name dns-msg))
(d 4 "type " (rr-type dns-msg))
(d 4 "class" (rr-class dns-msg))
(d 4 "ttl " (rr-ttl dns-msg))
(d 4 "data " "") (show-dns-message (rr-data 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)
(d 5 "name " (rr-data-ns:name dns-msg)))
(d 5 "name " (rr-data-ns-name 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)
(begin
(d 5 "preference " (rr-data-mx:preference dns-msg))
(d 5 "exchanger " (rr-data-mx:exchanger dns-msg))))
(d 5 "preference " (rr-data-mx-preference dns-msg))
(d 5 "exchanger " (rr-data-mx-exchanger 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)
(begin
(d 5 "mname " (rr-data-soa:mname dns-msg))
(d 5 "rname " (rr-data-soa:rname dns-msg))
(d 5 "serial " (rr-data-soa:serial dns-msg))
(d 5 "refresh " (rr-data-soa:refresh dns-msg))
(d 5 "expire " (rr-data-soa:expire dns-msg))
(d 5 "minimum " (rr-data-soa:expire dns-msg))))
(d 5 "mname " (rr-data-soa-mname dns-msg))
(d 5 "rname " (rr-data-soa-rname dns-msg))
(d 5 "serial " (rr-data-soa-serial dns-msg))
(d 5 "refresh " (rr-data-soa-refresh dns-msg))
(d 5 "expire " (rr-data-soa-expire dns-msg))
(d 5 "minimum " (rr-data-soa-expire 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)
(d 5 "text " (rr-data-txt:text dns-msg)))
(d 5 "text " (rr-data-txt-text 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
formats
signals
defrec-package
define-record-types
random
queues
conditions