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

+ octet generation for messages only just before the message is sent 

+ two additional constructors for query messages
+ rename "question" to "query" when variable hold a dns-message
This commit is contained in:
mainzelm 2003-01-22 12:27:50 +00:00
parent 4898196703
commit 73629e6baa
1 changed files with 118 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

221
scheme/lib/dns.scm
View File

@ -399,69 +399,39 @@
(map (lambda (elem) (force-ip elem)) names))
;;; -- message constructors: encode to octet-messages
;; makes an message header
(define (make-octet-header id header-flags question-count answer-count
nameserver-count additional-count)
(let* ((header-id (number->octet-pair id))
(header-question-count (number->octet-pair question-count))
(header-answer-count (number->octet-pair answer-count))
(header-nameserver-count (number->octet-pair nameserver-count))
(header-additional-count (number->octet-pair additional-count)))
(append header-id
header-flags
header-question-count
header-answer-count
header-nameserver-count
header-additional-count)))
(define (make-octet-header-flags qr opcode aa tc rd ra zero response-code)
(list
(ascii->char (+ (arithmetic-shift qr 7)
(arithmetic-shift opcode 3)
(arithmetic-shift aa 2)
(arithmetic-shift tc 1)
rd))
(ascii->char (+ (arithmetic-shift ra 7)
(arithmetic-shift zero 4)
response-code))))
;; a standard query header, usefull for most queries
(define (make-std-octet-query-header id question-count)
(let* ((qr 0) ; querytype: query 0, response 1
(define (make-std-query-header id question-count)
(let* ((qr 'query) ; querytype: query 0, response 1
(opcode 0) ; opcode: query 0, iquery 1 (OBSOLETE), status 2
(aa 0) ; authorative answer (in answers only)
(tc 0) ; truncation (size matters only with UDP)
(rd 1) ; recursion desired: nameserver pursues the query recursivly (optional)
(ra 0) ; recursion available (in answers only)
(aa #f) ; authorative answer (in answers only)
(tc #f) ; truncation (size matters only with UDP)
(rd #t) ; recursion desired: nameserver pursues the query recursivly (optional)
(ra #f) ; recursion available (in answers only)
(zero 0) ; future use
(response-code 0) ; response code: error conditions (in answers only)
(question-count question-count)
(answer-count 0) ; answer count (in answers only)
(nameserver-count 0) ; name server resources (in answers only)
(additional-count 0)) ; additional records (in answers only)
(make-octet-header id
(make-octet-header-flags qr opcode aa tc rd ra zero response-code)
question-count answer-count nameserver-count additional-count)))
;; makes a question (name, type, class)
(define (make-octet-question name type class)
(let* ((qname (name->octets name))
(qtype (number->octet-pair (message-type-number type)))
(qclass (number->octet-pair (message-class-number class))))
(append qname qtype qclass)))
(make-header
id
(make-flags qr opcode aa tc rd ra zero response-code)
question-count answer-count nameserver-count additional-count)))
;; makes a query-message (header and question only)
(define (make-octet-query-message id name type class)
(append
(make-std-octet-query-header id 1)
(make-octet-question name type class)))
;; TODO does this really work for several questions as well?
(define (make-query-dns-message header . questions)
(make-message header questions '() '() '()
(apply
append
(header->octets header)
(map question->octets questions))))
(define (make-simple-query-dns-message id name type class)
(make-query-dns-message (make-std-query-header id 1)
(make-question name type class)))
;; makes a resource record for ans, nss, ars (name, type, class, ttl, data)
(define (make-octet-rr name type class ttl rdata)
@ -510,6 +480,24 @@
(nameserver-count header-nameserver-count)
(additional-count header-additional-count))
;;; -- message constructors: encode to octet-messages
;; makes an message header
(define (header->octets header)
(let* ((header-id (number->octet-pair (header-id header)))
(header-question-count (number->octet-pair (header-question-count header)))
(header-answer-count (number->octet-pair (header-answer-count header)))
(header-nameserver-count (number->octet-pair
(header-nameserver-count header)))
(header-additional-count (number->octet-pair
(header-additional-count header))))
(append header-id
(flags->octets (header-flags header))
header-question-count
header-answer-count
header-nameserver-count
header-additional-count)))
;; flags
(define-record-type flags :flags
(make-flags query-type opcode authoritative? truncated? recursion-desired?
@ -543,6 +531,23 @@
((4) 'dns-not-implemented)
((5) 'dns-refused))))
(define (flags->octets flags)
(define (boolean->0/1 bool)
(if bool 1 0))
(list
(ascii->char (+ (arithmetic-shift
(if (eq? (flags-query-type flags) 'query) 0 1) 7)
(arithmetic-shift (flags-opcode flags) 3)
(arithmetic-shift
(boolean->0/1 (flags-authoritative? flags)) 2)
(arithmetic-shift
(boolean->0/1 (flags-truncated? flags)) 1)
(boolean->0/1 (flags-recursion-desired? flags))))
(ascii->char (+ (arithmetic-shift
(boolean->0/1 (flags-recursion-available? flags)) 7)
(arithmetic-shift (flags-zero flags) 4)
(flags-response-code flags)))))
;; question
(define-record-type question :question
@ -552,6 +557,15 @@
(type question-type)
(class question-class))
;; makes a question (name, type, class)
(define (question->octets q)
(let* ((qname (name->octets (question-name q)))
(qtype (number->octet-pair
(message-type-number (question-type q))))
(qclass (number->octet-pair
(message-class-number (question-class q)))))
(append qname qtype qclass)))
;;type rr
(define-record-type rr :rr
(make-rr name type class ttl data)
@ -825,19 +839,16 @@
;; checks if the received reply is valid. returns #t or error-msg.
(define (reply-acceptable? reply query)
;; Check correct id
(if (not (and (char=? (car reply) (car query))
(char=? (cadr reply) (cadr query))))
;; TODO replace display
(display "send-receive-message: bad reply id from server"))
(if (not (= (header-id (message-header reply))
(header-id (message-header query))))
;; TODO replace error
(error "send-receive-message: bad reply id from server"))
;; Check for error code:
(let ((response-code (flags-response-code (parse-flags reply))))
(let ((response-code (flags-response-code
(header-flags (message-header reply)))))
(if (not (eq? response-code 'dns-no-error))
(dns-error response-code))))
;; #t if message is truncated (could happen via UDP)
(define (truncated? reply)
(flags-truncated? (parse-flags reply)))
;; connects to nameserver and sends and receives messages. returns the reply.
;; here: via TCP
(define (send-receive-message-tcp nameservers query)
@ -864,9 +875,10 @@
(sock (cdr (assoc w wport-socket-alist))))
(if (not (connect-socket-successful? sock))
(dns-error 'bad-nameserver hit-ns))
(let ((query-string (list->string query))
(let ((query-string
(add-size-tag (list->string (message-source query))))
(r (socket:inport sock)))
(display (list->string (add-size-tag query)) w)
(display (list->string query-string) w)
(force-output w)
(let ((a (read-char r))
(b (read-char r)))
@ -874,13 +886,13 @@
(let ((s (read-string len r)))
(if (not (= len (string-length s)))
(dns-error 'unexpected-eof-from-server))
(values (string->list s)
(values (parse (string->list s))
hit-ns
(delete hit-ns nameservers))))))))
(lambda ()
(for-each close-socket sockets)))))
(reply-acceptable? reply query)
(values (parse reply)
(values reply
hit-ns
other-nss)))
@ -901,7 +913,7 @@
(lambda ()
'nothing-to-be-done-before)
(lambda ()
(let ((query-string (list->string query))
(let ((query-string (list->string (message-source query)))
(rsv (list->vector rs))
(rport-nameserver-alist (map cons rs nameservers))
(rport-socket-alist (map cons rs sockets)))
@ -913,15 +925,15 @@
(if (not (connect-socket-successful? (cdr (assoc r rport-socket-alist))))
(dns-error 'bad-nameserver hit-ns))
;;; 512 is the maximum udp-message size:
(values (string->list (read-string/partial 512 r))
(values (parse (string->list (read-string/partial 512 r)))
hit-ns
(delete hit-ns nameservers)))))
(lambda ()
(for-each close-socket sockets)))))
(reply-acceptable? reply query)
(if (truncated? reply)
(if (flags-truncated? (header-flags (message-header reply)))
(send-receive-message-tcp nameservers query)
(values (parse reply)
(values reply
hit-ns
other-nss))))
@ -981,47 +993,47 @@
(define (update-cache! key entry)
(table-set! cache key entry))
(define (dns-query-no-cache question protocol nameservers tried)
(define (dns-query-no-cache query protocol nameservers tried)
;; returns new retrieved data
(receive (dns-msg hit-ns nss-with-no-reply)
(send-receive-message nameservers question protocol)
(send-receive-message nameservers query protocol)
(values
(make-dns-message (parse question) dns-msg #f protocol (reverse tried))
(make-dns-message query dns-msg #f protocol (reverse tried))
hit-ns
nss-with-no-reply)))
(define (dns-query-with-cache question protocol nameservers tried)
(let ((qds (message-questions (parse question))))
(define (dns-query-with-cache query protocol nameservers tried)
(let ((qds (message-questions query)))
(let lp ((ns nameservers))
(if (null? ns)
(receive (reply-msg hit-ns nss-with-no-reply)
(send-receive-message nameservers question protocol)
(send-receive-message nameservers query protocol)
(update-cache! (make-key qds hit-ns)
(make-cache reply-msg (find-shortest-ttl reply-msg) (time)))
;; returns new retrieved data and updates cache
(values (make-dns-message (parse question) reply-msg #f protocol (reverse tried))
(values (make-dns-message query reply-msg #f protocol (reverse tried))
hit-ns
nss-with-no-reply))
(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 query (cache-answer found-data) #t protocol '())
#f
nameservers)))
(else (lp (cdr ns))))))))
(define (send-receive-message nameservers question protocol)
(define (send-receive-message nameservers query protocol)
((cond
((eq? protocol 'tcp) send-receive-message-tcp)
((eq? protocol 'udp) send-receive-message-udp))
nameservers question))
nameservers query))
;; makes a dns-query. optional cache-check.
;; returns a dns-message with cache-flag and either cache-data or new received data.
(define (dns-query/cache question use-cache? protocol nameservers tried)
(define (dns-query/cache query use-cache? protocol nameservers tried)
(if use-cache?
(dns-query-with-cache question protocol nameservers tried)
(dns-query-no-cache question protocol nameservers tried)))
(dns-query-with-cache query protocol nameservers tried)
(dns-query-no-cache query protocol nameservers tried)))
;; dns and recursion
;; recursion means, if the demanded information is not available from the
@ -1030,12 +1042,12 @@
;; this feature is technically optional (RFC 1035).
;; dns-get-information implements the resovler-side recursion.
;; it returns a dns-message
(define (dns-get-information question use-cache? protocol nameservers check-answer)
(define (dns-get-information query use-cache? protocol nameservers check-answer)
(let lp ((tried '()) (nss nameservers))
(if (null? nss)
(dns-error 'bad-address)
(receive (dns-msg hit-ns nss-with-no-reply)
(dns-query/cache question use-cache? protocol nss tried)
(dns-query/cache query use-cache? protocol nss tried)
(if (check-answer dns-msg)
dns-msg
(let ((auth? (flags-authoritative? (header-flags
@ -1247,14 +1259,15 @@
(let* ((maybe-ip-string (if (address32? name)
(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 (message-class in))
(make-octet-query-message (random 256) name type (message-class in))))
(query (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
(make-simple-query-dns-message
(random 256) maybe-ip-string type (message-class in))
(make-simple-query-dns-message (random 256) name type (message-class in))))
(use-cache? #t)
(protocol 'udp)
(nameservers (check-args nameservers))
(check-answer (lambda (dns-msg) #t))
(dns-msg (dns-get-information question use-cache? protocol nameservers check-answer))
(dns-msg (dns-get-information query use-cache? protocol nameservers check-answer))
(answers (message-answers (dns-message-reply dns-msg))))
dns-msg))
@ -1265,9 +1278,9 @@
(let* ((maybe-ip-string (if (address32? name)
(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
(dns-error 'not-a-hostname)
(make-octet-query-message (random 256) name (message-type a) (message-class in))))
(query (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
(dns-error 'not-a-hostname)
(make-simple-query-dns-message (random 256) name (message-type a) (message-class in))))
(use-cache? #t)
(protocol 'udp)
(nameservers (check-args nameservers))
@ -1275,7 +1288,7 @@
(let* ((reply (dns-message-reply dns-msg))
(answers (message-answers reply)))
(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 query use-cache? protocol nameservers check-answer))
(answers (filter-type (message-answers (dns-message-reply dns-msg)) (message-type a))))
(rr-data-a-ip (rr-data (car answers)))))
@ -1285,9 +1298,9 @@
(let* ((maybe-ip-string (if (address32? ip)
(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 (message-type ptr) (message-class in))
(dns-error 'not-a-ip)))
(query (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
(make-simple-query-dns-message (random 256) maybe-ip-string (message-type ptr) (message-class in))
(dns-error 'not-a-ip)))
(use-cache? #t)
(protocol 'udp)
(nameservers (check-args nameservers))
@ -1295,7 +1308,7 @@
(let* ((reply (dns-message-reply dns-msg))
(answers (message-answers reply)))
(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 query use-cache? protocol nameservers check-answer))
(answers (filter-type (message-answers (dns-message-reply dns-msg)) (message-type ptr))))
(rr-data-ptr-name (rr-data (car answers)))))
@ -1308,9 +1321,10 @@
(let* ((maybe-ip-string (if (address32? name)
(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
(dns-error 'not-a-hostname)
(make-octet-query-message (random 256) name (message-type ns) (message-class in))))
(query (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
(dns-error 'not-a-hostname)
(make-simple-query-dns-message
(random 256) name (message-type ns) (message-class in))))
(use-cache? #t)
(protocol 'udp)
(nameservers (check-args nameservers))
@ -1320,7 +1334,7 @@
(nameservers (message-nameservers reply)))
(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))
(dns-msg (dns-get-information query use-cache? protocol nameservers check-answer))
(reply (dns-message-reply dns-msg))
(soa (filter-type (message-nameservers reply) (message-type soa)))
(nss (filter-type (message-answers reply) (message-type ns)))
@ -1338,9 +1352,10 @@
(let* ((ip-string (if (address32? name)
(ip-string->in-addr-arpa (address32->ip-string 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
(dns-error 'not-a-hostname)
(make-octet-query-message (random 256) name (message-type mx) (message-class in))))
(query (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
(dns-error 'not-a-hostname)
(make-simple-query-dns-message
(random 256) name (message-type mx) (message-class in))))
(use-cache? #t)
(protocol 'tcp)
(nameservers (check-args nameservers))
@ -1351,7 +1366,7 @@
(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))
(dns-msg (dns-get-information query use-cache? protocol nameservers check-answer))
(reply (dns-message-reply dns-msg))
(mx (filter-type (message-answers reply) (message-type mx)))
(soa (filter-type (message-nameservers reply)(message-type soa)))