complete revision of the PLT-dns-resolver.
it nearly fully implements the rfc1035: - resolver-side recursion - cache - following types: a, ns, cname, hinfo, mx, ptr, soa, txt - in-addr.arpa (get hostname by ip) each dns-lookup returns a dns-message record.
This commit is contained in:
cresh
parent
9b916db28e
commit
6f9f67f484
826
dns.scm
826
dns.scm
|
|
@ -1,100 +1,317 @@
|
|||
;; open string-table big-util(?) ascii format signals random
|
||||
;
|
||||
; dns.scm
|
||||
;
|
||||
; Implementation of the RFC1035
|
||||
; domain names - implementation and specification
|
||||
; based on the PLT-implementation.
|
||||
;
|
||||
; Marcus Crestani <crestani@informatik.uni-tuebingen.de>
|
||||
; Copyright (c) 2002 Marcus Crestani
|
||||
;
|
||||
|
||||
|
||||
;;; should debug-msgs be printed out?
|
||||
(define *debug* #f)
|
||||
|
||||
|
||||
;;; -- globals and types
|
||||
|
||||
;; off
|
||||
(define *nul* (ascii->char 0))
|
||||
|
||||
;; on
|
||||
(define *on* (ascii->char 1))
|
||||
|
||||
;; message types
|
||||
(define types
|
||||
'((a 1)
|
||||
(ns 2)
|
||||
(md 3)
|
||||
(mf 4)
|
||||
(cname 5)
|
||||
(soa 6)
|
||||
(mb 7)
|
||||
(mg 8)
|
||||
(mr 9)
|
||||
(null 10)
|
||||
(wks 11)
|
||||
(ptr 12)
|
||||
(hinfo 13)
|
||||
(minfo 14)
|
||||
(mx 15)
|
||||
(txt 16)))
|
||||
'((a 1) ; a host address
|
||||
(ns 2) ; an authoritative name server
|
||||
(md 3) ; (obsolete)
|
||||
(mf 4) ; (obsolete)
|
||||
(cname 5) ; the canonical name for an alias
|
||||
(soa 6) ; marks the start of a zone of authority
|
||||
(mb 7) ; (experimental)
|
||||
(mg 8) ; (experimental)
|
||||
(mr 9) ; (experimental)
|
||||
(null 10) ; (experimental)
|
||||
(wks 11) ; a well known service description
|
||||
(ptr 12) ; a domain name pointer
|
||||
(hinfo 13) ; host information
|
||||
(minfo 14) ; mailbox or mail list information
|
||||
(mx 15) ; mail exchange
|
||||
(txt 16))) ; text strings
|
||||
|
||||
;; message classes
|
||||
(define classes
|
||||
'((in 1)
|
||||
(cs 2)
|
||||
(ch 3)
|
||||
(hs 4)))
|
||||
'((in 1) ; the Internet
|
||||
(cs 2) ; (obsolete)
|
||||
(ch 3) ; the CHAOS class
|
||||
(hs 4))) ; Hesoid
|
||||
|
||||
|
||||
;;; -- useful stuff
|
||||
|
||||
;; assoc the other way round
|
||||
(define (cossa i l)
|
||||
(if *debug* (display "cossa\n"))
|
||||
(cond
|
||||
((null? l) #f)
|
||||
((equal? (cadar l) i)
|
||||
(car l))
|
||||
(else (cossa i (cdr l)))))
|
||||
|
||||
;; encodes numbers (16bit) to octets
|
||||
(define (number->octet-pair n)
|
||||
(if *debug* (display "number->octet-pair\n"))
|
||||
(list (ascii->char (arithmetic-shift n -8))
|
||||
(ascii->char (modulo n 256))))
|
||||
|
||||
;; decodes octets to numbers (16bit)
|
||||
(define (octet-pair->number a b)
|
||||
(if *debug* (display "octet-pair->number\n"))
|
||||
(+ (arithmetic-shift (char->ascii a) 8)
|
||||
(char->ascii b)))
|
||||
|
||||
;; encodes numbers (32bit) to octets, needed for ttl
|
||||
(define (number->octet-quad n)
|
||||
(if *debug* (display "number->octet-quad\n"))
|
||||
(list (ascii->char (arithmetic-shift n -24))
|
||||
(ascii->char (modulo (arithmetic-shift n -16) 256))
|
||||
(ascii->char (modulo (arithmetic-shift n -8) 256))
|
||||
(ascii->char (modulo n 256))))
|
||||
|
||||
;; decodes octets to numbers, needed for 32bit ttl
|
||||
(define (octet-quad->number a b c d)
|
||||
(if *debug* (display "octet-quad->number\n"))
|
||||
(+ (arithmetic-shift (char->ascii a) 24)
|
||||
(arithmetic-shift (char->ascii b) 16)
|
||||
(arithmetic-shift (char->ascii c) 8)
|
||||
(char->ascii d)))
|
||||
|
||||
;; encodes a domain-name string to octets
|
||||
(define (name->octets s)
|
||||
(define (encode-portion s)
|
||||
(cons
|
||||
(ascii->char (string-length s))
|
||||
(string->list s)))
|
||||
|
||||
(if *debug* (display "name->octets\n"))
|
||||
(let loop ((s s))
|
||||
(cond
|
||||
((string-match "^([^.]*)\\.(.*)" s)
|
||||
((regexp-search (posix-string->regexp "^([^.]*)\\.(.*)") s)
|
||||
=> (lambda (match)
|
||||
(append
|
||||
(encode-portion (match:substring match 1))
|
||||
(loop (match:substring match 2)))))
|
||||
(else
|
||||
(append
|
||||
(encode-portion s)
|
||||
(list *nul*))))))
|
||||
|
||||
(define (make-std-query-header id question-count)
|
||||
(append
|
||||
(number->octet-pair id)
|
||||
(list *on* *nul*) ; Opcode & flags (recusive flag set)
|
||||
(number->octet-pair question-count)
|
||||
(number->octet-pair 0)
|
||||
(number->octet-pair 0)
|
||||
(number->octet-pair 0)))
|
||||
|
||||
(define (make-query id name type class)
|
||||
(append
|
||||
(make-std-query-header id 1)
|
||||
(name->octets name)
|
||||
(number->octet-pair (cadr (assoc type types)))
|
||||
(number->octet-pair (cadr (assoc class classes)))))
|
||||
(if (= 0 (string-length s))
|
||||
(list *nul*)
|
||||
(append
|
||||
(encode-portion s)
|
||||
(list *nul*)))))))
|
||||
|
||||
;; for tcp: message has to be tagged with its length
|
||||
(define (add-size-tag m)
|
||||
(if *debug* (display "add-size-tag\n"))
|
||||
(append (number->octet-pair (length m)) m))
|
||||
|
||||
(define (rr-data rr)
|
||||
(cadddr (cdr rr)))
|
||||
;; converts an octeted-ip to an human readable ip-string
|
||||
(define (ip->string s)
|
||||
(if *debug* (display "ip->string\n"))
|
||||
(format #f
|
||||
"~a.~a.~a.~a"
|
||||
(char->ascii (list-ref s 0))
|
||||
(char->ascii (list-ref s 1))
|
||||
(char->ascii (list-ref s 2))
|
||||
(char->ascii (list-ref s 3))))
|
||||
|
||||
(define (rr-type rr)
|
||||
(cadr rr))
|
||||
;; converts an ip-string to octets
|
||||
(define (string->ip s)
|
||||
(if *debug* (display "string->ip\n"))
|
||||
(let loop ((s s)
|
||||
(result '()))
|
||||
(cond
|
||||
((regexp-search (posix-string->regexp "^([^.]*)\\.(.*)") s)
|
||||
=> (lambda (match)
|
||||
(loop (match:substring match 2) (append result (list (ascii->char (string->number (match:substring match 1))))))))
|
||||
(else
|
||||
(append result (list (ascii->char (string->number s))))))))
|
||||
|
||||
(define (rr-name rr)
|
||||
(car rr))
|
||||
;; calculates a "random" number, needed for message-ids
|
||||
(define random
|
||||
(let ((crank (make-random (modulo (time) (- (expt 2 27) 1)))))
|
||||
(lambda (limit)
|
||||
(quotient (* (modulo (crank) 314159265)
|
||||
limit)
|
||||
314159265))))
|
||||
|
||||
(define (parse-name start reply)
|
||||
;; returns a in-addr.arpa name-string or #f (needed to resolver hostname by ip)
|
||||
(define (ip-string->in-addr s)
|
||||
(if *debug* (display "ip-string->in-addr\n"))
|
||||
(let loop ((s s)
|
||||
(count 0)
|
||||
(result ""))
|
||||
(cond
|
||||
((regexp-search (posix-string->regexp "^([^.]*)\\.(.*)") s)
|
||||
=> (lambda (match)
|
||||
(let* ((portion (match:substring match 1))
|
||||
(number (string->number portion)))
|
||||
(if (and number (< number 256))
|
||||
(loop (match:substring match 2) (+ count 1) (string-append portion "." result))
|
||||
#f))))
|
||||
(else
|
||||
(let ((number (string->number s)))
|
||||
(and number
|
||||
(< number 256)
|
||||
(= count 3)
|
||||
(string-append s "." result "in-addr.arpa")))))))
|
||||
|
||||
|
||||
|
||||
;;; -- message constructors: encode to octet-messages
|
||||
|
||||
;; makes an message header
|
||||
(define (make-octet-header id qr opcode aa tc rd ra z rcode qdcount ancount nscount arcount)
|
||||
(if *debug* (display "make-octet-header\n"))
|
||||
(let* ((header-id (number->octet-pair id))
|
||||
(header-flags (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 z 4)
|
||||
rcode))))
|
||||
(header-qdcount (number->octet-pair qdcount))
|
||||
(header-ancount (number->octet-pair ancount))
|
||||
(header-nscount (number->octet-pair nscount))
|
||||
(header-arcount (number->octet-pair arcount)))
|
||||
(append header-id
|
||||
header-flags
|
||||
header-qdcount
|
||||
header-ancount
|
||||
header-nscount
|
||||
header-arcount)))
|
||||
|
||||
|
||||
;; a standard query header, usefull for most queries
|
||||
(define (make-std-octet-query-header id question-count)
|
||||
(if *debug* (display "make-std-octet-query-header\n"))
|
||||
(let* ((qr 0) ; 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)
|
||||
(z 0) ; future use
|
||||
(rcode 0) ; response code: error conditions (in answers only)
|
||||
(qdcount question-count)
|
||||
(ancount 0) ; answer count (in answers only)
|
||||
(nscount 0) ; name server resources (in answers only)
|
||||
(arcount 0)) ; additional records (in answers only)
|
||||
|
||||
(make-octet-header id qr opcode aa tc rd ra z rcode qdcount ancount nscount arcount)))
|
||||
|
||||
|
||||
;; makes a question (name, type, class)
|
||||
(define (make-octet-question name type class)
|
||||
(if *debug* (display "make-octet-question\n"))
|
||||
(if (not (assoc type types))
|
||||
(error "make-octet-question: invalid DNS query type ~a" type))
|
||||
(if (not (assoc class classes))
|
||||
(error "make-octet-question: invalid DNS query class ~a" class))
|
||||
|
||||
(let* ((qname (name->octets name))
|
||||
(qtype (number->octet-pair (cadr (assoc type types))))
|
||||
(qclass (number->octet-pair (cadr (assoc class classes)))))
|
||||
(append qname qtype qclass)))
|
||||
|
||||
|
||||
;; makes a query-message (header and question only)
|
||||
(define (make-octet-query-message id name type class)
|
||||
(if *debug* (display "make-octet-query-message\n"))
|
||||
(append
|
||||
(make-std-octet-query-header id 1)
|
||||
(make-octet-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)
|
||||
(if *debug* (display "make-octet-rr\n"))
|
||||
(let* ((name (name->octets name))
|
||||
(type (number->octet-pair (cadr (assoc type types))))
|
||||
(class (number->octet-pair (cadr (assoc class classes))))
|
||||
(ttl (number->octet-quad ttl))
|
||||
(rdlength (number->octet-pair (length rdata)))
|
||||
(rdata rdata))
|
||||
(append name type class ttl rdlength rdata)))
|
||||
|
||||
|
||||
|
||||
;;; -- parsed message records
|
||||
|
||||
;;; -- dns-message: complete data-structure of an dns-lookup
|
||||
(define-record dns-message
|
||||
query
|
||||
reply
|
||||
cache?
|
||||
tried-nameservers)
|
||||
|
||||
;; message
|
||||
(define-record message
|
||||
header
|
||||
questions
|
||||
answers
|
||||
nameservers
|
||||
additionals
|
||||
source)
|
||||
|
||||
;; header
|
||||
(define-record header
|
||||
id
|
||||
flags
|
||||
qdc
|
||||
anc
|
||||
nsc
|
||||
arc)
|
||||
|
||||
;; flags
|
||||
(define-record flags
|
||||
querytype
|
||||
opcode
|
||||
auth
|
||||
trunc
|
||||
recursiondesired
|
||||
recursionavailable
|
||||
z
|
||||
rcode)
|
||||
|
||||
;; question
|
||||
(define-record question
|
||||
name
|
||||
type
|
||||
class)
|
||||
|
||||
;; rr
|
||||
(define-record rr
|
||||
name
|
||||
type
|
||||
class
|
||||
ttl
|
||||
data)
|
||||
|
||||
;; cache
|
||||
(define-record cache
|
||||
answer
|
||||
ttl
|
||||
time)
|
||||
|
||||
;;; -- message parser
|
||||
|
||||
;; parses a domain-name in an message. returns the name and the rest of the message.
|
||||
(define (parse-name start message)
|
||||
(if *debug* (display "parse-name\n"))
|
||||
(let ((v (char->ascii (car start))))
|
||||
(cond
|
||||
((zero? v)
|
||||
|
|
@ -108,7 +325,7 @@
|
|||
(cond
|
||||
((zero? len)
|
||||
(call-with-values
|
||||
(lambda () (parse-name start reply))
|
||||
(lambda () (parse-name start message))
|
||||
(lambda (s start)
|
||||
(let ((s0 (list->string (reverse! accum))))
|
||||
(values (if s
|
||||
|
|
@ -123,13 +340,27 @@
|
|||
(let ((offset (+ (arithmetic-shift (bitwise-and #x3f v) 8)
|
||||
(char->ascii (cadr start)))))
|
||||
(call-with-values
|
||||
(lambda () (parse-name (list-tail reply offset) reply))
|
||||
(lambda () (parse-name (list-tail message offset) message))
|
||||
(lambda (s ignore-start)
|
||||
(values s (cddr start)))))))))
|
||||
|
||||
(define (parse-rr start reply)
|
||||
;; parses a question in a message. returns the question and the rest of the message.
|
||||
(define (parse-question start message)
|
||||
(if *debug* (display "parse-question\n"))
|
||||
(call-with-values
|
||||
(lambda () (parse-name start reply))
|
||||
(lambda () (parse-name start message))
|
||||
(lambda (name start)
|
||||
(let ((type (car (cossa (octet-pair->number (car start) (cadr start)) types)))
|
||||
(start (cddr start)))
|
||||
(let ((class (car (cossa (octet-pair->number (car start) (cadr start)) classes)))
|
||||
(start (cddr start)))
|
||||
(values (make-question name type class) start))))))
|
||||
|
||||
;; parses a resourcerecord in a message. returns the rr and the rest of the message.
|
||||
(define (parse-rr start message)
|
||||
(if *debug* (display "parse-rr\n"))
|
||||
(call-with-values
|
||||
(lambda () (parse-name start message))
|
||||
(lambda (name start)
|
||||
(let ((type (car (cossa (octet-pair->number (car start) (cadr start)) types)))
|
||||
(start (cddr start)))
|
||||
|
|
@ -140,50 +371,160 @@
|
|||
(start (cddddr start)))
|
||||
(let ((len (octet-pair->number (car start) (cadr start)))
|
||||
(start (cddr start)))
|
||||
; Extract next len bytes for data:
|
||||
;; Extract next len bytes of data:
|
||||
(let loop ((len len)
|
||||
(start start)
|
||||
(accum '()))
|
||||
(if (zero? len)
|
||||
(values (list name type class ttl (reverse! accum))
|
||||
start)
|
||||
(values (make-rr name type class ttl (parse-rr-data type class (reverse! accum) message)) start)
|
||||
(loop (- len 1)
|
||||
(cdr start)
|
||||
(cons (car start) accum)))))))))))
|
||||
|
||||
(define (parse-ques start reply)
|
||||
(call-with-values
|
||||
(lambda () (parse-name start reply))
|
||||
(lambda (name start)
|
||||
(let ((type (car (cossa (octet-pair->number (car start) (cadr start)) types)))
|
||||
(start (cddr start)))
|
||||
(let ((class (car (cossa (octet-pair->number (car start) (cadr start)) classes)))
|
||||
(start (cddr start)))
|
||||
(values (list name type class) start))))))
|
||||
(define (parse-rr-data type class data message)
|
||||
(if *debug* (display "parse-rr-data\n"))
|
||||
(cond
|
||||
((eq? type 'a)
|
||||
(list (ip->string data)))
|
||||
|
||||
(define (parse-n parse start reply n)
|
||||
((eq? type 'ns)
|
||||
(list (call-with-values
|
||||
(lambda () (parse-name data message))
|
||||
(lambda (name rest) name))))
|
||||
|
||||
((eq? type 'cname)
|
||||
(list (call-with-values
|
||||
(lambda () (parse-name data message))
|
||||
(lambda (name rest) name))))
|
||||
|
||||
((eq? type 'hinfo)
|
||||
(list (list->string data)))
|
||||
|
||||
((eq? type 'mx)
|
||||
(list (octet-pair->number (car data) (cadr data))
|
||||
(call-with-values
|
||||
(lambda ()(parse-name (cddr data) message))
|
||||
(lambda (name rest) name))))
|
||||
|
||||
((eq? type 'ptr)
|
||||
(list (call-with-values
|
||||
(lambda () (parse-name data message))
|
||||
(lambda (name rest) name))))
|
||||
|
||||
((eq? type 'soa)
|
||||
(call-with-values
|
||||
(lambda () (parse-name data message))
|
||||
(lambda (mname rest)
|
||||
(call-with-values
|
||||
(lambda () (parse-name rest message))
|
||||
(lambda (rname rest)
|
||||
(let ((serial (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest)))
|
||||
(rest (cddddr rest)))
|
||||
(let ((refresh (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest)))
|
||||
(rest (cddddr rest)))
|
||||
(let ((retry (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest)))
|
||||
(rest (cddddr rest)))
|
||||
(let ((expire (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest)))
|
||||
(rest (cddddr rest)))
|
||||
(let ((minimum (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest)))
|
||||
(rest (cddddr rest)))
|
||||
(list mname rname serial refresh retry expire minimum)))))))))))
|
||||
|
||||
((eq? type 'txt)
|
||||
(list (list->string data)))
|
||||
|
||||
((eq? type 'wks)
|
||||
(list data))
|
||||
|
||||
(else (list data))))
|
||||
|
||||
;; parses n-times a message with parse. returns a list of parse-returns.
|
||||
(define (parse-n parse start message n)
|
||||
(if *debug* (display "parse-n\n"))
|
||||
(let loop ((n n) (start start) (accum '()))
|
||||
(if (zero? n)
|
||||
(values (reverse! accum) start)
|
||||
(call-with-values
|
||||
(lambda () (parse start reply))
|
||||
(lambda () (parse start message))
|
||||
(lambda (rr start)
|
||||
(loop (- n 1) start (cons rr accum)))))))
|
||||
|
||||
(define random
|
||||
(let ((crank (make-random (modulo (time) (- (expt 2 27) 1)))))
|
||||
(lambda (limit)
|
||||
(quotient (* (modulo (crank) 314159265)
|
||||
limit)
|
||||
314159265))))
|
||||
;; parses a message-headers flags. returns the flags.
|
||||
(define (parse-flags message)
|
||||
(if *debug* (display "parse-flags\n"))
|
||||
(let ((v0 (list-ref message 2))
|
||||
(v1 (list-ref message 3)))
|
||||
;; Check for error code:
|
||||
(let ((rcode (bitwise-and #xf (char->ascii v1)))
|
||||
(z (arithmetic-shift (bitwise-and 112 (char->ascii v1)) -4))
|
||||
(ra (arithmetic-shift (bitwise-and 64 (char->ascii v1)) -7))
|
||||
(rd (bitwise-and 1 (char->ascii v0)))
|
||||
(tc (arithmetic-shift (bitwise-and 2 (char->ascii v0)) -1))
|
||||
(aa (arithmetic-shift (bitwise-and 4 (char->ascii v0)) -2))
|
||||
(opcode (arithmetic-shift (bitwise-and 120 (char->ascii v0)) -3))
|
||||
(qr (arithmetic-shift (bitwise-and 128 (char->ascii v0)) -7)))
|
||||
(make-flags qr opcode aa tc rd ra z rcode))))
|
||||
|
||||
(define (dns-query nameserver addr type class)
|
||||
(if (not (assoc type types))
|
||||
(error "dns-query: invalid DNS query type ~a" type))
|
||||
(if (not (assoc class classes))
|
||||
(error "dns-query: invalid DNS query class ~a" class))
|
||||
|
||||
(let* ((query (make-query (random 256) addr type class))
|
||||
;; parses a message-header. returns the header.
|
||||
(define (parse-header message)
|
||||
(if *debug* (display "parse-header\n"))
|
||||
(let ((id (octet-pair->number (list-ref message 0) (list-ref message 1)))
|
||||
(flags (parse-flags message))
|
||||
(qd-count (octet-pair->number (list-ref message 4) (list-ref message 5)))
|
||||
(an-count (octet-pair->number (list-ref message 6) (list-ref message 7)))
|
||||
(ns-count (octet-pair->number (list-ref message 8) (list-ref message 9)))
|
||||
(ar-count (octet-pair->number (list-ref message 10) (list-ref message 11))))
|
||||
(make-header id flags qd-count an-count ns-count ar-count)))
|
||||
|
||||
|
||||
;; parses a message. returns the parsed message.
|
||||
(define (parse message)
|
||||
(if *debug* (display "parse\n"))
|
||||
(let* ((header (parse-header message))
|
||||
(start (list-tail message 12)))
|
||||
(call-with-values
|
||||
(lambda () (parse-n parse-question start message (header:qdc header)))
|
||||
(lambda (qds start)
|
||||
(call-with-values
|
||||
(lambda () (parse-n parse-rr start message (header:anc header)))
|
||||
(lambda (ans start)
|
||||
(call-with-values
|
||||
(lambda () (parse-n parse-rr start message (header:nsc header)))
|
||||
(lambda (nss start)
|
||||
(call-with-values
|
||||
(lambda () (parse-n parse-rr start message (header:arc header)))
|
||||
(lambda (ars start)
|
||||
(if (not (null? start))
|
||||
(error "parse: error parsing server message"))
|
||||
(make-message header qds ans nss ars message)))))))))))
|
||||
|
||||
|
||||
|
||||
;;; -- send, receive and validate message
|
||||
|
||||
;; checks if the received reply is valid. returns #t or error-msg.
|
||||
(define (reply-acceptable? reply query)
|
||||
(if *debug* (display "reply-acceptable?\n"))
|
||||
;; Check correct id
|
||||
(if (not (and (char=? (car reply) (car query))
|
||||
(char=? (cadr reply) (cadr query))))
|
||||
(error "send-receive-message: bad reply id from server"))
|
||||
;; Check for error code:
|
||||
(let ((rcode (flags:rcode (parse-flags reply))))
|
||||
(if (not (zero? rcode))
|
||||
(error "send-receive-message: error from server: ~a"
|
||||
(case rcode
|
||||
((1) "format error")
|
||||
((2) "server failure")
|
||||
((3) "name error")
|
||||
((4) "not implemented")
|
||||
((5) "refused"))))))
|
||||
|
||||
;; connects to nameserver and sends and receives messages. returns the reply.
|
||||
(define (send-receive-message nameserver question)
|
||||
(if *debug* (display "send-receive-message\n"))
|
||||
(let* ((query question)
|
||||
(reply
|
||||
(let ((socket (socket-connect protocol-family/internet
|
||||
socket-type/stream
|
||||
|
|
@ -192,7 +533,7 @@
|
|||
(w (socket:outport socket)))
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
'fick-dich-ins-knie)
|
||||
'nothing-to-be-done-before)
|
||||
(lambda ()
|
||||
(display (list->string (add-size-tag query)) w)
|
||||
(force-output w)
|
||||
|
|
@ -202,135 +543,97 @@
|
|||
(let ((len (octet-pair->number a b)))
|
||||
(let ((s (read-string len r)))
|
||||
(if (not (= len (string-length s)))
|
||||
(error "dns-query: unexpected EOF from server"))
|
||||
(error "send-receive-message: unexpected EOF from server"))
|
||||
(string->list s)))))
|
||||
(lambda ()
|
||||
(close-socket socket)))))))
|
||||
(reply-acceptable? reply query)
|
||||
(parse reply)))
|
||||
|
||||
;; First two bytes must match sent message id:
|
||||
(if (not (and (char=? (car reply) (car query))
|
||||
(char=? (cadr reply) (cadr query))))
|
||||
(error "dns-query: bad reply id from server"))
|
||||
|
||||
(let ((v0 (caddr reply))
|
||||
(v1 (cadddr reply)))
|
||||
;; Check for error code:
|
||||
(let ((rcode (bitwise-and #xf (char->ascii v1))))
|
||||
(if (not (zero? rcode))
|
||||
(error "dns-query: error from server: ~a"
|
||||
(case rcode
|
||||
((1) "format error")
|
||||
((2) "server failure")
|
||||
((3) "name error")
|
||||
((4) "not implemented")
|
||||
((5) "refused")))))
|
||||
|
||||
(let ((qd-count (octet-pair->number (list-ref reply 4) (list-ref reply 5)))
|
||||
(an-count (octet-pair->number (list-ref reply 6) (list-ref reply 7)))
|
||||
(ns-count (octet-pair->number (list-ref reply 8) (list-ref reply 9)))
|
||||
(ar-count (octet-pair->number (list-ref reply 10) (list-ref reply 11))))
|
||||
|
||||
(let ((start (list-tail reply 12)))
|
||||
(call-with-values
|
||||
(lambda () (parse-n parse-ques start reply qd-count))
|
||||
(lambda (qds start)
|
||||
(call-with-values
|
||||
(lambda () (parse-n parse-rr start reply an-count))
|
||||
(lambda (ans start)
|
||||
(call-with-values
|
||||
(lambda () (parse-n parse-rr start reply ns-count))
|
||||
(lambda (nss start)
|
||||
(call-with-values
|
||||
(lambda () (parse-n parse-rr start reply ar-count))
|
||||
(lambda (ars start)
|
||||
(if (not (null? start))
|
||||
(error "dns-query: error parsing server reply"))
|
||||
(values (positive? (bitwise-and #x4 (char->ascii v0)))
|
||||
qds ans nss ars reply))))))))))))))
|
||||
;;; -- cache
|
||||
|
||||
;; creates the cache, an emoty string-table
|
||||
(define cache (make-string-table))
|
||||
(define (dns-query/cache nameserver addr type class)
|
||||
(let ((key (format #f "~a;~a;~a;~a" nameserver addr type class)))
|
||||
(cond
|
||||
((table-ref cache key)
|
||||
=> (lambda (v)
|
||||
(apply values v)))
|
||||
(else
|
||||
(call-with-values
|
||||
(lambda () (dns-query nameserver addr type class))
|
||||
(lambda (auth? qds ans nss ars reply)
|
||||
(table-set! cache key (list auth? qds ans nss ars reply))
|
||||
(values auth? qds ans nss ars reply)))))))
|
||||
|
||||
(define (ip->string s)
|
||||
(format #f
|
||||
"~a.~a.~a.~a"
|
||||
(char->ascii (list-ref s 0))
|
||||
(char->ascii (list-ref s 1))
|
||||
(char->ascii (list-ref s 2))
|
||||
(char->ascii (list-ref s 3))))
|
||||
;; resets the cache
|
||||
(define (dns-clear-cache)
|
||||
(set! cache (make-string-table)))
|
||||
|
||||
(define (try-forwarding k nameserver)
|
||||
(let loop ((nameserver nameserver)
|
||||
(tried (list nameserver)))
|
||||
;; Normally the recursion is done for us, but it's technically optional
|
||||
(call-with-values
|
||||
(lambda () (k nameserver))
|
||||
(lambda (v ars auth?)
|
||||
(or v
|
||||
(and (not auth?)
|
||||
(let* ((ns (any
|
||||
(lambda (ar)
|
||||
(and (eq? (rr-type ar) 'a)
|
||||
(ip->string (rr-data ar))))
|
||||
ars)))
|
||||
(and ns
|
||||
(not (member ns tried))
|
||||
(loop ns (cons ns tried))))))))))
|
||||
;; 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? nameserver tried)
|
||||
(if *debug* (display "dns-query/cache\n"))
|
||||
(let ((dns-query
|
||||
(lambda ()
|
||||
(if *debug* (display "dns-query/cache:dns-query\n"))
|
||||
(make-dns-message (parse question) (send-receive-message nameserver question) #f (reverse tried)))) ; returns new retrieved data
|
||||
(dns-query-with-cache
|
||||
(lambda ()
|
||||
(if *debug* (display "dns-query/cache:dns-query-with-cache\n"))
|
||||
(let* ((qds (message:questions (parse question)))
|
||||
;; cache-key relevant data
|
||||
(name (question:name (car qds)))
|
||||
(type (question:type (car qds)))
|
||||
(class (question:class (car qds)))
|
||||
(key (format #f "~a;~a;~a;~a" nameserver name type class))
|
||||
(found-data (table-ref cache key)))
|
||||
(cond
|
||||
((and found-data
|
||||
;; checks if cached-data is still valid
|
||||
(< (time) (+ (cache:time found-data) (cache:ttl found-data))))
|
||||
(make-dns-message (parse question) (cache:answer found-data) #t (reverse tried))) ; returns the cached-data
|
||||
(else
|
||||
(let ((reply-msg (send-receive-message nameserver question)))
|
||||
(if *debug* (display "write to cache\n"))
|
||||
(table-set! cache key (make-cache reply-msg
|
||||
(if (null? (message:answers reply-msg))
|
||||
0
|
||||
(rr:ttl (car (message:answers reply-msg))))
|
||||
(time)))
|
||||
(make-dns-message (parse question) reply-msg #f (reverse tried))))))))) ; returns new retrieved data and updates cache
|
||||
(if use-cache?
|
||||
(dns-query-with-cache)
|
||||
(dns-query))))
|
||||
|
||||
(define (dns-get-address nameserver addr)
|
||||
(or (try-forwarding
|
||||
(lambda (nameserver)
|
||||
(call-with-values
|
||||
(lambda () (dns-query/cache nameserver addr 'a 'in))
|
||||
(lambda (auth? qds ans nss ars reply)
|
||||
(values (and (positive? (length ans))
|
||||
(let ((s (rr-data (car ans))))
|
||||
(ip->string s)))
|
||||
ars auth?))))
|
||||
nameserver)
|
||||
(error "dns-get-address: bad address ~a" addr)))
|
||||
;; dns and recursion
|
||||
;; recursion means, if the demanded information is not available from the
|
||||
;; nameserver, another nameserver (usualy an authority) has to be contacted.
|
||||
;; normally the recursion is done for us by the nameserver istself, but
|
||||
;; 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? nameserver check-answer)
|
||||
(if *debug* (display "dns-get-information\n"))
|
||||
(letrec ((tried (list nameserver))
|
||||
;; with every (also unanswerd) requests authoritative nameservers are send back
|
||||
;; try-recursive tries to get information from these nameservers
|
||||
(try-recursive
|
||||
(lambda (auth? nss)
|
||||
(if (or auth? (null? nss))
|
||||
(error "dns-get-information: bad address ~a" (question:name (car (message:questions (parse question)))))
|
||||
(let* ((ns (and (eq? (rr:type (car nss)) 'a) (ip->string (rr:data (car nss)))))
|
||||
(dns-msg (if (and ns
|
||||
(not (member ns tried))
|
||||
(set! tried (cons ns tried)))
|
||||
(dns-query/cache question use-cache? ns tried)
|
||||
(try-recursive auth? (cdr nss)))))
|
||||
(check-success dns-msg)))))
|
||||
;; checks if the answer is useful. returns a dns-message.
|
||||
(check-success
|
||||
(lambda (dns-msg)
|
||||
(if *debug* (display "dns-get-information:check-success\n"))
|
||||
(let ((useful-answer? (check-answer dns-msg)))
|
||||
(if useful-answer?
|
||||
dns-msg
|
||||
(let ((auth? (not (zero? (flags:auth (header:flags (message:header (dns-message:reply dns-msg)))))))
|
||||
;; other nameservers names are found in the nameserver-part,
|
||||
;; but their ip-adresses are found in the additonal-rrs
|
||||
(other-nameservers (message:additionals (dns-message:reply dns-msg))))
|
||||
(try-recursive auth? other-nameservers)))))))
|
||||
(check-success (dns-query/cache question use-cache? nameserver tried))))
|
||||
|
||||
(define (dns-get-mail-exchanger nameserver addr)
|
||||
(or (try-forwarding
|
||||
(lambda (nameserver)
|
||||
(call-with-values
|
||||
(lambda () (dns-query/cache nameserver addr 'mx 'in))
|
||||
(lambda (auth? qds ans nss ars reply)
|
||||
(values (let loop ((ans ans)
|
||||
(best-pref 99999) ; this is enough
|
||||
(exchanger #f))
|
||||
(cond
|
||||
((null? ans)
|
||||
(or exchanger
|
||||
;; Does 'soa mean that the input address is fine?
|
||||
(and (any? (lambda (ns)
|
||||
(eq? (rr-type ns) 'soa))
|
||||
nss)
|
||||
addr)))
|
||||
(else
|
||||
(let ((d (rr-data (car ans))))
|
||||
(let ((pref (octet-pair->number (car d) (cadr d))))
|
||||
(if (< pref best-pref)
|
||||
(call-with-values
|
||||
(lambda () (parse-name (cddr d) reply))
|
||||
(lambda (name start)
|
||||
(loop (cdr ans) pref name)))
|
||||
(loop (cdr ans) best-pref exchanger)))))))
|
||||
ars auth?))))
|
||||
nameserver)
|
||||
(error "dns-get-mail-exchanger: bad address")))
|
||||
|
||||
;; parses the resolv.conf file and returns the first found nameserver
|
||||
(define (dns-find-nameserver)
|
||||
(with-input-from-file "/etc/resolv.conf"
|
||||
(lambda ()
|
||||
|
|
@ -339,11 +642,136 @@
|
|||
(cond
|
||||
((eof-object? l)
|
||||
#f)
|
||||
((string-match "nameserver[ ]+([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+)"
|
||||
l)
|
||||
((regexp-search (posix-string->regexp "nameserver[ ]+([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+)") l)
|
||||
=> (lambda (match)
|
||||
(match:substring match 1)))
|
||||
(else
|
||||
(loop))))))))
|
||||
|
||||
|
||||
(define (dns-lookup name type)
|
||||
(let* ((ip-string (ip-string->in-addr name))
|
||||
(question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
|
||||
(make-octet-query-message (random 256) ip-string type 'in)
|
||||
(make-octet-query-message (random 256) name type 'in)))
|
||||
(use-cache? #t)
|
||||
(nameserver (dns-find-nameserver))
|
||||
(check-answer (lambda (dns-msg) (if *debug* (display "check-answer\n")) #t))
|
||||
;; ### type-a-queries should provide at least one answer
|
||||
; (let* ((reply (dns-message:reply dns-msg))
|
||||
; (answers (message:answers reply)))
|
||||
; (positive? (length answers))))))
|
||||
(dns-msg (dns-get-information question use-cache? nameserver check-answer))
|
||||
(answers (message:answers (dns-message:reply dns-msg))))
|
||||
(if (not (null? answers))
|
||||
(show-dns-message (car answers))
|
||||
(display "sorry, no answers received\n"))
|
||||
dns-msg))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;;; pretty-prints a dns-msg
|
||||
(define (show-dns-message dns-msg)
|
||||
(let* ((d
|
||||
(lambda (n s1 s2)
|
||||
(letrec ((loop (lambda (n)
|
||||
(if (zero? n)
|
||||
""
|
||||
(string-append " " (loop (- n 1)))))))
|
||||
(display (loop n))
|
||||
(display s1)
|
||||
(display ": ")
|
||||
(display s2)
|
||||
(newline)))))
|
||||
|
||||
(cond
|
||||
((dns-message? dns-msg)
|
||||
(begin
|
||||
(d 0 "DNS-MESSAGE" "")
|
||||
(d 1 "QUERY" "")(show-dns-message (dns-message:query dns-msg))(newline)
|
||||
(d 1 "REPLY" "")(show-dns-message (dns-message:reply dns-msg))(newline)
|
||||
(d 1 "CACHE?" (if (dns-message:cache? dns-msg)
|
||||
"found in cache"
|
||||
"not found in cache"))
|
||||
(d 1 "TRIED-NAMESERVERS" (if (> (length (dns-message:tried-nameservers dns-msg)) 1)
|
||||
(begin
|
||||
(display " had perform recursion: ")
|
||||
(dns-message:tried-nameservers dns-msg))
|
||||
(begin
|
||||
(display " without recursion: ")
|
||||
(dns-message:tried-nameservers dns-msg))))))
|
||||
((message? dns-msg)
|
||||
(begin
|
||||
(d 2 "MESSAGE" "")
|
||||
(d 3 "Header " "")(show-dns-message (message:header dns-msg))
|
||||
(d 3 "Questions " "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:questions dns-msg))
|
||||
(d 3 "Answers " "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:answers dns-msg))
|
||||
(d 3 "Nameservers" "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:nameservers dns-msg))
|
||||
(d 3 "Additionals" "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:additionals dns-msg))))
|
||||
((header? dns-msg)
|
||||
(begin
|
||||
(d 4 "id" (header:id dns-msg))
|
||||
(d 4 "Flags" "")(show-dns-message (header:flags dns-msg))
|
||||
(d 4 "question-count " (header:qdc dns-msg))
|
||||
(d 4 "answer-count " (header:anc dns-msg))
|
||||
(d 4 "nameserver-count " (header:nsc dns-msg))
|
||||
(d 4 "additional-count " (header:arc dns-msg))))
|
||||
((flags? dns-msg)
|
||||
(begin
|
||||
(d 5 "querytype" (flags:querytype dns-msg))
|
||||
(d 5 "opcode" (flags:opcode dns-msg))
|
||||
(d 5 "auth" (flags:auth dns-msg))
|
||||
(d 5 "trunc" (flags:trunc dns-msg))
|
||||
(d 5 "recursiondesired" (flags:recursiondesired dns-msg))
|
||||
(d 5 "recursionavailable" (flags:recursionavailable dns-msg))
|
||||
(d 5 "z" (flags:z dns-msg))
|
||||
(d 5 "rcode" (flags:rcode dns-msg))))
|
||||
((question? dns-msg)
|
||||
(begin
|
||||
(d 4 "name " (question:name dns-msg))
|
||||
(d 4 "type " (question:type dns-msg))
|
||||
(d 4 "class" (question:class dns-msg))))
|
||||
((rr? dns-msg)
|
||||
(begin
|
||||
(d 4 "name " (rr:name dns-msg))
|
||||
(d 4 "type " (rr:type dns-msg))
|
||||
(d 4 "class" (rr:class dns-msg))
|
||||
(d 4 "ttl " (rr:ttl dns-msg))
|
||||
(d 4 "data " (rr:data dns-msg)))))))
|
||||
|
||||
|
||||
|
||||
|
||||
;; plt stuff, to examine how they resolved mx-records
|
||||
;
|
||||
;(define (dns-get-mail-exchanger nameserver addr)
|
||||
; (or (try-forwarding
|
||||
; (lambda (nameserver)
|
||||
; (call-with-values
|
||||
; (lambda () (dns-query/cache nameserver addr 'mx 'in))
|
||||
; (lambda (cache? auth? qds ans nss ars reply)
|
||||
; (values (let loop ((ans ans)
|
||||
; (best-pref 99999) ; this is enough
|
||||
; (exchanger #f))
|
||||
; (cond
|
||||
; ((null? ans)
|
||||
; (or exchanger
|
||||
; ;; Does 'soa mean that the input address is fine?
|
||||
; (and (any? (lambda (ns)
|
||||
; (eq? (rr:type ns) 'soa))
|
||||
; nss)
|
||||
; addr)))
|
||||
; (else
|
||||
; (let ((d (rr:data (car ans))))
|
||||
; (let ((pref (octet-pair->number (car d) (cadr d))))
|
||||
; (if (< pref best-pref)
|
||||
; (call-with-values
|
||||
; (lambda () (parse-name (cddr d) reply))
|
||||
; (lambda (name start)
|
||||
; (loop (cdr ans) pref name)))
|
||||
; (loop (cdr ans) best-pref exchanger)))))))
|
||||
; ars auth?))))
|
||||
; nameserver)
|
||||
; (error "dns-get-mail-exchanger: bad address")))
|
||||
|
|
|
|||
Loading…
Reference in New Issue