sunet/dns.scm

1091 lines
36 KiB
Scheme

;
; dns.scm
;
; Implementation of the RFC1035
; domain names - implementation and specification
; based on the PLT-implementation.
;
;
; TODO: -*!!! CHECK-ANSWER !!!
; *(wrong: if check-answer is not successfull, bad hostname is returned)
; *solution: error conditions -> if thrown, return #f
; - test, test, test
; - types from newer RFCs (41)
; - UDP: truncation check
; -*error conditions
; -*better interface (found or #f)
; - additional type-a processing: force-ip
; - check-answer for each type
; mx: rfc2821
; - more documentation
;
;
; sample usage:
;
; (dns-lookup-name <name> [nameserver]) --> <ip>
; (dns-lookup-ip <ip> [nameserver]) --> <name>
; (dns-lookup-nameserver <name> [nameserver]) --> <ip of authoritative nameserver>
; (dns-lookup-mail-exchanger <name> [nameserver]) --> <mail-exchanger>
;
; (dns-lookup <name/ip> <type> [nameserver]) --> <dns-message>
; (show-dns-message <dns-message) --> the whole message, human readable
;
; (concurrent-lookup <dns-lookup-*> <name>)
;;; 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) ; 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) ; 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) (error "dns-message: type not implemented: " i))
((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
((regexp-search (posix-string->regexp "^([^.]*)\\.(.*)") s)
=> (lambda (match)
(append
(encode-portion (match:substring match 1))
(loop (match:substring match 2)))))
(else
(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))
;; 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))))
;; 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))))))))
;; 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))))
;; checks if a string is a ip
(define (ip? s)
(if *debug* (display "ip-string->in-addr\n"))
(let loop ((s s)
(count 0))
(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))
#f))))
(else
(let ((number (string->number s)))
(and number
(< number 256)
(= count 3)
#t))))))
;; returns a in-addr.arpa name-string or #f (needed to resolve 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?
protocol
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)
;; End of name
(values #f (cdr start)))
((zero? (bitwise-and #xc0 v))
;; Normal label
(let loop ((len v)
(start (cdr start))
(accum '()))
(cond
((zero? len)
(call-with-values
(lambda () (parse-name start message))
(lambda (s start)
(let ((s0 (list->string (reverse! accum))))
(values (if s
(string-append s0 "." s)
s0)
start)))))
(else (loop (- len 1)
(cdr start)
(cons (car start) accum))))))
(else
;; Compression offset
(let ((offset (+ (arithmetic-shift (bitwise-and #x3f v) 8)
(char->ascii (cadr start)))))
(call-with-values
(lambda () (parse-name (list-tail message offset) message))
(lambda (s ignore-start)
(values s (cddr start)))))))))
;; 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 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)))
(let ((class (car (cossa (octet-pair->number (car start) (cadr start)) classes)))
(start (cddr start)))
(let ((ttl (octet-quad->number (car start) (cadr start)
(caddr start) (cadddr start)))
(start (cddddr start)))
(let ((len (octet-pair->number (car start) (cadr start)))
(start (cddr start)))
;; Extract next len bytes of data:
(let loop ((len len)
(start start)
(accum '()))
(if (zero? len)
(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)))))))))))
;;; -- rr-data-type records
(define-record rr-data-a
ip)
(define-record rr-data-ns
name)
(define-record rr-data-cname
name)
;; ###
;; hinfo not correctly implemented:
;; don't know how the fields in this record, haven't found any example yet
;; try (dns-lookup <name> 'hinfo) with several names, if you find a name
;; which delivers a hinfo-answer, please tell me :-)
(define-record rr-data-hinfo
data)
(define-record rr-data-mx
preference
exchanger)
(define-record rr-data-ptr
name)
(define-record rr-data-soa
mname
rname
serial
refresh
retry
expire
minimum)
;; ### same as hinfo
(define-record rr-data-txt
text)
;; ### same as hinfo and txt
(define-record rr-data-wks
data)
;;
(define (parse-rr-data type class data message)
(if *debug* (display "parse-rr-data\n"))
(cond
((eq? type 'a)
(make-rr-data-a (ip->string data)))
((eq? type 'ns)
(make-rr-data-ns (call-with-values
(lambda () (parse-name data message))
(lambda (name rest) name))))
((eq? type 'cname)
(make-rr-data-cname (call-with-values
(lambda () (parse-name data message))
(lambda (name rest) name))))
((eq? type 'mx)
(make-rr-data-mx (octet-pair->number (car data) (cadr data))
(call-with-values
(lambda ()(parse-name (cddr data) message))
(lambda (name rest) name))))
((eq? type 'ptr)
(make-rr-data-ptr (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)))
(make-rr-data-soa mname rname serial refresh retry expire minimum)))))))))))
((eq? type 'hinfo)
(make-rr-data-hinfo (list->string data)))
((eq? type 'txt)
(make-rr-data-txt (list->string data)))
((eq? type 'wks)
(make-rr-data-wks 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 message))
(lambda (rr start)
(loop (- n 1) start (cons rr accum)))))))
;; 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))))
;; 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))))
(display "send-receive-message: bad reply id from server"))
;; Check for error code:
(let ((rcode (flags:rcode (parse-flags reply))))
(if (not (zero? 0));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.
;; here: via TCP
(define (send-receive-message-tcp nameserver question)
(if *debug* (display "send-receive-message\n"))
(let* ((query question)
(reply
(let ((socket (socket-connect protocol-family/internet
socket-type/stream
nameserver 53)))
(let ((r (socket:inport socket))
(w (socket:outport socket)))
(dynamic-wind
(lambda ()
'nothing-to-be-done-before)
(lambda ()
(display (list->string (add-size-tag query)) w)
(force-output w)
(let ((a (read-char r))
(b (read-char r)))
(let ((len (octet-pair->number a b)))
(let ((s (read-string len r)))
(if (not (= len (string-length s)))
(error "send-receive-message: unexpected EOF from server"))
(string->list s)))))
(lambda ()
(close-socket socket)))))))
(reply-acceptable? reply query)
(parse reply)))
;; here: via UDP
(define (send-receive-message-udp nameserver question)
(if *debug* (display "send-receive-message\n"))
(let* ((query question)
(reply
(let ((socket (socket-connect protocol-family/internet
socket-type/datagram
nameserver 53)))
(let ((r (socket:inport socket))
(w (socket:outport socket)))
(dynamic-wind
(lambda ()
'nothing-to-be-done-before)
(lambda ()
(display (list->string query) w)
(force-output w)
(let ((s (read-string/partial 512 r))) ; 512 is the maximum udp-message size
(string->list s)))
(lambda ()
(close-socket socket)))))))
(reply-acceptable? reply query)
(parse reply)))
;;; -- cache
;; creates the cache, an emoty string-table
(define cache (make-string-table))
;; resets the cache
(define (dns-clear-cache)
(set! cache (make-string-table)))
;; searches in a dns-msg for the shortest ttl. this is needed for cache-management.
(define (find-shortest-ttl dns-msg)
(if *debug* (display "find-shortest-ttl\n"))
(letrec ((minimum #f)
(find-shortest-ttl-1
(lambda (dns-msg)
(cond
((dns-message? dns-msg)
(find-shortest-ttl-1 (dns-message:reply dns-msg)))
((message? dns-msg)
(for-each (lambda (x) (find-shortest-ttl-1 x)) (message:answers dns-msg))
(for-each (lambda (x) (find-shortest-ttl-1 x)) (message:nameservers dns-msg))
(for-each (lambda (x) (find-shortest-ttl-1 x)) (message:additionals dns-msg))
minimum)
((rr? dns-msg)
(cond
((not minimum) (set! minimum (rr:ttl dns-msg)))
(else
(if (and (not minimum) (> minimum (rr:ttl dns-msg)))
(set! minimum (rr:ttl dns-msg))))))))))
(find-shortest-ttl-1 dns-msg)))
;; 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 nameserver tried)
(if *debug* (display "dns-query/cache\n"))
(let ((send-receive-message
(cond
((eq? protocol 'tcp) send-receive-message-tcp)
((eq? protocol 'udp) send-receive-message-udp))))
(let ((dns-query
(lambda ()
(if *debug* (display "dns-query/cache:dns-query\n"))
;; returns new retrieved data
(make-dns-message (parse question) (send-receive-message nameserver question) #f protocol (reverse tried))))
(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))))
;; returns cached data
(make-dns-message (parse question) (cache:answer found-data) #t protocol (reverse tried)))
(else
(let ((reply-msg (send-receive-message nameserver question)))
(if *debug* (display "write to cache\n"))
(table-set! cache key (make-cache reply-msg (find-shortest-ttl reply-msg) (time)))
;; returns new retrieved data and updates cache
(make-dns-message (parse question) reply-msg #f protocol (reverse tried)))))))))
(if use-cache?
(dns-query-with-cache)
(dns-query)))))
;; 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? protocol nameserver check-answer)
(if *debug* (display "dns-get-information\n"))
(letrec ((tried (list nameserver))
;; with every (even unanswerd) requests authoritative nameservers are sent 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 (in combination with query-type)"
(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? protocol 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 (filter (lambda (elem) (eq? (rr:type elem) 'a))
(message:additionals (dns-message:reply dns-msg)))))
(try-recursive auth? other-nameservers)))))))
(check-success (dns-query/cache question use-cache? protocol nameserver tried))))
;; parses the resolv.conf file and returns a list of found nameserver
(define (dns-find-nameserver-list)
(with-input-from-file "/etc/resolv.conf"
(lambda ()
(let loop ((ns '()))
(let ((l (read-line)))
(cond
((eof-object? l)
(if (null? ns)
(error "dns-find-nameserver-list: no nameserver(s) found in /etc/resolv.conf")
ns))
((regexp-search (posix-string->regexp "nameserver[ ]+([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+)") l)
=> (lambda (match)
(loop (append ns (list (match:substring match 1))))))
(else
(loop ns))))))))
;; returns the first found nameserver
(define (dns-find-nameserver)
(let ((ns (dns-find-nameserver-list)))
(if (null? ns)
(error "dns-find-nameserver: no nameserver found in /etc/resolv.conf")
(car ns))))
;; concurrent-lookup
;; starts a <lookup>-lookup to all nameservers in (dns-find-nameserver-list)
(define (concurrent-lookup lookup name)
(let* ((return 'no-value)
(lock (make-lock))
(queue (make-queue))
(nameserver-list (dns-find-nameserver-list)))
(obtain-lock lock)
(spawn (lambda ()
(for-each (lambda (nameserver)
(spawn
(lambda ()
(display nameserver)(display " started\n")
(let* ((result (apply lookup (list name nameserver))))
(enqueue! queue result)
(display nameserver)(display " ")(display result)(newline)
(release-lock lock)))))
(dns-find-nameserver-list))))
(display "Consumer started\n")
(let loop ((count (length nameserver-list)))
(obtain-lock lock)
(let ((result (dequeue! queue)))
(if (or result (= 1 (length nameserver-list)))
result
(loop (- count 1)))))))
;; checks the arguments of the dns-lookup-* functions.
;; if a nameserver-name is given and not a nameserver-ip
;; (dns-lookup-name nameserver) is called.
(define (check-args args)
(if (null? args)
(dns-find-nameserver)
(let ((nameserver (car args)))
(if (ip? nameserver)
nameserver
(dns-lookup-name nameserver)))))
;; dns-lookup with more options than dns-lookup-*
;; optional: nameserver could be passed to the function.
(define (dns-lookup name type . args)
(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)
(protocol 'udp)
(nameserver (check-args args))
(check-answer (lambda (dns-msg) #t))
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
(answers (message:answers (dns-message:reply dns-msg))))
(if (not (null? answers))
(for-each (lambda (x) (show-dns-message x)(newline)) answers)
(display "no answers received - but resolved information in other sections.\n"))
dns-msg))
;; looks up a hostname, returns an ip.
;; (dns-lookup-name <name> [nameserver])
(define (dns-lookup-name name . args)
(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
(error "dns-lookup-name: no valid hostname, suppose it is an ip")
(make-octet-query-message (random 256) name 'a 'in)))
(use-cache? #t)
(protocol 'udp)
(nameserver (check-args args))
(valid-answers (lambda (answer)
(filter (lambda (ans)
(eq? (rr:type ans) 'a))
answer)))
(check-answer (lambda (dns-msg)
(let* ((reply (dns-message:reply dns-msg))
(answers (message:answers reply)))
(not (null? (valid-answers answers))))))
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
(answers (valid-answers (message:answers (dns-message:reply dns-msg)))))
(rr-data-a:ip (rr:data (car answers)))))
;; looks up an ip, returns a hostname
;; (dns-inverse-lookup <name> [nameserver])
(define (dns-inverse-lookup ip . args)
(let* ((ip-string (ip-string->in-addr ip))
(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 'ptr 'in)
(error "dns-inverse-lookup: no valid ip")))
(use-cache? #t)
(protocol 'udp)
(nameserver (check-args args))
(valid-answers (lambda (answers)
(filter (lambda (ans)
(eq? (rr:type ans) 'ptr))
answers)))
(check-answer (lambda (dns-msg)
(let* ((reply (dns-message:reply dns-msg))
(answers (message:answers reply)))
(not (null? (valid-answers answers))))))
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
(answers (valid-answers (message:answers (dns-message:reply dns-msg)))))
(rr-data-ptr:name (rr:data (car answers)))))
(define dns-lookup-ip dns-inverse-lookup)
;; looks up an authoritative nameserver for a hostname
;; returns a nameserver
;; (dns-lookup-nameserver <name> [nameserver])
(define (dns-lookup-nameserver name . args)
(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
(error "dns-lookup-name: no valid hostname, suppose it is an ip")
(make-octet-query-message (random 256) name 'ns 'in)))
(use-cache? #t)
(protocol 'tcp)
(nameserver (check-args args))
(valid-nameservers (lambda (nameservers)
(filter (lambda (ns)
(eq? (rr:type ns) 'soa))
nameservers)))
(check-answer (lambda (dns-msg)
(let* ((reply (dns-message:reply dns-msg))
(nameservers (message:nameservers reply)))
(not (null? (valid-nameservers nameservers))))))
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
(nameservers (valid-nameservers (message:nameservers (dns-message:reply dns-msg)))))
(dns-lookup-name (rr-data-soa:mname (rr:data (car nameservers))))))
;; looks up a mail-exchanger for a hostname.
;; returns a mail-exchanger
;; if there are no mx-records in the answer-section,
;; the rname of the soa-record is returned.
;; (dns-lookup-mail-exchanger <name> [nameserver])
;; ### CHECK RFC2821
(define (dns-lookup-mail-exchanger name . args)
(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
(error "dns-lookup-name: no valid hostname, suppose it is an ip")
(make-octet-query-message (random 256) name 'mx 'in)))
(use-cache? #t)
(protocol 'tcp)
(nameserver (check-args args))
(valid-answers (lambda (answers)
(filter (lambda (answer)
(eq? (rr:type answer) 'mx))
answers)))
(valid-nameservers (lambda (nameservers)
(filter (lambda (ns)
(eq? (rr:type ns) 'soa))
nameservers)))
(check-answer (lambda (dns-msg)
(let* ((reply (dns-message:reply dns-msg))
(answers (message:answers reply))
(nameservers (message:nameservers reply)))
(or (not (null? (valid-answers answers)))
(not (null? (valid-nameservers nameservers)))))))
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
(answers (valid-answers (message:answers (dns-message:reply dns-msg))))
(nameservers (valid-nameservers (message:nameservers (dns-message:reply dns-msg)))))
(if (null? answers)
(rr-data-soa:rname (rr:data (car nameservers)))
(let loop ((answers (cdr answers))
(preference (rr-data-mx:preference (rr:data (car answers))))
(exchanger (rr-data-mx:exchanger (rr:data (car answers)))))
(if (null? answers)
exchanger
(let ((new-preference (rr-data-mx:preference (rr:data (car answers)))))
(if (<= preference new-preference)
(loop (cdr answers) preference exchanger)
(loop (cdr answers) new-preference (rr-data-mx:exchanger (rr:data (car answers)))))))))))
;;; 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 "PROTOCOL" (let ((protocol (dns-message:protocol dns-msg)))
(cond
((eq? protocol 'tcp) "TCP")
((eq? protocol 'udp) "UDP"))))
(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 " "") (show-dns-message (rr:data dns-msg))))
((rr-data-a? dns-msg)
(d 5 "ip " (rr-data-a:ip dns-msg)))
((rr-data-ns? dns-msg)
(d 5 "name " (rr-data-ns:name dns-msg)))
((rr-data-cname? dns-msg)
(d 5 "name " (rr-data-cname:name dns-msg)))
((rr-data-mx? dns-msg)
(begin
(d 5 "preference " (rr-data-mx:preference dns-msg))
(d 5 "exchanger " (rr-data-mx:exchanger dns-msg))))
((rr-data-ptr? dns-msg)
(d 5 "name " (rr-data-ptr:name dns-msg)))
((rr-data-soa? dns-msg)
(begin
(d 5 "mname " (rr-data-soa:mname dns-msg))
(d 5 "rname " (rr-data-soa:rname dns-msg))
(d 5 "serial " (rr-data-soa:serial dns-msg))
(d 5 "refresh " (rr-data-soa:refresh dns-msg))
(d 5 "expire " (rr-data-soa:expire dns-msg))
(d 5 "minimum " (rr-data-soa:expire dns-msg))))
;; ###
((rr-data-hinfo? dns-msg)
(d 5 "data " (rr-data-hinfo:data dns-msg)))
((rr-data-txt? dns-msg)
(d 5 "text " (rr-data-txt:text dns-msg)))
((rr-data-wks? dns-msg)
(d 5 "data " (rr-data-wks:data dns-msg)))
)))