sunet/scheme/lib/dns.scm

1568 lines
52 KiB
Scheme

;
; dns.scm
;
; Implementation of the RFC1035
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 2002 by Marcus Crestani.
;;; Copyright (c) 2002-2003 by Martin Gasbichler
;;; 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 '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
((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-enumerated-type message-type :message-type
message-type?
the-message-types
message-type-name
message-type-number
(unknown ; types, which are not yet implemented
a ; a host address
ns ; an authoritative name server
md ; (obsolete)
mf ; (obsolete)
cname ; the canonical name for an alias
soa ; marks the start of a zone of authority
mb ; (experimental)
mg ; (experimental)
mr ; (experimental)
null ; (experimental)
wks ; a well known service description
ptr ; a domain name pointer
hinfo ; host information
minfo ; (experimental)
mx ; mail exchange
txt)) ; text strings
;; message classes
(define-enumerated-type message-class :message-class
message-class?
the-message-classes
message-class-name
message-class-number
(placeholder ; this starts at 0...
in ; the Internet
cs ; (obsolete)
ch ; the CHAOS class
hs)) ; Hesoid
;;; -- useful stuff
;; 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))
;; a standard query header, usefull for most queries
(define (make-std-query-header id question-count)
(let* ((qr 'query) ; querytype: query 0, response 1
(opcode 0) ; opcode: query 0, iquery 1 (OBSOLETE), status 2
(aa #f) ; authorative answer (in answers only)
(tc #f) ; truncation (size matters only with UDP)
(rd #t) ; recursion desired: nameserver pursues the query recursivly (optional)
(ra #f) ; recursion available (in answers only)
(zero 0) ; future use
(response-code 0) ; response code: error conditions (in answers only)
(question-count question-count)
(answer-count 0) ; answer count (in answers only)
(nameserver-count 0) ; name server resources (in answers only)
(additional-count 0)) ; additional records (in answers only)
(make-header
id
(make-flags qr opcode aa tc rd ra zero response-code)
question-count answer-count nameserver-count additional-count)))
;; makes a query-message (header and question only)
;; TODO does this really work for several questions as well?
(define (make-query-dns-message header . questions)
(make-message header questions '() '() '()
(apply
append
(header->octets header)
(map question->octets questions))))
(define (make-simple-query-dns-message id name type class)
(make-query-dns-message (make-std-query-header id 1)
(make-question name type class)))
;; makes a resource record for ans, nss, ars (name, type, class, ttl, data)
(define (make-octet-rr name type class ttl rdata)
(let* ((name (name->octets name))
(type (number->octet-pair (message-type-number type)))
(class (number->octet-pair (message-class-number class)))
(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-type dns-message :dns-message
(make-dns-message query reply cache? protocol tried-nameservers)
dns-message?
(query dns-message-query)
(reply dns-message-reply)
(cache? dns-message-cache?)
(protocol dns-message-protocol)
(tried-nameservers dns-message-tried-nameservers))
;; message
(define-record-type message :message
(make-message header questions answers nameservers additionals source)
message?
(header message-header)
(questions message-questions)
(answers message-answers)
(nameservers message-nameservers)
(additionals message-additionals)
(source message-source))
;; header
(define-record-type header :header
(make-header id flags question-count answer-count nameserver-count
additional-count)
header?
(id header-id)
(flags header-flags)
(question-count header-question-count)
(answer-count header-answer-count)
(nameserver-count header-nameserver-count)
(additional-count header-additional-count))
;;; -- message constructors: encode to octet-messages
;; makes an message header
(define (header->octets header)
(let* ((header-id (number->octet-pair (header-id header)))
(header-question-count (number->octet-pair (header-question-count header)))
(header-answer-count (number->octet-pair (header-answer-count header)))
(header-nameserver-count (number->octet-pair
(header-nameserver-count header)))
(header-additional-count (number->octet-pair
(header-additional-count header))))
(append header-id
(flags->octets (header-flags header))
header-question-count
header-answer-count
header-nameserver-count
header-additional-count)))
;; flags
(define-record-type flags :flags
(make-flags query-type opcode authoritative? truncated? recursion-desired?
recursion-available? zero response-code)
flags?
(query-type flags-query-type)
(opcode flags-opcode)
(authoritative? flags-authoritative?)
(truncated? flags-truncated?)
(recursion-desired? flags-recursion-desired?)
(recursion-available? flags-recursion-available?)
(zero flags-zero)
(response-code flags-response-code))
(define (make-flags-from-numbers
querytype opcode authoritative? truncated? recursion-desired? recursion-available?
zero response-code)
(make-flags
(if (zero? querytype) 'query 'response)
opcode
(not (zero? authoritative?))
(not (zero? truncated?))
(not (zero? recursion-desired?))
(not (zero? recursion-available?))
zero
(case response-code
((0) 'dns-no-error)
((1) 'dns-format-error)
((2) 'dns-server-failure)
((3) 'dns-name-error)
((4) 'dns-not-implemented)
((5) 'dns-refused))))
(define (flags->octets flags)
(define (boolean->0/1 bool)
(if bool 1 0))
(list
(ascii->char (+ (arithmetic-shift
(if (eq? (flags-query-type flags) 'query) 0 1) 7)
(arithmetic-shift (flags-opcode flags) 3)
(arithmetic-shift
(boolean->0/1 (flags-authoritative? flags)) 2)
(arithmetic-shift
(boolean->0/1 (flags-truncated? flags)) 1)
(boolean->0/1 (flags-recursion-desired? flags))))
(ascii->char (+ (arithmetic-shift
(boolean->0/1 (flags-recursion-available? flags)) 7)
(arithmetic-shift (flags-zero flags) 4)
(flags-response-code flags)))))
;; question
(define-record-type question :question
(make-question name type class)
question?
(name question-name)
(type question-type)
(class question-class))
;; makes a question (name, type, class)
(define (question->octets q)
(let* ((qname (name->octets (question-name q)))
(qtype (number->octet-pair
(message-type-number (question-type q))))
(qclass (number->octet-pair
(message-class-number (question-class q)))))
(append qname qtype qclass)))
;;type rr
(define-record-type rr :rr
(make-rr name type class ttl data)
rr?
(name rr-name)
(type rr-type)
(class rr-class)
(ttl rr-ttl)
(data rr-data))
;; cache
(define-record-type cache :cache
(make-cache answer ttl time)
cache?
(answer cache-answer)
(ttl cache-ttl)
(time cache-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 (vector-ref the-message-types
(octet-pair->number (car start) (cadr start))))
(start (cddr start)))
(let ((class (vector-ref the-message-classes
(octet-pair->number (car start) (cadr start))))
(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 (vector-ref the-message-types
(octet-pair->number (car start) (cadr start))))
(start (cddr start)))
(let ((class (vector-ref the-message-classes
(octet-pair->number (car start) (cadr start))))
(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-type rr-data-a :rr-data-a
(make-rr-data-a ip)
rr-data-a?
(ip rr-data-a-ip))
(define-record-type rr-data-ns :rr-data-ns
(make-rr-data-ns name)
rr-data-ns?
(name rr-data-ns-name))
(define-record-type rr-data-cname :rr-data-cname
(make-rr-data-cname name)
rr-data-cname?
(name rr-data-cname-name))
;; ###
;; hinfo not correctly implemented, trying to find examples
(define-record-type rr-data-hinfo :rr-data-hinfo
(make-rr-data-hinfo data)
rr-data-hinfo?
(data rr-data-hinfo-data))
(define-record-type rr-data-mx :rr-data-mx
(make-rr-data-mx preference exchanger)
rr-data-mx?
(preference rr-data-mx-preference)
(exchanger rr-data-mx-exchanger))
(define-record-type rr-data-ptr :rr-data-ptr
(make-rr-data-ptr name)
rr-data-ptr?
(name rr-data-ptr-name))
(define-record-type rr-data-soa :rr-data-soa
(make-rr-data-soa mname rname serial refresh retry expire minimum)
rr-data-soa?
(mname rr-data-soa-mname)
(rname rr-data-soa-rname)
(serial rr-data-soa-serial)
(refresh rr-data-soa-refresh)
(retry rr-data-soa-retry)
(expire rr-data-soa-expire)
(minimum rr-data-soa-minimum))
;; ### same as hinfo
(define-record-type rr-data-txt :rr-data-txt
(make-rr-data-txt text)
rr-data-txt?
(text rr-data-txt-text))
;; ### same as hinfo and txt
(define-record-type rr-data-wks :rr-data-wks
(make-rr-data-wks data)
rr-data-wks?
(data rr-data-wks-data))
;;
(define (parse-rr-data type class data message)
(cond
((eq? type (message-type a))
(make-rr-data-a (octet-ip->address32 data)))
((eq? type (message-type ns))
(make-rr-data-ns (call-with-values
(lambda () (parse-name data message))
(lambda (name rest) name))))
((eq? type (message-type cname))
(make-rr-data-cname (call-with-values
(lambda () (parse-name data message))
(lambda (name rest) name))))
((eq? type (message-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 (message-type ptr))
(make-rr-data-ptr (call-with-values
(lambda () (parse-name data message))
(lambda (name rest) name))))
((eq? type (message-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 (message-type hinfo))
(make-rr-data-hinfo (list->string data)))
((eq? type (message-type txt))
(make-rr-data-txt (list->string data)))
((eq? type (message-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 ((response-code (bitwise-and #xf (char->ascii v1)))
(zero (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-from-numbers qr opcode aa tc rd ra zero response-code))))
;; 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))
(question-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 question-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-question-count header)))
(lambda (qds start)
(call-with-values
(lambda () (parse-n parse-rr start message (header-answer-count header)))
(lambda (ans start)
(call-with-values
(lambda () (parse-n parse-rr start message (header-nameserver-count header)))
(lambda (nss start)
(call-with-values
(lambda () (parse-n parse-rr start message (header-additional-count 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 (= (header-id (message-header reply))
(header-id (message-header query))))
;; TODO replace error
(error "send-receive-message: bad reply id from server"))
;; Check for error code:
(let ((response-code (flags-response-code
(header-flags (message-header reply)))))
(if (not (eq? response-code 'dns-no-error))
(dns-error response-code))))
;; 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))
(wport-nameserver-alist (map cons ws nameservers))
(wport-socket-alist (map cons ws sockets)))
(dynamic-wind
(lambda () #f)
(lambda ()
(let* ((ready-ports (apply select-port-channels #f ws))
(w (car ready-ports))
(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
(add-size-tag (list->string (message-source query))))
(r (socket:inport sock)))
(display (list->string query-string) 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 (parse (string->list s))
hit-ns
(delete hit-ns nameservers))))))))
(lambda ()
(for-each close-socket sockets)))))
(reply-acceptable? reply query)
(values 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 (message-source 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)
(let* ((ready (apply select-port-channels #f rs))
(r (car ready))
(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 (parse (string->list (read-string/partial 512 r)))
hit-ns
(delete hit-ns nameservers)))))
(lambda ()
(for-each close-socket sockets)))))
(reply-acceptable? reply query)
(if (flags-truncated? (header-flags (message-header reply)))
(send-receive-message-tcp nameservers query)
(values 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
(message-type-name type)
(message-class-name 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 query protocol nameservers tried)
;; returns new retrieved data
(receive (dns-msg hit-ns nss-with-no-reply)
(send-receive-message nameservers query protocol)
(values
(make-dns-message query dns-msg #f protocol (reverse tried))
hit-ns
nss-with-no-reply)))
(define (dns-query-with-cache query protocol nameservers tried)
(let ((qds (message-questions query)))
(let lp ((ns nameservers))
(if (null? ns)
(receive (reply-msg hit-ns nss-with-no-reply)
(send-receive-message nameservers query protocol)
(update-cache! (make-key qds hit-ns)
(make-cache reply-msg (find-shortest-ttl reply-msg) (time)))
;; returns new retrieved data and updates cache
(values (make-dns-message query reply-msg #f protocol (reverse tried))
hit-ns
nss-with-no-reply))
(cond ((lookup-cache qds (car ns))
=> (lambda (found-data)
;; returns cached data
(values (make-dns-message query (cache-answer found-data) #t protocol '())
#f
nameservers)))
(else (lp (cdr ns))))))))
(define (send-receive-message nameservers query protocol)
((cond
((eq? protocol 'tcp) send-receive-message-tcp)
((eq? protocol 'udp) send-receive-message-udp))
nameservers query))
;; makes a dns-query. optional cache-check.
;; returns a dns-message with cache-flag and either cache-data or new received data.
(define (dns-query/cache query use-cache? protocol nameservers tried)
(if use-cache?
(dns-query-with-cache query protocol nameservers tried)
(dns-query-no-cache query protocol nameservers tried)))
;; dns and recursion
;; recursion means, if the demanded information is not available from the
;; 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 query use-cache? protocol nameservers check-answer)
(let lp ((tried '()) (nss nameservers))
(if (null? nss)
(dns-error 'bad-address)
(receive (dns-msg hit-ns nss-with-no-reply)
(dns-query/cache query use-cache? protocol nss tried)
(if (check-answer dns-msg)
dns-msg
(let ((auth? (flags-authoritative? (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) (message-type 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)))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Parsing of /etc/resolv.conf
(define (parse-nameserver rest-of-line)
(let ((match (regexp-search
(rx (: (submatch (** 1 3 digit) "."
(** 1 3 digit) "."
(** 1 3 digit) "."
(** 1 3 digit))
(* white))); don't complain about tailing white space
rest-of-line)))
(if match
(cons 'nameserver (match:substring match 1))
(signal 'resolv.conf-parse-error))))
; could be more restrictive...
(define domain-name-regexp (rx (+ (| alphanum #\. #\-))))
(define (parse-domain rest-of-line)
(let ((match (regexp-search
(rx (: (submatch ,domain-name-regexp)
(* white))); don't complain about tailing white space
rest-of-line)))
(if match
(cons 'domain (match:substring match 1))
(signal 'resolv.conf-parse-error))))
(define (parse-search rest-of-line)
(let ((domains (regexp-fold-right domain-name-regexp
(lambda (match junk accu)
(cons (match:substring match 0) accu))
'()
rest-of-line)))
(if (null? domains)
(signal 'resolv.conf-parse-error)
(cons 'search domains))))
(define (parse-sortlist rest-of-line)
(let ((netmask-pairs (regexp-fold-right (rx (+ (| digit #\. #\/)))
(lambda (match junk accu)
(cons (match:substring match 0) accu))
'()
rest-of-line)))
(if (null? netmask-pairs)
(signal 'resolv.conf-parse-error)
(cons 'sortlist netmask-pairs))))
(define (parse-options rest-of-line)
(regexp-fold-right
(rx (| "debug" "no_tld_query" (: "ndots:" (submatch digit))))
(lambda (match junk accu)
(let ((str (match:substring match 0)))
(cond ((string=? str "debug")
(cons 'debug accu))
((string=? str "no_tld_query")
(cons 'no_tld_query accu))
(else (cons (cons 'ndots
(string->number (match:substring match 1))) accu)))))
'()
rest-of-line))
(define *resolv.conf-cache*)
(define *resolv.conf-cache-date* 0)
(define (resolv.conf)
(let ((actual-m-time (file-info:mtime (file-info "/etc/resolv.conf"))))
(if (> actual-m-time *resolv.conf-cache-date*)
(parse-resolv.conf!))
*resolv.conf-cache*))
(define (parse-resolv.conf!)
(let ((actual-m-time (file-info:mtime (file-info "/etc/resolv.conf")))
(contents (really-parse-resolv.conf "/etc/resolv.conf")))
(set! *resolv.conf-cache* contents)
(set! *resolv.conf-cache-date* actual-m-time)))
(define (really-parse-resolv.conf file-name)
;; accumulate nameserver entries
;; domain and search are mutual exclusive, take the last
(define (adjust-result rev-result have-search-or-domain? nameservers)
(cond ((null? rev-result)
(if (null? nameservers)
'()
(list (cons 'nameserver nameservers))))
((eq? (caar rev-result) 'domain)
(if have-search-or-domain?
(adjust-result (cdr rev-result) have-search-or-domain? nameservers)
(cons (car rev-result)
(adjust-result (cdr rev-result)
#t
nameservers))))
((eq? (caar rev-result) 'search)
(if have-search-or-domain?
(adjust-result (cdr rev-result) have-search-or-domain? nameservers)
(cons (car rev-result)
(adjust-result (cdr rev-result)
#t
nameservers))))
((eq? (caar rev-result) 'nameserver)
(adjust-result (cdr rev-result)
have-search-or-domain?
(cons (cdar rev-result)
nameservers)))
(else (cons (car rev-result)
(adjust-result (cdr rev-result)
have-search-or-domain?
nameservers)))))
(with-input-from-file file-name
(lambda ()
(let loop ((rev-result '()))
(let ((l (read-line)))
(cond
((eof-object? l)
(adjust-result rev-result #f '()))
((regexp-search
(rx (: "nameserver" (+ (| " " "\t")
(submatch (* any))
eos)))
l)
=> (lambda (match)
(loop (cons (parse-nameserver (match:substring match 1))
rev-result))))
((regexp-search
(rx (: "domain" (+ (| " " "\t")
(submatch (* any))
eos)))
l)
=> (lambda (match)
(loop (cons (parse-domain (match:substring match 1))
rev-result))))
((regexp-search
(rx (: "search" (+ (| " " "\t")
(submatch (* any))
eos)))
l)
=> (lambda (match)
(loop (cons (parse-search (match:substring match 1))
rev-result))))
((regexp-search
(rx (: "sortlist" (+ (| " " "\t")
(submatch (* any))
eos)))
l)
=> (lambda (match)
(parse-sortlist (match:substring match 1))))
((regexp-search
(rx (: "options" (+ (| " " "\t")
(submatch (* any))
eos)))
l)
=> (lambda (match)
(parse-options (match:substring match 1))))
(else (signal 'resolv.conf-parse-error))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Figure out the default name servers
(define (dns-find-nameserver-list)
(cond ((assoc 'nameserver (resolv.conf))
=> (lambda (nameserver.list)
(cdr nameserver.list)))
(else '())))
;; 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)
(map ip-string->address32 (dns-find-nameserver-list))
(map (lambda (nameserver)
(cond
((address32? nameserver) nameserver)
((ip-string? nameserver) (ip-string->address32 nameserver))
(else (map (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)))
(query (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
(make-simple-query-dns-message
(random 256) maybe-ip-string type (message-class in))
(make-simple-query-dns-message (random 256) name type (message-class in))))
(use-cache? #t)
(protocol 'udp)
(nameservers (check-args nameservers))
(check-answer (lambda (dns-msg) #t))
(dns-msg (dns-get-information query use-cache? protocol nameservers check-answer))
(answers (message-answers (dns-message-reply dns-msg))))
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)))
(query (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
(dns-error 'not-a-hostname)
(make-simple-query-dns-message (random 256) name (message-type a) (message-class in))))
(use-cache? #t)
(protocol 'udp)
(nameservers (check-args nameservers))
(check-answer (lambda (dns-msg)
(let* ((reply (dns-message-reply dns-msg))
(answers (message-answers reply)))
(not (null? (filter-type answers (message-type a)))))))
(dns-msg (dns-get-information query use-cache? protocol nameservers check-answer))
(answers (filter-type (message-answers (dns-message-reply dns-msg)) (message-type a))))
(rr-data-a-ip (rr-data (car answers)))))
;; 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)))
(query (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
(make-simple-query-dns-message (random 256) maybe-ip-string (message-type ptr) (message-class in))
(dns-error 'not-a-ip)))
(use-cache? #t)
(protocol 'udp)
(nameservers (check-args nameservers))
(check-answer (lambda (dns-msg)
(let* ((reply (dns-message-reply dns-msg))
(answers (message-answers reply)))
(not (null? (filter-type answers (message-type ptr)))))))
(dns-msg (dns-get-information query use-cache? protocol nameservers check-answer))
(answers (filter-type (message-answers (dns-message-reply dns-msg)) (message-type ptr))))
(rr-data-ptr-name (rr-data (car answers)))))
(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)))
(query (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
(dns-error 'not-a-hostname)
(make-simple-query-dns-message
(random 256) name (message-type ns) (message-class in))))
(use-cache? #t)
(protocol 'udp)
(nameservers (check-args nameservers))
(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 (message-type soa))))
(not (null? (filter-type answers (message-type ns))))))))
(dns-msg (dns-get-information query use-cache? protocol nameservers check-answer))
(reply (dns-message-reply dns-msg))
(soa (filter-type (message-nameservers reply) (message-type soa)))
(nss (filter-type (message-answers reply) (message-type ns)))
(add (filter-type (message-additionals reply) (message-type 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)))
(query (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
(dns-error 'not-a-hostname)
(make-simple-query-dns-message
(random 256) name (message-type mx) (message-class in))))
(use-cache? #t)
(protocol 'tcp)
(nameservers (check-args nameservers))
(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 (message-type mx))))
(not (null? (filter-type answers (message-type cname))))
(not (null? (filter-type answers (message-type a))))))))
(dns-msg (dns-get-information query use-cache? protocol nameservers check-answer))
(reply (dns-message-reply dns-msg))
(mx (filter-type (message-answers reply) (message-type mx)))
(soa (filter-type (message-nameservers reply)(message-type soa)))
(cname (filter-type (message-answers reply) (message-type cname)))
(a (filter-type (message-answers reply) (message-type 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 (pretty-print-dns-message dns-msg . maybe-port)
(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)))))
(with-current-output-port*
(if (null? maybe-port)
(current-output-port)
(car maybe-port))
(lambda ()
(define (show-dns-message dns-msg)
(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-question-count dns-msg))
(d 4 "answer-count " (header-answer-count dns-msg))
(d 4 "nameserver-count " (header-nameserver-count dns-msg))
(d 4 "additional-count " (header-additional-count dns-msg))))
((flags? dns-msg)
(begin
(d 5 "querytype" (flags-query-type dns-msg))
(d 5 "opcode" (flags-opcode dns-msg))
(d 5 "authoritative?" (flags-authoritative? dns-msg))
(d 5 "truncated?" (flags-truncated? dns-msg))
(d 5 "recursion-desired?" (flags-recursion-desired? dns-msg))
(d 5 "recursion-available?" (flags-recursion-available? dns-msg))
(d 5 "zero" (flags-zero dns-msg))
(d 5 "response-code" (flags-response-code dns-msg))))
((question? dns-msg)
(begin
(d 4 "name " (question-name dns-msg))
(d 4 "type " (message-type-name (question-type dns-msg)))
(d 4 "class" (message-class-name (question-class dns-msg)))))
((rr? dns-msg)
(begin
(d 4 "name " (rr-name dns-msg))
(d 4 "type "(message-type-name (rr-type dns-msg)))
(d 4 "class" (message-class-name (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)))
))
(show-dns-message 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)))
(define (is-fqdn? name)
(regexp-search? (rx #\.) name))
(define (maybe-dns-lookup-name name)
(call-with-current-continuation
(lambda (k)
(with-handler (lambda (cond more)
(if (dns-error? cond)
(k #f)
(more)))
(lambda ()
(dns-lookup-name name))))))
(define (maybe-dns-lookup-ip ip-addr)
(call-with-current-continuation
(lambda (k)
(with-handler (lambda (cond more)
(if (dns-error? cond)
(k #f)
(more)))
(lambda ()
(dns-lookup-ip ip-addr))))))
(define (domains-for-search)
(cond ((assoc 'domain (resolv.conf))
=> (lambda (pair)
(list (cdr pair))))
((assoc 'search (resolv.conf))
=> (lambda (pair)
(cdr pair)))
(else '())))
(define (host-fqdn name-or-socket-address)
(if (socket-address? name-or-socket-address)
(socket-address->fqdn name-or-socket-address #f)
(let ((name name-or-socket-address))
(if (is-fqdn? name)
name
(let lp ((domains (domains-for-search)))
(if (null? domains)
#f
(cond ((maybe-dns-lookup-name (string-append name "." (car domains)))
=> (lambda (ip)
(dns-lookup-ip ip)))
(else (lp (cdr domains))))))))))
(define (system-fqdn)
(host-fqdn (system-name)))