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

Make message-type and message-class an enumerated type.

This commit is contained in:
mainzelm 2003-01-16 20:08:14 +00:00
parent 1087695e37
commit b77a20674c
2 changed files with 94 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

173
scheme/lib/dns.scm
View File

@ -183,43 +183,44 @@
(define *on* (ascii->char 1))
;; message types
(define types
'((unknown 0); types, which are not yet implemented
(a 1) ; a host address
(ns 2) ; an authoritative name server
(md 3) ; (obsolete)
(mf 4) ; (obsolete)
(cname 5) ; the canonical name for an alias
(soa 6) ; marks the start of a zone of authority
(mb 7) ; (experimental)
(mg 8) ; (experimental)
(mr 9) ; (experimental)
(null 10) ; (experimental)
(wks 11) ; a well known service description
(ptr 12) ; a domain name pointer
(hinfo 13) ; host information
(minfo 14) ; (experimental)
(mx 15) ; mail exchange
(txt 16))) ; text strings
(define-enumerated-type message-type :message-type
message-type?
the-message-types
message-type-name
message-type-index
(unknown ; types, which are not yet implemented
a ; a host address
ns ; an authoritative name server
md ; (obsolete)
mf ; (obsolete)
cname ; the canonical name for an alias
soa ; marks the start of a zone of authority
mb ; (experimental)
mg ; (experimental)
mr ; (experimental)
null ; (experimental)
wks ; a well known service description
ptr ; a domain name pointer
hinfo ; host information
minfo ; (experimental)
mx ; mail exchange
txt)) ; text strings
;; message classes
(define classes
'((in 1) ; the Internet
(cs 2) ; (obsolete)
(ch 3) ; the CHAOS class
(hs 4))) ; Hesoid
(define-enumerated-type message-class :message-class
message-class?
the-message-classes
message-class-name
message-class-index
(placeholder ; this starts at 0...
in ; the Internet
cs ; (obsolete)
ch ; the CHAOS class
hs)) ; Hesoid
;;; -- useful stuff
;; assoc the other way round
(define (cossa i l)
(cond
((null? l) 'unknown)
((equal? (cadar l) i)
(car l))
(else (cossa i (cdr l)))))
;; number: 0<= x < 256
;; octet-pair: (char char)
;; octet-quad: (char char char char)
@ -453,14 +454,14 @@
;; makes a question (name, type, class)
(define (make-octet-question name type class)
(if (not (assoc type types))
(dns-error 'invalid-type))
(if (not (assoc class classes))
(if (not (message-type? type))
(dns-error 'invalid-type type))
(if (not (message-class? class))
(dns-error 'invalid-class))
(let* ((qname (name->octets name))
(qtype (number->octet-pair (cadr (assoc type types))))
(qclass (number->octet-pair (cadr (assoc class classes)))))
(qtype (number->octet-pair (message-type-index type)))
(qclass (number->octet-pair (message-class-index class))))
(append qname qtype qclass)))
@ -474,8 +475,8 @@
;; makes a resource record for ans, nss, ars (name, type, class, ttl, data)
(define (make-octet-rr name type class ttl rdata)
(let* ((name (name->octets name))
(type (number->octet-pair (cadr (assoc type types))))
(class (number->octet-pair (cadr (assoc class classes))))
(type (number->octet-pair (message-type-index type)))
(class (number->octet-pair (message-class-index class)))
(ttl (number->octet-quad ttl))
(rdlength (number->octet-pair (length rdata)))
(rdata rdata))
@ -598,9 +599,9 @@
(call-with-values
(lambda () (parse-name start message))
(lambda (name start)
(let ((type (car (cossa (octet-pair->number (car start) (cadr start)) types)))
(let ((type (vector-ref the-message-types (octet-pair->number (car start) (cadr start))))
(start (cddr start)))
(let ((class (car (cossa (octet-pair->number (car start) (cadr start)) classes)))
(let ((class (vector-ref the-message-classes (octet-pair->number (car start) (cadr start))))
(start (cddr start)))
(values (make-question name type class) start))))))
@ -609,9 +610,9 @@
(call-with-values
(lambda () (parse-name start message))
(lambda (name start)
(let ((type (car (cossa (octet-pair->number (car start) (cadr start)) types)))
(let ((type (vector-ref the-message-types (octet-pair->number (car start) (cadr start))))
(start (cddr start)))
(let ((class (car (cossa (octet-pair->number (car start) (cadr start)) classes)))
(let ((class (vector-ref the-message-classes (octet-pair->number (car start) (cadr start))))
(start (cddr start)))
(let ((ttl (octet-quad->number (car start) (cadr start)
(caddr start) (cadddr start)))
@ -690,31 +691,31 @@
(define (parse-rr-data type class data message)
(cond
((eq? type 'a)
((eq? type (message-type a))
(make-rr-data-a (octet-ip->address32 data)))
((eq? type 'ns)
((eq? type (message-type ns))
(make-rr-data-ns (call-with-values
(lambda () (parse-name data message))
(lambda (name rest) name))))
((eq? type 'cname)
((eq? type (message-type cname))
(make-rr-data-cname (call-with-values
(lambda () (parse-name data message))
(lambda (name rest) name))))
((eq? type 'mx)
((eq? type (message-type mx))
(make-rr-data-mx (octet-pair->number (car data) (cadr data))
(call-with-values
(lambda ()(parse-name (cddr data) message))
(lambda (name rest) name))))
((eq? type 'ptr)
((eq? type (message-type ptr))
(make-rr-data-ptr (call-with-values
(lambda () (parse-name data message))
(lambda (name rest) name))))
((eq? type 'soa)
((eq? type (message-type soa))
(call-with-values
(lambda () (parse-name data message))
(lambda (mname rest)
@ -733,13 +734,13 @@
(rest (cddddr rest)))
(make-rr-data-soa mname rname serial refresh retry expire minimum)))))))))))
((eq? type 'hinfo)
((eq? type (message-type hinfo))
(make-rr-data-hinfo (list->string data)))
((eq? type 'txt)
((eq? type (message-type txt))
(make-rr-data-txt (list->string data)))
((eq? type 'wks)
((eq? type (message-type wks))
(make-rr-data-wks data))
(else (list data))))
@ -819,7 +820,8 @@
((2) (dns-error 'dns-server-failure))
((3) (dns-error 'dns-name-error))
((4) (dns-error 'dns-not-implemented))
((5) (dns-error 'dns-refused))))))
((5) (dns-error 'dns-refused))
(else (error "this must not happend"))))))
;; #t if message is truncated (could happen via UDP)
(define (truncated? reply)
@ -950,7 +952,11 @@
((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)))
(format #f "~a;~a;~a;~a"
nameserver
name
(message-type-name type)
(message-class-name class))))
(define (lookup-cache qds nameserver)
(let* ((key (make-key qds nameserver))
@ -1032,7 +1038,7 @@
;; 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))
(filter (lambda (elem) (eq? (rr-type elem) (message-type a)))
(message-additionals (dns-message-reply dns-msg)))))
(lp (if (not (member hit-ns tried)) (cons hit-ns tried) tried)
(lset-union equal?
@ -1234,8 +1240,8 @@
(ip-string->in-addr-arpa (address32->ip-string name))
(ip-string->in-addr-arpa name)))
(question (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
(make-octet-query-message (random 256) maybe-ip-string type 'in)
(make-octet-query-message (random 256) name type 'in)))
(make-octet-query-message (random 256) maybe-ip-string type (message-class in))
(make-octet-query-message (random 256) name type (message-class in))))
(use-cache? #t)
(protocol 'udp)
(nameservers (check-args nameservers))
@ -1257,16 +1263,16 @@
(ip-string->in-addr-arpa name)))
(question (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
(dns-error 'not-a-hostname)
(make-octet-query-message (random 256) name 'a 'in)))
(make-octet-query-message (random 256) name (message-type a) (message-class in))))
(use-cache? #t)
(protocol 'udp)
(nameservers (check-args nameservers))
(check-answer (lambda (dns-msg)
(let* ((reply (dns-message-reply dns-msg))
(answers (message-answers reply)))
(not (null? (filter-type answers 'a))))))
(not (null? (filter-type answers (message-type a)))))))
(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)) (message-type a))))
(rr-data-a-ip (rr-data (car answers)))))
;; looks up an ip, returns a hostname
@ -1276,7 +1282,7 @@
(ip-string->in-addr-arpa (address32->ip-string ip))
(ip-string->in-addr-arpa ip)))
(question (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
(make-octet-query-message (random 256) maybe-ip-string 'ptr 'in)
(make-octet-query-message (random 256) maybe-ip-string (message-type ptr) (message-class in))
(dns-error 'not-a-ip)))
(use-cache? #t)
(protocol 'udp)
@ -1284,9 +1290,9 @@
(check-answer (lambda (dns-msg)
(let* ((reply (dns-message-reply dns-msg))
(answers (message-answers reply)))
(not (null? (filter-type answers 'ptr))))))
(not (null? (filter-type answers (message-type ptr)))))))
(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)) (message-type ptr))))
(rr-data-ptr-name (rr-data (car answers)))))
(define dns-inverse-lookup dns-lookup-ip)
@ -1300,7 +1306,7 @@
(ip-string->in-addr-arpa name)))
(question (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
(dns-error 'not-a-hostname)
(make-octet-query-message (random 256) name 'ns 'in)))
(make-octet-query-message (random 256) name (message-type ns) (message-class in))))
(use-cache? #t)
(protocol 'udp)
(nameservers (check-args nameservers))
@ -1308,13 +1314,13 @@
(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)))))))
(or (not (null? (filter-type nameservers (message-type soa))))
(not (null? (filter-type answers (message-type 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)))
(soa (filter-type (message-nameservers reply) (message-type soa)))
(nss (filter-type (message-answers reply) (message-type ns)))
(add (filter-type (message-additionals reply) (message-type 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))))
@ -1330,7 +1336,7 @@
(ip-string->in-addr-arpa name)))
(question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
(dns-error 'not-a-hostname)
(make-octet-query-message (random 256) name 'mx 'in)))
(make-octet-query-message (random 256) name (message-type mx) (message-class in))))
(use-cache? #t)
(protocol 'tcp)
(nameservers (check-args nameservers))
@ -1338,15 +1344,15 @@
(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)))))))
(or (not (null? (filter-type answers (message-type mx))))
(not (null? (filter-type answers (message-type cname))))
(not (null? (filter-type answers (message-type 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)))
(mx (filter-type (message-answers reply) (message-type mx)))
(soa (filter-type (message-nameservers reply)(message-type soa)))
(cname (filter-type (message-answers reply) (message-type cname)))
(a (filter-type (message-answers reply) (message-type a))))
(cond
((not (null? a))
@ -1421,13 +1427,13 @@
((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 "type " (message-type-name (question-type dns-msg)))
(d 4 "class" (message-class-name (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 "type "(message-type-name (rr-type dns-msg)))
(d 4 "class" (message-class-name (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)
@ -1510,14 +1516,13 @@
(dns-lookup-ip ip-addr))))))
(define (domains-for-search)
(let ((resolv.conf (parse-resolv.conf!)))
(cond ((assoc 'domain resolv.conf)
(cond ((assoc 'domain (resolv.conf))
=> (lambda (pair)
(list (cdr pair))))
((assoc 'search resolv.conf)
((assoc 'search (resolv.conf))
=> (lambda (pair)
(cdr pair)))
(else '()))))
(else '())))
(define (host-fqdn name-or-socket-address)
(if (socket-address? name-or-socket-address)

1
scheme/packages.scm
View File

@ -466,6 +466,7 @@
ascii
formats
signals
finite-types
define-record-types
random
queues