diff --git a/scheme/lib/dns.scm b/scheme/lib/dns.scm index e4a04cb..6a4da50 100644 --- a/scheme/lib/dns.scm +++ b/scheme/lib/dns.scm @@ -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)))