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

1
scheme/packages.scm
View File

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