+ 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
parent
4898196703
commit
73629e6baa
|
|
@ -399,43 +399,14 @@
|
|||
(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)
|
||||
|
|
@ -443,25 +414,24 @@
|
|||
(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)
|
||||
(make-header
|
||||
id
|
||||
(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)
|
||||
(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
|
||||
(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-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)
|
||||
(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,8 +1298,8 @@
|
|||
(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))
|
||||
(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)
|
||||
|
|
@ -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
|
||||
(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-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)
|
||||
(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
|
||||
(query (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))))
|
||||
(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)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue