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