1330 lines
43 KiB
Scheme
1330 lines
43 KiB
Scheme
;
|
|
; dns.scm
|
|
;
|
|
; Implementation of the RFC1035
|
|
|
|
;;; This file is part of the Scheme Untergrund Networking package.
|
|
|
|
;;; Copyright (c) 2002 by Marcus Crestani.
|
|
;;; For copyright information, see the file COPYING which comes with
|
|
;;; the distribution.
|
|
|
|
; domain names - implementation and specification
|
|
; based on the PLT-implementation.
|
|
;
|
|
;
|
|
; TODO:
|
|
; - test, test, test
|
|
; - types from newer RFCs (41, unknown)
|
|
; - more documentation
|
|
;
|
|
; ---
|
|
; sample usage & documentation:
|
|
;
|
|
; <ip-address32> is a 32bit integer internet->address, shortly address32.
|
|
; <ip-string> is a string in standard dot notation "xxx.xxx.xxx.xxx".
|
|
; <name> is a string
|
|
;
|
|
; <nameserver> can either be a domainname, an ip-string or an ip-address32.
|
|
; if it is a domainname, its ip is looked up on a nameserver listed in
|
|
; /etc/resolv.conf.
|
|
;
|
|
; (dns-find-nameserver) --> <ip-address32>
|
|
; this parses the /etc/resolv.conf file and returns the first found
|
|
; nameserver in address32 format.
|
|
;
|
|
;
|
|
;
|
|
; (dns-lookup-name <name> [nameserver]) --> <ip-address32>
|
|
; (dns-lookup-ip <ip-string | ip-address32> [nameserver]) --> <name>
|
|
; (dns-lookup-nameserver <name> [nameserver])
|
|
; --> <list of ip-address32s of authoritative nameservers>
|
|
; (dns-lookup-mail-exchanger <name> [nameserver])
|
|
; --> <list of names of mail-exchangers>
|
|
;
|
|
; dns-lookup-name, dns-lookup-ip, dns-lookup-nameserver and
|
|
; dns-lookup-mail-exchanger are "simple lookup functions",
|
|
; they return the wanted information or #f.
|
|
; dns-lookup-ip can either be given an ip-string or an ip-address32.
|
|
;
|
|
; concurrent dns lookup:
|
|
; if a list of nameservers is given to the optional <nameserver> argument,
|
|
; a concurrent lookup to all nameservers in this list is started.
|
|
; The nameservers in this list could either be ip-strings or ip-address32s.
|
|
; example: (dns-lookup-name "www.uni-tuebingen.de" (dns-find-nameserver-list))
|
|
; starts an concurrent lookup which contacts all nameservers in
|
|
; /etc/resolv.conf.
|
|
;
|
|
;
|
|
; (dns-lookup <name | ip-string | ip-address32> <type> [nameserver])
|
|
; --> <dns-message>
|
|
; (show-dns-message <dns-message) --> the whole message, human readable
|
|
;
|
|
; a <dns-message> is a record, with several entries, which holds the whole
|
|
; query/response dialog. the simplest way to get detailed information about
|
|
; the record structure is to view the result of show-dns-message.
|
|
;
|
|
; dns-lookup returns much more information than the simple lookup functions,
|
|
; only useful in very special cases.
|
|
;
|
|
;
|
|
; some lookups return a hostname (e.g. mx).
|
|
; many applications need instead of a hostname a ip address.
|
|
; force-ip and force-ip-list guarantee that a ip address is
|
|
; returned.
|
|
;
|
|
; (force-ip <name>) --> <ip>
|
|
; (force-ip-list <list of names>) --> <list of ips>
|
|
;
|
|
;
|
|
; useful converters:
|
|
;
|
|
; (address32->ip-string <ip-address32>) -> <ip-string>
|
|
; (ip-string->address32 <ip-string>) -> <ip-address32>
|
|
|
|
|
|
|
|
;; --- error conditions
|
|
|
|
;; supertype of all errors signaled by this library
|
|
(define-condition-type 'dns-error '(error))
|
|
(define dns-error? (condition-predicate 'dns-error))
|
|
|
|
(define-condition-type 'invalid-type '(dns-error))
|
|
(define invalid-type? (condition-predicate 'invalid-type))
|
|
|
|
(define-condition-type 'invalid-class '(dns-error))
|
|
(define invalid-class? (condition-predicate 'invalid-class))
|
|
|
|
(define-condition-type 'parse-error '(dns-error))
|
|
(define parse-error? (condition-predicate 'parse))
|
|
|
|
(define-condition-type 'unexpected-eof-from-server '(dns-error))
|
|
(define unexpected-eof-from-server? (condition-predicate 'unexpected-eof-from-server))
|
|
|
|
(define-condition-type 'bad-address '(dns-error))
|
|
(define bad-address? (condition-predicate 'bad-address))
|
|
|
|
(define-condition-type 'no-nameservers '(dns-error))
|
|
(define no-nameservers? (condition-predicate 'no-nameservers))
|
|
|
|
(define-condition-type 'bad-nameserver '(dns-error))
|
|
(define bad-nameserver? (condition-predicate 'bad-nameserver))
|
|
|
|
(define-condition-type 'not-a-hostname '(dns-error))
|
|
(define not-a-hostname? (condition-predicate 'not-a-hostname))
|
|
|
|
(define-condition-type 'not-a-ip '(dns-error))
|
|
(define not-a-ip? (condition-predicate 'not-a-ip))
|
|
|
|
;; supertype of all errors signaled if the dns server returned a non-sero
|
|
;; reply code
|
|
(define-condition-type 'dns-server-error '(dns-error))
|
|
(define dns-server-error? (condition-predicate 'dns-server-error))
|
|
|
|
(define-condition-type 'dns-format-error '(dns-server-error))
|
|
(define dns-format-error? (condition-predicate 'dns-format-error))
|
|
|
|
(define-condition-type 'dns-server-failure '(dns-server-error))
|
|
(define dns-server-failure? (condition-predicate 'dns-server-failure))
|
|
|
|
(define-condition-type 'dns-name-error '(dns-server-error))
|
|
(define dns-name-error? (condition-predicate 'dns-name-error))
|
|
|
|
(define-condition-type 'dns-not-implemented '(dns-server-error))
|
|
(define dns-not-implemented? (condition-predicate 'dns-not-implemented))
|
|
|
|
(define-condition-type 'dns-refused '(dns-server-error))
|
|
(define dns-refused? (condition-predicate 'dns-refused))
|
|
|
|
(define (dns-error condition . stuff)
|
|
(apply signal condition (dns-error->string condition) stuff))
|
|
|
|
(define (dns-error->string condition)
|
|
(string-append
|
|
"dns-error: "
|
|
(case condition
|
|
((invalid-type)
|
|
"make-octet-question: invalid DNS query type")
|
|
((invalid-class)
|
|
"make-octet-question: invalid DNS query class")
|
|
((parse-error)
|
|
"parse: error parsing server message")
|
|
((unexpected-eof-from-server)
|
|
"send-receive-message: unexpected EOF from server")
|
|
((bad-address)
|
|
"dns-get-information: bad address (in combination with query type)")
|
|
((no-nameservers)
|
|
"dns-find-nameserver: no nameservers found in /etc/resolv.conf")
|
|
((bad-nameserver)
|
|
"send-receive-message: nameserver refused connection")
|
|
((not-a-hostname)
|
|
"no hostname given")
|
|
((not-a-ip)
|
|
"no ip given")
|
|
((dns-format-error)
|
|
"error from server: (1) format error")
|
|
((dns-server-failure)
|
|
"error from server: (2) server failure")
|
|
((dns-name-error)
|
|
"error from server: (3) name error")
|
|
((dns-not-implemented)
|
|
"error from server: (4) not implemented")
|
|
((dns-refused)
|
|
"error from server: (5) refused")
|
|
(else (error "Unknown dns-error" condition)))))
|
|
|
|
|
|
;;; -- globals and types
|
|
;; off
|
|
(define *nul* (ascii->char 0))
|
|
|
|
;; on
|
|
(define *on* (ascii->char 1))
|
|
|
|
;; message types
|
|
(define types
|
|
'((unknown 0); types, which are not yet implemented
|
|
(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) ; (experimental)
|
|
(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)
|
|
(cond
|
|
((null? l) 'unknown)
|
|
((equal? (cadar l) i)
|
|
(car l))
|
|
(else (cossa i (cdr l)))))
|
|
|
|
;; number: 0<= x < 256
|
|
;; octet-pair: (char char)
|
|
;; octet-quad: (char char char char)
|
|
;; name: string *{"." string}
|
|
;; octets: *{(char *char)} nullchar
|
|
;; octet-ip: (char char char char)
|
|
;; address32: 0 <= x < 2^32-1
|
|
;; ip-string: "www.xxx.yyy.zzz"
|
|
;; ip-string-arpa: "zzz.yyy.xxx.www.in-addr.arpa"
|
|
|
|
;; encodes numbers (16bit) to octets
|
|
(define (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)
|
|
(+ (arithmetic-shift (char->ascii a) 8)
|
|
(char->ascii b)))
|
|
|
|
;; encodes numbers (32bit) to octets, needed for ttl
|
|
(define (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)
|
|
(+ (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)))
|
|
|
|
(let loop ((s s))
|
|
(cond
|
|
((regexp-search (rx (: bos (submatch (* (~ "."))) "." (submatch (* any))))
|
|
s)
|
|
=> (lambda (match)
|
|
(append
|
|
(encode-portion (match:substring match 1))
|
|
(loop (match:substring match 2)))))
|
|
(else
|
|
(if (= 0 (string-length s))
|
|
(list *nul*)
|
|
;;; TODO isn't this case an error?
|
|
(append
|
|
(encode-portion s)
|
|
(list *nul*)))))))
|
|
|
|
|
|
;; for tcp: message has to be tagged with its length
|
|
(define (add-size-tag m)
|
|
(append (number->octet-pair (length m)) m))
|
|
|
|
;; converts an octeted-ip to a 32bit integer internet-address
|
|
(define (octet-ip->address32 ip)
|
|
(+ (arithmetic-shift (char->ascii (list-ref ip 0)) 24)
|
|
(arithmetic-shift (char->ascii (list-ref ip 1)) 16)
|
|
(arithmetic-shift (char->ascii (list-ref ip 2)) 8)
|
|
(char->ascii (list-ref ip 3))))
|
|
|
|
;; converts a 32 bit integer internet-address to an octeted-ip
|
|
(define (address32->octet-ip ip)
|
|
(list (arithmetic-shift ip -24)
|
|
(modulo (arithmetic-shift ip -16) 256)
|
|
(modulo (arithmetic-shift ip -8) 256)
|
|
(modulo ip 256)))
|
|
|
|
;; converts an ip-string to an 32bit integer internet-address
|
|
(define (ip-string->address32 ip)
|
|
(octet-ip->address32 (ip-string->octet-ip ip)))
|
|
|
|
;; converts an ip-string to an 32bit integer internet-address
|
|
(define (address32->ip-string ip)
|
|
(format #f
|
|
"~a.~a.~a.~a"
|
|
(arithmetic-shift ip -24)
|
|
(modulo (arithmetic-shift ip -16) 256)
|
|
(modulo (arithmetic-shift ip -8) 256)
|
|
(modulo ip 256)))
|
|
|
|
;; converts an octeted-ip to an human readable ip-string
|
|
(define (octet-ip->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))))
|
|
|
|
(define ip-string-regexp (rx (: bos
|
|
(submatch (** 1 3 digit)) "."
|
|
(submatch (** 1 3 digit)) "."
|
|
(submatch (** 1 3 digit)) "."
|
|
(submatch (** 1 3 digit))
|
|
eos)))
|
|
|
|
;; converts an ip-string to octets
|
|
(define (ip-string->octet-ip s)
|
|
(cond
|
|
((regexp-search ip-string-regexp s)
|
|
=> (lambda (match)
|
|
(list
|
|
(ascii->char (string->number (match:substring match 1)))
|
|
(ascii->char (string->number (match:substring match 2)))
|
|
(ascii->char (string->number (match:substring match 3)))
|
|
(ascii->char (string->number (match:substring match 4))))))
|
|
(else
|
|
(error "invalid ip-string" s))))
|
|
|
|
;; calculates a "random" number, needed for message-ids
|
|
;; TODO use SRFI-27
|
|
(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-string? s)
|
|
(define (byte-as-string? string)
|
|
(let ((number (string->number string)))
|
|
(and number
|
|
(>= number 0)
|
|
(< number 256))))
|
|
(cond
|
|
((regexp-search ip-string-regexp s)
|
|
=> (lambda (match)
|
|
(and (byte-as-string? (match:substring match 1))
|
|
(byte-as-string? (match:substring match 2))
|
|
(byte-as-string? (match:substring match 3))
|
|
(byte-as-string? (match:substring match 4)))))
|
|
(else #f)))
|
|
|
|
|
|
;; checks if v is a address32
|
|
(define (address32? v)
|
|
(and (number? v)
|
|
(<= 0 v #xffffffff)))
|
|
|
|
;; returns a in-addr.arpa name-string or #f (needed to resolve hostname by ip)
|
|
(define (ip-string->in-addr-arpa s)
|
|
(cond
|
|
((regexp-search ip-string-regexp s)
|
|
=> (lambda (match)
|
|
(string-append
|
|
(match:substring match 4) "."
|
|
(match:substring match 3) "."
|
|
(match:substring match 2) "."
|
|
(match:substring match 1) "."
|
|
"in-addr.arpa")))
|
|
(else #f)))
|
|
|
|
;; filters types in a list of rrs
|
|
(define (filter-type list type)
|
|
(filter (lambda (rr)
|
|
(eq? (rr:type rr) type))
|
|
list))
|
|
|
|
;; sorts a mx-rr-list by preference. needed for dns-lookup-mail-exchanger.
|
|
(define (sort-by-preference mx-list)
|
|
(sort-list mx-list
|
|
(lambda (a b)
|
|
(< (rr-data-mx:preference (rr:data a)) (rr-data-mx:preference (rr:data b))))))
|
|
|
|
|
|
;; returns a IP if available (additonal type-a processing)
|
|
(define (force-ip name)
|
|
(let loop ((result (dns-lookup-name name)))
|
|
(if (ip-string? result)
|
|
result
|
|
(loop (dns-lookup-name result)))))
|
|
|
|
;; returns a list of IPs (additional type-a processing)
|
|
(define (force-ip-list names)
|
|
(map (lambda (elem) (force-ip elem)) names))
|
|
|
|
|
|
;;; -- 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)
|
|
(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)
|
|
(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 (not (assoc type types))
|
|
(dns-error 'invalid-type))
|
|
(if (not (assoc class classes))
|
|
(dns-error 'invalid-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)
|
|
(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)
|
|
(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)
|
|
(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)
|
|
(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)
|
|
(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, trying to find examples
|
|
(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)
|
|
(cond
|
|
((eq? type 'a)
|
|
(make-rr-data-a (octet-ip->address32 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)
|
|
(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)
|
|
(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)
|
|
(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)
|
|
(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))
|
|
(dns-error 'parse-error))
|
|
(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)
|
|
;; 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? rcode))
|
|
(case rcode
|
|
((1) (dns-error 'dns-format-error))
|
|
((2) (dns-error 'dns-server-failure))
|
|
((3) (dns-error 'dns-name-error))
|
|
((4) (dns-error 'dns-not-implemented))
|
|
((5) (dns-error 'dns-refused))))))
|
|
|
|
;; #t if message is truncated (could happen via UDP)
|
|
(define (truncated? reply)
|
|
(let ((trunc (flags:trunc (parse-flags reply))))
|
|
(= trunc 1)))
|
|
|
|
;; connects to nameserver and sends and receives messages. returns the reply.
|
|
;; here: via TCP
|
|
(define (send-receive-message-tcp nameservers query)
|
|
(receive (reply hit-ns other-nss)
|
|
(let ((sockets (map (lambda (nameserver)
|
|
(let ((sock (create-socket protocol-family/internet
|
|
socket-type/stream))
|
|
(addr (internet-address->socket-address
|
|
nameserver 53)))
|
|
;; we ignore the return value and select
|
|
;; unconditionally later
|
|
(connect-socket-no-wait sock addr)
|
|
sock))
|
|
nameservers)))
|
|
(let* ((ws (map socket:outport sockets))
|
|
(wsv (list->vector ws))
|
|
(wport-nameserver-alist (map cons ws nameservers))
|
|
(wport-socket-alist (map cons ws sockets)))
|
|
(dynamic-wind
|
|
(lambda () #f)
|
|
(lambda ()
|
|
(receive (ignore-r write-ready ignore-e)
|
|
;;; TODO this should circumvent the buffer
|
|
(select '#() wsv '#())
|
|
(let* ((w (vector-ref write-ready 0))
|
|
(hit-ns (cdr (assoc w wport-nameserver-alist)))
|
|
(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))
|
|
(r (socket:inport sock)))
|
|
(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)))
|
|
(dns-error 'unexpected-eof-from-server))
|
|
(values (string->list s)
|
|
hit-ns
|
|
(delete hit-ns nameservers)))))))))
|
|
(lambda ()
|
|
(for-each close-socket sockets)))))
|
|
(reply-acceptable? reply query)
|
|
(values (parse reply)
|
|
hit-ns
|
|
other-nss)))
|
|
|
|
;; here: via UDP
|
|
(define (send-receive-message-udp nameservers query)
|
|
(receive (reply hit-ns other-nss)
|
|
(let ((sockets (map (lambda (nameserver)
|
|
(let ((sock (create-socket protocol-family/internet
|
|
socket-type/datagram))
|
|
(addr (internet-address->socket-address
|
|
nameserver 53)))
|
|
(connect-socket sock addr)
|
|
sock))
|
|
nameservers)))
|
|
(let ((rs (map socket:inport sockets))
|
|
(ws (map socket:outport sockets)))
|
|
(dynamic-wind
|
|
(lambda ()
|
|
'nothing-to-be-done-before)
|
|
(lambda ()
|
|
(let ((query-string (list->string query))
|
|
(rsv (list->vector rs))
|
|
(rport-nameserver-alist (map cons rs nameservers))
|
|
(rport-socket-alist (map cons rs sockets)))
|
|
(for-each (lambda (w) (display query-string w)) ws)
|
|
(for-each force-output ws)
|
|
(receive (read-ready ignore-w ignore-e)
|
|
;;; TODO this should circumvent the buffer
|
|
(select rsv '#() '#())
|
|
(let* ((r (vector-ref read-ready 0))
|
|
(hit-ns (cdr (assoc r rport-nameserver-alist))))
|
|
(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))
|
|
hit-ns
|
|
(delete hit-ns nameservers))))))
|
|
(lambda ()
|
|
(for-each close-socket sockets)))))
|
|
(reply-acceptable? reply query)
|
|
(if (truncated? reply)
|
|
(send-receive-message-tcp nameservers query)
|
|
(values (parse reply)
|
|
hit-ns
|
|
other-nss))))
|
|
|
|
|
|
;;; -- cache
|
|
|
|
;; creates the cache, an empty 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)
|
|
(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)))
|
|
|
|
|
|
(define (make-key qds nameserver)
|
|
(let*;; cache-key relevant data
|
|
((name (question:name (car qds)))
|
|
(type (question:type (car qds)))
|
|
(class (question:class (car qds))))
|
|
(format #f "~a;~a;~a;~a" nameserver name type class)))
|
|
|
|
(define (lookup-cache qds nameserver)
|
|
(let* ((key (make-key qds nameserver))
|
|
(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))))
|
|
found-data)
|
|
(else #f))))
|
|
|
|
(define (update-cache! key entry)
|
|
(table-set! cache key entry))
|
|
|
|
(define (dns-query-no-cache question protocol nameservers tried)
|
|
;; returns new retrieved data
|
|
(receive (dns-msg hit-ns nss-with-no-reply)
|
|
(send-receive-message nameservers question protocol)
|
|
(values
|
|
(make-dns-message (parse question) 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))))
|
|
(let lp ((ns nameservers))
|
|
(if (null? ns)
|
|
(receive (reply-msg hit-ns nss-with-no-reply)
|
|
(send-receive-message nameservers question 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))
|
|
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 '())
|
|
#f
|
|
nameservers)))
|
|
(else (lp (cdr ns))))))))
|
|
|
|
(define (send-receive-message nameservers question protocol)
|
|
((cond
|
|
((eq? protocol 'tcp) send-receive-message-tcp)
|
|
((eq? protocol 'udp) send-receive-message-udp))
|
|
nameservers question))
|
|
|
|
;; 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)
|
|
(if use-cache?
|
|
(dns-query-with-cache question protocol nameservers tried)
|
|
(dns-query-no-cache question protocol nameservers tried)))
|
|
|
|
;; 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 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)
|
|
(if (check-answer dns-msg)
|
|
dns-msg
|
|
(let ((auth? (not
|
|
(zero?
|
|
(flags:auth (header:flags
|
|
(message:header
|
|
(dns-message:reply dns-msg))))))))
|
|
(if auth?
|
|
(dns-error 'bad-address)
|
|
;; other nameservers names are found in the nameserver-part,
|
|
;; but their ip-adresses are found in the additonal-rrs
|
|
(let ((other-nameservers
|
|
(filter (lambda (elem) (eq? (rr:type elem) 'a))
|
|
(message:additionals (dns-message:reply dns-msg)))))
|
|
(lp (if (not (member hit-ns tried)) (cons hit-ns tried) tried)
|
|
(lset-union equal?
|
|
nss-with-no-reply
|
|
(lset-difference equal? other-nameservers 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)
|
|
(dns-error 'no-nameservers)
|
|
ns))
|
|
((regexp-search
|
|
(rx (: "nameserver" (+ (| " " "\t")
|
|
(submatch (** 1 3 digit)
|
|
(= 3 (: "." (** 1 3 digit)))))))
|
|
l)
|
|
=> (lambda (match)
|
|
(loop (append ns (list (ip-string->address32 (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)
|
|
(dns-error 'no-nameservers)
|
|
(car ns))))
|
|
|
|
|
|
;; checks the nameservers argument of the 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-list)
|
|
(map (lambda (nameserver)
|
|
(cond
|
|
((address32? nameserver) nameserver)
|
|
((ip-string? nameserver) (ip-string->address32 nameserver))
|
|
(else (dns-lookup-name nameserver (dns-find-nameserver-list)))))
|
|
(car args))))
|
|
|
|
;; dns-lookup with more options than dns-lookup-*
|
|
(define (dns-lookup name type . nameservers)
|
|
(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 'in)
|
|
(make-octet-query-message (random 256) name type '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))
|
|
(answers (message:answers (dns-message:reply dns-msg))))
|
|
(if (not (null? answers))
|
|
(for-each (lambda (x) (show-dns-message x)(newline)) answers)
|
|
;;; TODO remove display
|
|
(display "no answers received - but resolved information in other sections.\n"))
|
|
dns-msg))
|
|
|
|
|
|
;; looks up a hostname, returns an ip.
|
|
;; (dns-lookup-name <name> nameservers)
|
|
(define (dns-lookup-name name . nameservers)
|
|
(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 'a 'in)))
|
|
(use-cache? #t)
|
|
(protocol 'udp)
|
|
(nameservers (check-args nameservers))
|
|
(check-answer (lambda (dns-msg)
|
|
(let* ((reply (dns-message:reply dns-msg))
|
|
(answers (message:answers reply)))
|
|
(not (null? (filter-type answers 'a))))))
|
|
(dns-msg (dns-get-information question use-cache? protocol nameservers check-answer))
|
|
(answers (filter-type (message:answers (dns-message:reply dns-msg)) 'a)))
|
|
(rr-data-a:ip (rr:data (car answers)))))
|
|
|
|
;; looks up an ip, returns a hostname
|
|
;; (dns-inverse-lookup <name> [nameserver])
|
|
(define (dns-lookup-ip ip . nameservers)
|
|
(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 'ptr 'in)
|
|
(dns-error 'not-a-ip)))
|
|
(use-cache? #t)
|
|
(protocol 'udp)
|
|
(nameservers (check-args nameservers))
|
|
(check-answer (lambda (dns-msg)
|
|
(let* ((reply (dns-message:reply dns-msg))
|
|
(answers (message:answers reply)))
|
|
(not (null? (filter-type answers 'ptr))))))
|
|
(dns-msg (dns-get-information question use-cache? protocol nameservers check-answer))
|
|
(answers (filter-type (message:answers (dns-message:reply dns-msg)) 'ptr)))
|
|
(rr-data-ptr:name (rr:data (car answers)))))
|
|
|
|
(define dns-inverse-lookup dns-lookup-ip)
|
|
|
|
;; looks up an authoritative nameserver for a hostname
|
|
;; returns a list of nameservers
|
|
;; (dns-lookup-nameserver <name> [nameserver])
|
|
(define (dns-lookup-nameserver name . nameservers)
|
|
(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 'ns 'in)))
|
|
(use-cache? #t)
|
|
(protocol 'udp)
|
|
(nameservers (check-args nameservers))
|
|
(check-answer (lambda (dns-msg)
|
|
(let* ((reply (dns-message:reply dns-msg))
|
|
(answers (message:answers reply))
|
|
(nameservers (message:nameservers reply)))
|
|
(or (not (null? (filter-type nameservers 'soa)))
|
|
(not (null? (filter-type answers 'ns)))))))
|
|
(dns-msg (dns-get-information question use-cache? protocol nameservers check-answer))
|
|
(reply (dns-message:reply dns-msg))
|
|
(soa (filter-type (message:nameservers reply) 'soa))
|
|
(nss (filter-type (message:answers reply) 'ns))
|
|
(add (filter-type (message:additionals reply) 'a)))
|
|
(if (null? nss)
|
|
(list (dns-lookup-name (rr-data-soa:mname (rr:data (car soa)))))
|
|
(map (lambda (elem) (rr-data-a:ip (rr:data elem))) add))))
|
|
|
|
;; looks up a mail-exchanger for a hostname.
|
|
;; returns a list of mail-exchanger, sorted by their preference
|
|
;; if there are no mx-records in the answer-section,
|
|
;; implementation based on RFC2821
|
|
;; (dns-lookup-mail-exchanger <name> [nameserver])
|
|
(define (dns-lookup-mail-exchanger name . nameservers)
|
|
(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 'mx 'in)))
|
|
(use-cache? #t)
|
|
(protocol 'tcp)
|
|
(nameservers (check-args nameservers))
|
|
(check-answer (lambda (dns-msg)
|
|
(let* ((reply (dns-message:reply dns-msg))
|
|
(answers (message:answers reply))
|
|
(nameservers (message:nameservers reply)))
|
|
(or (not (null? (filter-type answers 'mx)))
|
|
(not (null? (filter-type answers 'cname)))
|
|
(not (null? (filter-type answers 'a)))))))
|
|
(dns-msg (dns-get-information question use-cache? protocol nameservers check-answer))
|
|
(reply (dns-message:reply dns-msg))
|
|
(mx (filter-type (message:answers reply) 'mx))
|
|
(soa (filter-type (message:nameservers reply) 'soa))
|
|
(cname (filter-type (message:answers reply) 'cname))
|
|
(a (filter-type (message:answers reply) 'a)))
|
|
|
|
(cond
|
|
((not (null? a))
|
|
(list (rr-data-a:ip (rr:data (car a)))))
|
|
((not (null? cname))
|
|
(dns-lookup-mail-exchanger (rr-data-cname:name (rr:data (car cname)))))
|
|
((null? mx)
|
|
(list (rr-data-soa:rname (rr:data (car soa)))))
|
|
(else
|
|
(map (lambda (elem) (rr-data-mx:exchanger (rr:data elem))) (sort-by-preference mx))))))
|
|
|
|
;;; 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)))
|
|
|
|
)))
|
|
|
|
(define *fqdn-lock* (make-lock))
|
|
(define *fqdn-cache* '())
|
|
|
|
(define (socket-address->fqdn addr cache?)
|
|
(receive (ip32 port)
|
|
(socket-address->internet-address addr)
|
|
(internet-address->fqdn ip32 cache?)))
|
|
|
|
(define (internet-address->fqdn ip32 cache?)
|
|
(if cache?
|
|
(begin
|
|
(obtain-lock *fqdn-lock*)
|
|
(cond
|
|
((assv ip32 *fqdn-cache*) =>
|
|
(lambda (pair)
|
|
(release-lock *fqdn-lock*)
|
|
(cdr pair)))
|
|
(else
|
|
(release-lock *fqdn-lock*)
|
|
(let ((fqdn (dns-lookup-ip ip32)))
|
|
(set! *fqdn-cache*
|
|
(cons (cons ip32 fqdn) *fqdn-cache*))
|
|
fqdn))))
|
|
(dns-lookup-ip ip32)))
|
|
|
|
;;; TODO THIS USES gethostbyname
|
|
(define (host-fqdn name-or-socket-address)
|
|
(if (socket-address? name-or-socket-address)
|
|
(socket-address->fqdn name-or-socket-address #f)
|
|
;; TODO: try looking up with domain from "search" appended
|
|
(internet-address->fqdn
|
|
(car
|
|
(host-info:addresses
|
|
(host-info name-or-socket-address)))
|
|
#f)))
|
|
|
|
;;; TODO THIS USES gethostbyname
|
|
(define (system-fqdn)
|
|
;; TODO: isn't this simply (host-fqdn (system-name))?
|
|
(internet-address->fqdn (car (host-info:addresses (host-info (system-name))))
|
|
#t))
|