2071 lines
71 KiB
Scheme
2071 lines
71 KiB
Scheme
;
|
|
; dns.scm
|
|
;
|
|
; Client-Implementation of the RFC 1035
|
|
|
|
;;; This file is part of the Scheme Untergrund Networking package.
|
|
|
|
;;; Copyright (c) 2002 by Marcus Crestani.
|
|
;;; Copyright (c) 2002-2003 by Martin Gasbichler
|
|
;;; Copyright (c) 2005-2006 by Norbert Freudemann
|
|
;;; 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
|
|
; - could be a good thing to merge dns.scm with the dnsd/resolver.scm?
|
|
; - 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-list) --> <ip-string list>
|
|
; this parses the /etc/resolv.conf file and returns the found
|
|
; nameserver in a list of dotted strings.
|
|
;
|
|
; (dns-find-nameserver) --> <ip-string>
|
|
; this parses the /etc/resolv.conf file and returns the first found
|
|
; nameserver in dotted string notation.
|
|
;
|
|
; (dns-check-namservers [nameserver list]) --> undefined
|
|
; checks if the given nameservers are reachable. If no argument is given,
|
|
; the nameservers in /etc/resolv.conf are checked.
|
|
;
|
|
;
|
|
; (dns-lookup-name <name> [nameserver list] [use-cache?]) --> <ip-address32>
|
|
; (dns-lookup-ip <ip-string | ip-address32> [nameserver list] [use-cache?])
|
|
; --> <name>
|
|
; (dns-lookup-nameserver <name> [nameserver list] [use-cache?])
|
|
; --> <list of ip-address32s of authoritative nameservers>
|
|
; (dns-lookup-mail-exchanger <name> [nameserver list] [use-cache?])
|
|
; --> <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 list])
|
|
; --> <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 'no-nameserver-given '(dns-error))
|
|
(define no-nameserver-given? (condition-predicate 'no-nameserver-given))
|
|
|
|
(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")
|
|
((no-nameserver-given)
|
|
"dns-find-nameserver: no nameservers given")
|
|
((bad-nameserver)
|
|
"send-receive-message: could not establish connection to server(s)")
|
|
((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)))))
|
|
|
|
|
|
;; --- (Q)Type and (Q)Class of a Message: ---
|
|
|
|
;; Message Type:
|
|
;; The IANA assigned type-values as in RFC 1035 and 3596 (IPv6) including the
|
|
;; super-set QTYPE starting at value 252+ that are needed for some queries.
|
|
(define-finite-type message-type :message-type
|
|
(value)
|
|
message-type?
|
|
the-message-type
|
|
message-type-name
|
|
message-type-index
|
|
(value message-type-number)
|
|
((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 (deprecated in RFC 1123)
|
|
(ptr 12) ; A domain name pointer
|
|
(hinfo 13) ; Host information
|
|
(minfo 14) ; Experimental
|
|
(mx 15) ; Mail exchange
|
|
(txt 16) ; Text strings
|
|
(aaaa 28) ; An IPv6 host address
|
|
(axfr 252) ; A request for a zone-transfer
|
|
(mailb 253) ; A request for mailbox-related records
|
|
(maila 254) ; Obsolete
|
|
(* 255))) ; A request for all records
|
|
|
|
|
|
;; Search for a message type, given the IANA-assigned value.
|
|
;; TYPE: number -> message-type or #f
|
|
(define (message-type-number->type number)
|
|
(let loop ((n (vector-length the-message-type)))
|
|
(if (= n 0)
|
|
#f
|
|
(let ((m (- n 1)))
|
|
(if (= number (message-type-number (vector-ref the-message-type m)))
|
|
(vector-ref the-message-type m)
|
|
(loop m))))))
|
|
|
|
|
|
;; Returns the message-type for a symbol
|
|
;; TYPE: symbol -> message-type or #f
|
|
(define (message-type-symbol->type symbol)
|
|
(let loop ((n (vector-length the-message-type)))
|
|
(if (= n 0)
|
|
#f
|
|
(let ((m (- n 1)))
|
|
(if (eq? symbol (message-type-name (vector-ref the-message-type m)))
|
|
(vector-ref the-message-type m)
|
|
(loop m))))))
|
|
|
|
|
|
;; Message Classes:
|
|
;; The resource-record class-values including the super-set QCLASS
|
|
;; (* 255)...
|
|
(define-finite-type message-class :message-class
|
|
(value)
|
|
message-class?
|
|
the-message-class
|
|
message-class-name
|
|
message-class-index
|
|
(value message-class-number)
|
|
((in 1) ; Internet
|
|
(cs 2) ; Obsolete
|
|
(ch 3) ; CHAOS
|
|
(hs 4) ; Hesiod
|
|
(* 255))) ; A QCLASS value: search for any class-entries.
|
|
|
|
|
|
;; Search for a message class, given the IANA-assigned value.
|
|
;; TYPE: number -> message-class or #f
|
|
(define (message-class-number->type number)
|
|
(let loop ((n (vector-length the-message-class)))
|
|
(if (= n 0)
|
|
#f
|
|
(let ((m (- n 1)))
|
|
(if (= number (message-class-number (vector-ref the-message-class m)))
|
|
(vector-ref the-message-class m)
|
|
(loop m))))))
|
|
|
|
|
|
;; Returns the message-class for a symbol
|
|
;; TYPE: symbol -> message-class or #f
|
|
(define (message-class-symbol->type symbol)
|
|
(let loop ((n (vector-length the-message-class)))
|
|
(if (= n 0)
|
|
#f
|
|
(let ((m (- n 1)))
|
|
(if (eq? symbol (message-class-name (vector-ref the-message-class m)))
|
|
(vector-ref the-message-class m)
|
|
(loop m))))))
|
|
|
|
|
|
|
|
;;; -- 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)))
|
|
|
|
(define *nul* (ascii->char 0))
|
|
|
|
(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))
|
|
|
|
;; checks if v is an address32
|
|
(define (address32? v)
|
|
(and (number? v) (<= 0 v #xffffffff)))
|
|
|
|
;; filters types in a list of rrs
|
|
(define (filter-type list type)
|
|
(filter (lambda (rr)
|
|
(eq? (resource-record-type rr) type))
|
|
list))
|
|
|
|
;; sorts a mx-resource-record-list by preference. needed for dns-lookup-mail-exchanger.
|
|
(define (sort-by-preference mx-list)
|
|
(sort-list mx-list
|
|
(lambda (a b)
|
|
(< (resource-record-data-mx-preference (resource-record-data a))
|
|
(resource-record-data-mx-preference (resource-record-data b))))))
|
|
|
|
|
|
;; returns an 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))
|
|
|
|
|
|
;; ----------------------------------
|
|
;; --- Dealing with domain names: ---
|
|
;; ----------------------------------
|
|
|
|
;; Regexp matching a label of a name
|
|
(define label-regexp
|
|
(rx (: (| (: bos "." eos)
|
|
(:
|
|
bos
|
|
(submatch (| "*" (: alphanumeric (* (| alphanumeric "-")))))
|
|
"."
|
|
(submatch (| "" (: alphanumeric (* any))))
|
|
eos)))))
|
|
|
|
|
|
;; Splits a name in its first label an the rest
|
|
;; Note: (dn-split? "de." will be ("de" . "")
|
|
;; TYPE: string -> (string . string) or #f
|
|
(define (dn-split? name)
|
|
(cond
|
|
((string=? name ".") #f)
|
|
((regexp-search label-regexp name)
|
|
=> (lambda (match)
|
|
(cons (match:substring match 1)
|
|
(match:substring match 2))))
|
|
(else #f)))
|
|
|
|
|
|
;; Look if a string is a FQDN
|
|
;; TYPE: string -> boolean
|
|
(define (fqdn? name)
|
|
(let loop ((name name))
|
|
(cond
|
|
((dn-split? name)
|
|
=> (lambda (p)
|
|
(let ((cp (cdr p)))
|
|
(if (string=? cp "")
|
|
#t
|
|
(loop (cdr p))))))
|
|
(else #f))))
|
|
|
|
|
|
;; Cuts the first label from a FQDN and returns the rest of the name.
|
|
;; TYPE: string -> string
|
|
(define (cut-name name)
|
|
(cond
|
|
((regexp-search label-regexp name)
|
|
=> (lambda (match)
|
|
(let ((m (match:substring match 2)))
|
|
(if (string=? m "") "." m))))
|
|
(else #f)))
|
|
|
|
|
|
; Adds an ending dot to a string if neccessary.
|
|
; TYPE: string -> string
|
|
(define (make-fqdn-name name)
|
|
(let ((last-char (string-ref name (- (string-length name) 1))))
|
|
(if (not (char=? #\. last-char))
|
|
(string-append name ".")
|
|
name)))
|
|
|
|
|
|
; --- Message Constructors: ---
|
|
|
|
; A standard query header, usefull for most queries.
|
|
; See RFC 1035 (4.1.1) for details.
|
|
(define (make-std-query-header id question-count)
|
|
(let* ((qr 'query) ; querytype: query 0, response 1
|
|
(opcode 0) ; opcode: query 0, iquery 1 (OBSOLETE: see RFC 3425), 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-message header question . questions)
|
|
(let ((questions (cons question questions)))
|
|
(make-message header questions '() '() '()
|
|
(apply
|
|
append
|
|
(header->octets header)
|
|
(map question->octets questions)))))
|
|
|
|
(define (make-simple-query-message name type class)
|
|
(make-query-message (make-std-query-header (random-integer 65536) 1)
|
|
(make-question name type class)))
|
|
|
|
|
|
;;; -- 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 set-message-source!)) ; The bite-encoded message
|
|
|
|
;; 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 set-header-answer-count!)
|
|
(nameserver-count header-nameserver-count set-header-nameserver-count!)
|
|
(additional-count header-additional-count set-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? set-flags-authoritative!)
|
|
(truncated? flags-truncated? set-flags-truncated!)
|
|
(recursion-desired? flags-recursion-desired?)
|
|
(recursion-available? flags-recursion-available? set-flags-recursion-available!)
|
|
(zero flags-zero)
|
|
(response-code flags-response-code set-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)
|
|
(let ((response-code (flags-response-code flags)))
|
|
(if (number? response-code)
|
|
response-code
|
|
(if (symbol? response-code)
|
|
(case response-code
|
|
((dns-no-error) 0)
|
|
((dns-format-error) 1)
|
|
((dns-server-failure) 2)
|
|
((dns-name-error) 3)
|
|
((dns-not-implemented) 4)
|
|
((dns-refused) 5)))))))))
|
|
|
|
|
|
;; question
|
|
(define-record-type question :question
|
|
(really-make-question name type class)
|
|
question?
|
|
(name question-name)
|
|
(type question-type)
|
|
(class question-class))
|
|
|
|
; Ensures the internal representation of a domain-name:
|
|
(define (make-question name type class)
|
|
(really-make-question (make-fqdn-name name) type 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 resource-record
|
|
(define-record-type resource-record :resource-record
|
|
(make-resource-record name type class ttl data)
|
|
resource-record?
|
|
(name resource-record-name)
|
|
(type resource-record-type)
|
|
(class resource-record-class)
|
|
(ttl resource-record-ttl)
|
|
(data resource-record-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 "." (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 (string-ci=? s ".")
|
|
(string-append s0 ".")
|
|
(string-append s0 "." s))
|
|
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 (message-type-number->type
|
|
(octet-pair->number (car start) (cadr start))))
|
|
(start (cddr start)))
|
|
(let ((class (message-class-number->type
|
|
(octet-pair->number (car start) (cadr start))))
|
|
(start (cddr start)))
|
|
(values (make-question name type class) start))))))
|
|
|
|
|
|
;; parses a resource-record in a message. returns the rr and the
|
|
;; rest of the message.
|
|
(define (parse-rr start message)
|
|
|
|
(define (type-number->type type-number)
|
|
(let ((type (message-type-number->type type-number)))
|
|
(if type
|
|
type
|
|
'unsupported-message-type)))
|
|
|
|
(define (class-number->class class-number)
|
|
(let ((class (message-class-number->type class-number)))
|
|
(if class
|
|
class
|
|
'unsupported-message-class)))
|
|
|
|
(call-with-values
|
|
(lambda () (parse-name start message))
|
|
(lambda (name start)
|
|
(let ((type (type-number->type
|
|
(octet-pair->number (car start) (cadr start))))
|
|
(start (cddr start)))
|
|
(let ((class (class-number->class
|
|
(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-resource-record
|
|
name type class ttl
|
|
(parse-resource-record-data
|
|
type class (reverse! accum) message)) start)
|
|
(loop (- len 1)
|
|
(cdr start)
|
|
(cons (car start) accum)))))))))))
|
|
|
|
|
|
;; -- Resource-Record records: ---
|
|
|
|
;; Data-Fields for the supported types of resource records:
|
|
|
|
(define-record-type resource-record-data-a :resource-record-data-a
|
|
(make-resource-record-data-a ip)
|
|
resource-record-data-a?
|
|
(ip resource-record-data-a-ip))
|
|
|
|
(define-record-type resource-record-data-aaaa :resource-record-data-aaaa
|
|
(make-resource-record-data-aaaa ipv6)
|
|
resource-record-data-aaaa?
|
|
(ipv6 resource-record-data-aaaa-ipv6))
|
|
|
|
(define-record-type resource-record-data-ns :resource-record-data-ns
|
|
(make-resource-record-data-ns name)
|
|
resource-record-data-ns?
|
|
(name resource-record-data-ns-name))
|
|
|
|
(define-record-type resource-record-data-cname :resource-record-data-cname
|
|
(make-resource-record-data-cname name)
|
|
resource-record-data-cname?
|
|
(name resource-record-data-cname-name))
|
|
|
|
(define-record-type resource-record-data-hinfo :resource-record-data-hinfo
|
|
(make-resource-record-data-hinfo data)
|
|
resource-record-data-hinfo?
|
|
(data resource-record-data-hinfo-data))
|
|
|
|
(define-record-type resource-record-data-mx :resource-record-data-mx
|
|
(make-resource-record-data-mx preference exchanger)
|
|
resource-record-data-mx?
|
|
(preference resource-record-data-mx-preference)
|
|
(exchanger resource-record-data-mx-exchanger))
|
|
|
|
(define-record-type resource-record-data-ptr :resource-record-data-ptr
|
|
(make-resource-record-data-ptr name)
|
|
resource-record-data-ptr?
|
|
(name resource-record-data-ptr-name))
|
|
|
|
(define-record-type resource-record-data-soa :resource-record-data-soa
|
|
(make-resource-record-data-soa mname rname serial refresh retry expire minimum)
|
|
resource-record-data-soa?
|
|
(mname resource-record-data-soa-mname)
|
|
(rname resource-record-data-soa-rname)
|
|
(serial resource-record-data-soa-serial)
|
|
(refresh resource-record-data-soa-refresh)
|
|
(retry resource-record-data-soa-retry)
|
|
(expire resource-record-data-soa-expire)
|
|
(minimum resource-record-data-soa-minimum))
|
|
|
|
(define-record-type resource-record-data-txt :resource-record-data-txt
|
|
(make-resource-record-data-txt text)
|
|
resource-record-data-txt?
|
|
(text resource-record-data-txt-text))
|
|
|
|
;; ## not corretly implemented (deprecated in RFC 1123)
|
|
(define-record-type resource-record-data-wks :resource-record-data-wks
|
|
(make-resource-record-data-wks data)
|
|
resource-record-data-wks?
|
|
(data resource-record-data-wks-data))
|
|
|
|
|
|
;; --------------------------------------------------
|
|
;; --- Message-(Un)-Parser / message-compression ---
|
|
;; --------------------------------------------------
|
|
|
|
;; FQDNs are stored together with the assiciated pointer-number in
|
|
;; an association-list (a-list)
|
|
;; The octet-message is stored in the o-list
|
|
|
|
|
|
;; Returns an (if possible) compressed octet-name
|
|
;; TYPE: string x l-of-octets x l-of-names-> l-of-octets x l-of-names
|
|
(define (mc-name->octets name o-list a-list)
|
|
;; TYPE: string -> octets
|
|
(define (encode-label s)
|
|
(cons (ascii->char (string-length s)) (string->list s)))
|
|
;; Returns elements from the list-of-names who matches name
|
|
(define (lookup? name a-list)
|
|
(let ((res
|
|
(fold-right
|
|
(lambda (e l)
|
|
(if (string-ci=? name (car e))
|
|
(cons e l)
|
|
l))
|
|
'()
|
|
a-list)))
|
|
(if (null? res) #f res)))
|
|
;; Create a pointer to another byte of an octet-message
|
|
(define (make-name-pointer number)
|
|
(if (<= number #x3FFF)
|
|
(number->octet-pair (bitwise-ior #xC000 number))
|
|
(error "This must be a very long message... .")))
|
|
|
|
(cond
|
|
;; Nothing left?
|
|
((or (string=? name "") (string=? name "."))
|
|
(values (append o-list (list (ascii->char 0))) a-list))
|
|
;; Matching FQDN?
|
|
((lookup? name a-list)
|
|
=> (lambda (e)
|
|
(values (append o-list (make-name-pointer (cdar e)))
|
|
a-list)))
|
|
;; Cut-and-retry:
|
|
(else
|
|
(let ((dn-pair (dn-split? name)))
|
|
(if dn-pair
|
|
(mc-name->octets (cdr dn-pair)
|
|
(append o-list (encode-label (car dn-pair)))
|
|
(cons (cons name (length o-list)) a-list))
|
|
(error "mc-name->octets: Not a FQDN!"))))))
|
|
|
|
|
|
;; Converts a message-question-record-type into octets
|
|
;; TYPE: msg-question x l-of-octets x l-of-names -> l-of-octets x l-of-names
|
|
(define (mc-question->octets q o-list a-list)
|
|
(receive (o-list a-list)
|
|
(mc-name->octets (question-name q) o-list a-list)
|
|
(values (append o-list
|
|
(number->octet-pair
|
|
(message-type-number (question-type q)))
|
|
(number->octet-pair
|
|
(message-class-number (question-class q))))
|
|
a-list)))
|
|
|
|
|
|
;; Translate the resource-record-data-*-content into octets.
|
|
;; TYPE: RR x list-of-octets x list-of-names -> list-of-octets x list-of-names
|
|
(define (mc-rdata->octets rr o-list a-list)
|
|
;; TXT and HINFO strings
|
|
(define (string-list->char-string-list l)
|
|
(let loop ((l l)
|
|
(r '()))
|
|
(if (null? l)
|
|
r
|
|
(let ((len (string-length (car l))))
|
|
(loop (cdr l)
|
|
(append
|
|
r
|
|
(list (ascii->char len))
|
|
(string->list (car l))))))))
|
|
|
|
(let ((rr-data (resource-record-data rr)))
|
|
(cond
|
|
;; Parser fallback:
|
|
((list? rr-data)
|
|
(values (append o-list rr-data) a-list))
|
|
;; Only IN supported...
|
|
((eq? (message-class in) (resource-record-class rr))
|
|
(cond
|
|
((resource-record-data-a? rr-data)
|
|
(values (append o-list
|
|
(address32->octet-ip
|
|
(resource-record-data-a-ip rr-data)))
|
|
a-list))
|
|
((resource-record-data-aaaa? rr-data) ;; TODO!
|
|
(values (append o-list (resource-record-data-aaaa-ipv6 rr-data))
|
|
a-list))
|
|
((resource-record-data-ns? rr-data)
|
|
(mc-name->octets (resource-record-data-ns-name rr-data) o-list a-list))
|
|
((resource-record-data-cname? rr-data)
|
|
(mc-name->octets (resource-record-data-cname-name rr-data)
|
|
o-list a-list))
|
|
((resource-record-data-mx? rr-data)
|
|
(mc-name->octets (resource-record-data-mx-exchanger rr-data)
|
|
(append o-list
|
|
(number->octet-pair
|
|
(resource-record-data-mx-preference rr-data)))
|
|
a-list))
|
|
((resource-record-data-ptr? rr-data)
|
|
(mc-name->octets (resource-record-data-ptr-name rr-data) o-list a-list))
|
|
((resource-record-data-soa? rr-data)
|
|
(receive (o-list a-list)
|
|
(mc-name->octets (resource-record-data-soa-mname rr-data)
|
|
o-list a-list)
|
|
(receive (o-list a-list)
|
|
(mc-name->octets
|
|
(resource-record-data-soa-rname rr-data)
|
|
o-list a-list)
|
|
(values
|
|
(append o-list
|
|
(number->octet-quad
|
|
(resource-record-data-soa-serial rr-data))
|
|
(number->octet-quad
|
|
(resource-record-data-soa-refresh rr-data))
|
|
(number->octet-quad
|
|
(resource-record-data-soa-retry rr-data))
|
|
(number->octet-quad
|
|
(resource-record-data-soa-expire rr-data))
|
|
(number->octet-quad
|
|
(resource-record-data-soa-minimum rr-data)))
|
|
a-list))))
|
|
((resource-record-data-txt? rr-data)
|
|
(values (append o-list (string-list->char-string-list
|
|
(resource-record-data-txt-text rr-data)))
|
|
a-list))
|
|
((resource-record-data-hinfo? rr-data)
|
|
(values (append o-list (string-list->char-string-list
|
|
(resource-record-data-hinfo-data rr-data))
|
|
a-list)))
|
|
((resource-record-data-wks? rr-data) ;; Deprecated
|
|
(values (append o-list (resource-record-data-wks-data rr-data) a-list)))
|
|
(else (error "unknown-resource-record"))))
|
|
(else (error "class not supported")))))
|
|
|
|
|
|
;; Handle the conversion of a RR into octets:
|
|
;; TYPE: RR x list-of-octets x list-of-names -> list-of-octets x list-of-names
|
|
(define (mc-resource-record->octets r o-list a-list)
|
|
(receive (o-list a-list)
|
|
(mc-name->octets (resource-record-name r) o-list a-list)
|
|
(let* ((o-list
|
|
(append o-list
|
|
(number->octet-pair
|
|
(message-type-number (resource-record-type r)))
|
|
(number->octet-pair
|
|
(message-class-number (resource-record-class r)))
|
|
(number->octet-quad (resource-record-ttl r))))
|
|
;; A placeholder value for RDLENGTH:
|
|
(o-list-w (append o-list (number->octet-pair 0))))
|
|
(receive (o-list-1 a-list-1)
|
|
(mc-rdata->octets r o-list-w a-list)
|
|
(let* ((l-ol (length o-list-w))
|
|
(oc-data (list-tail o-list-1 l-ol)))
|
|
(values (append o-list
|
|
(number->octet-pair (length oc-data))
|
|
oc-data)
|
|
a-list-1))))))
|
|
|
|
|
|
;; Converts a message-record-type into octets:
|
|
;; TYPE: message -> octet-message
|
|
(define (mc-message->octets m)
|
|
;; Convert the RRs:
|
|
(define fold-proc-for-rrs
|
|
(lambda (e p)
|
|
(receive (o-list a-list)
|
|
(mc-resource-record->octets e (car p) (cdr p))
|
|
(cons o-list a-list))))
|
|
|
|
;;(pretty-print-dns-message m)
|
|
(let* ((oct-header (header->octets (message-header m)))
|
|
(oct-q-pair
|
|
(fold ;; this is fold-left (srfi-1)
|
|
(lambda (e p)
|
|
(receive (o-list a-list)
|
|
(mc-question->octets e (car p) (cdr p))
|
|
(cons o-list a-list)))
|
|
(cons oct-header '())
|
|
(message-questions m)))
|
|
(oct-answ-pair
|
|
(fold fold-proc-for-rrs oct-q-pair (message-answers m)))
|
|
(oct-auth-pair
|
|
(fold fold-proc-for-rrs oct-answ-pair (message-nameservers m)))
|
|
(oct-addi-pair
|
|
(fold fold-proc-for-rrs oct-auth-pair (message-additionals m))))
|
|
(car oct-addi-pair)))
|
|
|
|
|
|
|
|
;; ---
|
|
|
|
;; Parse the resource records data-field:
|
|
|
|
(define (parse-resource-record-data type class data message)
|
|
|
|
(define (list-head l k)
|
|
(if (<= k (length l))
|
|
(let loop ((k k)
|
|
(l l)
|
|
(r '()))
|
|
(if (= 0 k)
|
|
r
|
|
(loop (- k 1)
|
|
(cdr l)
|
|
(append r (list (car l))))))
|
|
(error "list-head")))
|
|
|
|
(define (parse-char-strings data)
|
|
(let loop ((len (char->ascii (car data)))
|
|
(l (cdr data))
|
|
(res '()))
|
|
(let ((str (list->string (list-head l len))))
|
|
(if (> (length l) len)
|
|
(let ((tail (list-tail l len)))
|
|
(loop (char->ascii (car tail))
|
|
(cdr tail)
|
|
(append res (list str))))
|
|
(append res (list str))))))
|
|
|
|
(cond
|
|
((eq? type (message-type a))
|
|
(make-resource-record-data-a (octet-ip->address32 data)))
|
|
|
|
((eq? type (message-type aaaa))
|
|
(make-resource-record-data-aaaa data)) ; TODO ...
|
|
|
|
|
|
((eq? type (message-type ns))
|
|
(make-resource-record-data-ns (call-with-values
|
|
(lambda () (parse-name data message))
|
|
(lambda (name rest) name))))
|
|
|
|
((eq? type (message-type cname))
|
|
(make-resource-record-data-cname (call-with-values
|
|
(lambda () (parse-name data message))
|
|
(lambda (name rest) name))))
|
|
|
|
((eq? type (message-type mx))
|
|
(make-resource-record-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-resource-record-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-resource-record-data-soa mname rname serial refresh retry expire minimum)))))))))))
|
|
|
|
;; The TXT&Hinfo-Type contains one or more <character-strings>
|
|
;; (see. Ch.3.3// RFC 1035
|
|
((eq? type (message-type txt))
|
|
(make-resource-record-data-txt
|
|
(parse-char-strings data)))
|
|
|
|
((eq? type (message-type hinfo))
|
|
(parse-char-strings data))
|
|
|
|
((eq? type (message-type wks))
|
|
(make-resource-record-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))))
|
|
|
|
(define *max-tries* 3)
|
|
(define *timeout* 1)
|
|
|
|
;; connects to nameserver and sends and receives messages. returns the reply.
|
|
;; here: via TCP
|
|
(define (send-receive-message-tcp nameserver query)
|
|
(send-receive-message-tcp-int nameserver query reply-acceptable?))
|
|
|
|
(define (send-receive-message-tcp-int nameservers query accept?)
|
|
(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
|
|
(call-with-current-continuation
|
|
(lambda (k)
|
|
(with-handler (lambda (cond more)
|
|
(k #f))
|
|
(lambda ()
|
|
(connect-socket-no-wait sock addr)
|
|
sock))))))
|
|
nameservers)))
|
|
(let* ((nameservers
|
|
(let loop ((sockets sockets)
|
|
(nss nameservers))
|
|
(cond
|
|
((or (null? sockets) (null? nss)) '())
|
|
((socket? (car sockets))
|
|
(cons (car nss) (loop (cdr sockets) (cdr nss))))
|
|
(else (loop (cdr sockets) (cdr nss))))))
|
|
|
|
(sockets (filter socket? sockets))
|
|
(ws (map socket:outport sockets))
|
|
(wport-nameserver-alist (map cons ws nameservers))
|
|
(wport-socket-alist (map cons ws sockets)))
|
|
(dynamic-wind
|
|
(lambda ()
|
|
'nothing-to-be-done-before)
|
|
(lambda ()
|
|
(let loop-port-channels ((tried-channels '())
|
|
(number-tries 1))
|
|
(letrec ((delete-list
|
|
(lambda (elems list)
|
|
(cond
|
|
((null? elems) list)
|
|
((null? list) '())
|
|
(else (delete-list (cdr elems) (delete (car elems) list))))))
|
|
(ws-new (delete-list tried-channels ws)))
|
|
(if (or (null? ws-new) (>= number-tries *max-tries*))
|
|
(dns-error 'bad-nameserver)
|
|
(let ((ready (apply select-ports *timeout* ws)))
|
|
;; (let ((ready (apply select-port-channels *timeout* ws)))
|
|
(if (= (length tried-channels) (length ws))
|
|
(dns-error 'bad-nameserver)
|
|
(let loop-ready-channels ((ready-channels ready))
|
|
(if (null? ready-channels)
|
|
(loop-port-channels (append tried-channels ready) (+ number-tries 1))
|
|
(let* ((w (car ready-channels))
|
|
(hit-ns (cdr (assoc w wport-nameserver-alist)))
|
|
(sock (cdr (assoc w wport-socket-alist))))
|
|
(if (not (connect-socket-successful? sock))
|
|
(loop-ready-channels (cdr ready-channels))
|
|
(let ((query-string
|
|
(list->string (add-size-tag (message-source query))))
|
|
(r (socket:inport sock)))
|
|
(call-with-current-continuation
|
|
(lambda (k)
|
|
(with-handler (lambda (cond more)
|
|
(k (loop-ready-channels (cdr ready-channels))))
|
|
(lambda ()
|
|
(display 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 (and (not (= 0 (string-length s)))
|
|
(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)))))
|
|
(accept? reply query)
|
|
(values reply hit-ns other-nss)))
|
|
|
|
;; here: via UDP
|
|
(define (send-receive-message-udp nameserver query)
|
|
(send-receive-message-udp-int nameserver query reply-acceptable?))
|
|
|
|
(define (send-receive-message-udp-int nameservers query accept?)
|
|
(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 loop-port-channels ((tried-channels '())
|
|
(number-tries 1))
|
|
(letrec ((delete-list
|
|
(lambda (elems list)
|
|
(cond
|
|
((null? elems) list)
|
|
((null? list) '())
|
|
(else (delete-list (cdr elems) (delete (car elems) list))))))
|
|
(rs-new (delete-list tried-channels rs)))
|
|
(if (or (null? rs-new) (>= number-tries *max-tries*))
|
|
(dns-error 'bad-nameserver)
|
|
(let ((ready (apply select-ports *timeout* rs-new)))
|
|
;; (let ((ready (apply select-port-channels *timeout* rs-new)))
|
|
(if (= (length tried-channels) (length rs))
|
|
(dns-error 'bad-nameserver)
|
|
(let loop-ready-channels ((ready-channels ready))
|
|
(if (null? ready-channels)
|
|
(loop-port-channels (append tried-channels ready) (+ number-tries 1))
|
|
(let* ((r (car ready-channels))
|
|
(hit-ns (cdr (assoc r rport-nameserver-alist))))
|
|
(if (not (connect-socket-successful? (cdr (assoc r rport-socket-alist))))
|
|
(loop-ready-channels (cdr ready-channels))
|
|
;; 512 is the maximum udp-message size:
|
|
(let ((answer (string->list (read-string/partial 512 r))))
|
|
(if (null? answer)
|
|
(loop-ready-channels (cdr ready-channels))
|
|
(values (parse answer)
|
|
hit-ns
|
|
(delete hit-ns nameservers)))))))))))))))
|
|
(lambda ()
|
|
(for-each close-socket sockets)))))
|
|
(accept? reply query)
|
|
(if (flags-truncated? (header-flags (message-header reply)))
|
|
(send-receive-message-tcp-int nameservers query accept?)
|
|
(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)
|
|
((resource-record? dns-msg)
|
|
(cond
|
|
((not minimum) (set! minimum (resource-record-ttl dns-msg)))
|
|
(else
|
|
(if (and (not minimum) (> minimum (resource-record-ttl dns-msg)))
|
|
(set! minimum (resource-record-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-enumerated-type network-protocol :network-protocol
|
|
network-protocol?
|
|
network-protocols
|
|
network-protocol-name
|
|
network-protocol-index
|
|
(udp tcp))
|
|
|
|
(define (send-receive-message nameservers query protocol)
|
|
((cond
|
|
((eq? protocol (network-protocol tcp)) send-receive-message-tcp)
|
|
((eq? protocol (network-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.
|
|
; (The means of trying recursion are given by the check-answer proc)
|
|
|
|
|
|
(define (dns-get-information query protocol check-answer . args)
|
|
(receive (nameservers use-cache?) (lookup-optional-args args)
|
|
(let lp ((tried '()) (nss nameservers))
|
|
(display "Tried nameservers: ")
|
|
(map (lambda (x) (display (address32->ip-string x)) (display " ")) tried)(newline)
|
|
(display "Nameserver list: ")
|
|
(map (lambda (x) (display (address32->ip-string x)) (display " ")) nss)(newline)
|
|
(if (null? nss)
|
|
(if (null? tried)
|
|
(dns-error 'no-nameserver-given)
|
|
(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-rr
|
|
(filter (lambda (elem)
|
|
(eq? (resource-record-type elem)
|
|
(message-type a)))
|
|
(message-additionals
|
|
(dns-message-reply dns-msg))))
|
|
(other-nameservers
|
|
(map (lambda (e)
|
|
(resource-record-data-a-ip
|
|
(resource-record-data e)))
|
|
other-nameservers-rr)))
|
|
(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-condition-type 'resolv.conf-parse-error '(dns-error))
|
|
(define resolv.conf-parse-error? (condition-predicate 'resolv.conf-parse-error))
|
|
|
|
(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-file* "/etc/resolv.conf")
|
|
|
|
(define (resolv.conf)
|
|
(let ((actual-m-time (file-info:mtime (file-info *resolv.conf-file*))))
|
|
(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 *resolv.conf-file*)))
|
|
(contents (really-parse-resolv.conf *resolv.conf-file*)))
|
|
(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 (: bos (| "#" ";")))
|
|
l)
|
|
(loop rev-result))
|
|
((regexp-search
|
|
(rx (: bos "nameserver" (+ (| " " "\t")
|
|
(submatch (* any))
|
|
eos)))
|
|
l)
|
|
=> (lambda (match)
|
|
(loop (cons (parse-nameserver (match:substring match 1))
|
|
rev-result))))
|
|
((regexp-search
|
|
(rx (: bos "domain" (+ (| " " "\t")
|
|
(submatch (* any))
|
|
eos)))
|
|
l)
|
|
=> (lambda (match)
|
|
(loop (cons (parse-domain (match:substring match 1))
|
|
rev-result))))
|
|
((regexp-search
|
|
(rx (: bos "search" (+ (| " " "\t")
|
|
(submatch (* any))
|
|
eos)))
|
|
l)
|
|
=> (lambda (match)
|
|
(loop (cons (parse-search (match:substring match 1))
|
|
rev-result))))
|
|
|
|
((regexp-search
|
|
(rx (: bos "sortlist" (+ (| " " "\t")
|
|
(submatch (* any))
|
|
eos)))
|
|
l)
|
|
=> (lambda (match)
|
|
(loop (cons (parse-sortlist (match:substring match 1))
|
|
rev-result))))
|
|
|
|
|
|
((regexp-search
|
|
(rx (: bos "options" (+ (| " " "\t")
|
|
(submatch (* any))
|
|
eos)))
|
|
l)
|
|
=> (lambda (match)
|
|
(loop (cons (parse-options (match:substring match 1))
|
|
rev-result))))
|
|
;; skips lines with parse errors, instead of
|
|
;; raising a 'resolv.conf-parse-error
|
|
(else (loop rev-result))))))))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Figure out the default name servers
|
|
|
|
(define (dns-find-nameserver-list)
|
|
(cond ((assoc 'nameserver (resolv.conf))
|
|
=> (lambda (nameserver.list)
|
|
(cdr nameserver.list)))
|
|
(else '("127.0.0.1"))))
|
|
|
|
;; 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 if the nameservers are working, prints a summary
|
|
(define (dns-check-nameservers . args)
|
|
(let* ((print-summary
|
|
(lambda (working-channels non-working-channels)
|
|
(for-each (lambda (channel)
|
|
(display "FAIL: ")(display channel)
|
|
(display " - host not reachable.")(newline))
|
|
non-working-channels)
|
|
(for-each (lambda (channel)
|
|
(display "PASS: ")(display channel)
|
|
(display " - connection established.")(newline))
|
|
working-channels)
|
|
(if (null? working-channels)
|
|
(begin (display "ERROR: no working nameserver found.")(newline)))))
|
|
|
|
(nameservers (if (null? args)
|
|
(dns-find-nameserver-list)
|
|
(car args)))
|
|
(sockets (map
|
|
(lambda (nameserver)
|
|
(let ((sock (create-socket protocol-family/internet
|
|
socket-type/stream))
|
|
(addr (internet-address->socket-address
|
|
(ip-string->address32 nameserver) 53)))
|
|
(call-with-current-continuation
|
|
(lambda (k)
|
|
(with-handler (lambda (cond more)
|
|
(display "FAIL: ")
|
|
(display nameserver)
|
|
(display " - no DNS Service available.")
|
|
(newline)
|
|
(k #f))
|
|
(lambda ()
|
|
(connect-socket-no-wait sock addr)
|
|
sock))))))
|
|
nameservers)))
|
|
|
|
(let* ((nameservers
|
|
(let loop ((sockets sockets)
|
|
(nss nameservers))
|
|
(cond
|
|
((or (null? sockets) (null? nss)) '())
|
|
((socket? (car sockets))
|
|
(cons (car nss) (loop (cdr sockets) (cdr nss))))
|
|
(else (loop (cdr sockets) (cdr nss))))))
|
|
|
|
(sockets (filter socket? sockets))
|
|
(ws (map socket:outport sockets))
|
|
(wport-nameserver-alist (map cons ws nameservers))
|
|
(wport-socket-alist (map cons ws sockets)))
|
|
(dynamic-wind
|
|
(lambda ()
|
|
'nothing-to-be-done-before)
|
|
(lambda ()
|
|
(let loop-port-channels ((working-channels '())
|
|
(non-working-channels '())
|
|
(tried-channels '())
|
|
(number-tries 1))
|
|
(letrec ((delete-list
|
|
(lambda (elems list)
|
|
(cond
|
|
((null? elems) list)
|
|
((null? list) '())
|
|
(else (delete-list (cdr elems) (delete (car elems) list))))))
|
|
(ready (delete-list tried-channels
|
|
(apply select-port-channels *timeout* ws))))
|
|
|
|
(if (or (>= number-tries *max-tries*))
|
|
(print-summary working-channels
|
|
(delete-list working-channels
|
|
(delete-list non-working-channels
|
|
nameservers)))
|
|
(let loop-ready-channels ((working-channels working-channels)
|
|
(non-working-channels non-working-channels)
|
|
(ready-channels ready))
|
|
(if (null? ready-channels)
|
|
(loop-port-channels working-channels
|
|
non-working-channels
|
|
(append tried-channels ready)
|
|
(+ number-tries 1))
|
|
(let* ((w (car ready-channels))
|
|
(hit-ns (cdr (assoc w wport-nameserver-alist)))
|
|
(sock (cdr (assoc w wport-socket-alist))))
|
|
(if (connect-socket-successful? sock)
|
|
(loop-ready-channels (append working-channels (list hit-ns))
|
|
non-working-channels (cdr ready-channels))
|
|
(loop-ready-channels working-channels
|
|
(append non-working-channels
|
|
(list hit-ns))
|
|
(cdr ready-channels))))))))))
|
|
(lambda ()
|
|
(for-each close-socket sockets))))))
|
|
|
|
|
|
;; computes the nameservers argument of the lookup functions.
|
|
;; if a nameserver-name is given and not a nameserver-ip
|
|
;; (dns-lookup-name nameserver) is called.
|
|
;; use-cache? defaults to #t
|
|
(define (lookup-optional-args args)
|
|
(if (null? args)
|
|
(values (map ip-string->address32 (dns-find-nameserver-list)) #t)
|
|
(values
|
|
(map (lambda (nameserver)
|
|
(cond
|
|
((address32? nameserver) nameserver)
|
|
((ip-string? nameserver) (ip-string->address32 nameserver))
|
|
(else (map dns-lookup-name (dns-find-nameserver-list)))))
|
|
(car args))
|
|
(if (null? (cdr args))
|
|
#t
|
|
(cadr args)))))
|
|
|
|
;; dns-lookup with more options than dns-lookup-*
|
|
(define (dns-lookup name type . args)
|
|
(receive (nameservers use-cache?) (lookup-optional-args args)
|
|
(let* ((maybe-ip-string (if (address32? name)
|
|
(ip-string->in-addr.arpa-string (address32->ip-string name))
|
|
(ip-string->in-addr.arpa-string name)))
|
|
(query (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
|
|
(make-simple-query-message
|
|
maybe-ip-string type (message-class in))
|
|
(make-simple-query-message name type (message-class in))))
|
|
(protocol (network-protocol udp))
|
|
(check-answer (lambda (dns-msg) #t))
|
|
(dns-msg (dns-get-information query protocol check-answer nameservers use-cache?))
|
|
(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 . args)
|
|
(receive (nameservers use-cache?) (lookup-optional-args args)
|
|
(let* ((maybe-ip-string (if (address32? name)
|
|
(ip-string->in-addr.arpa-string (address32->ip-string name))
|
|
(ip-string->in-addr.arpa-string 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-message name (message-type a) (message-class in))))
|
|
(protocol (network-protocol udp))
|
|
(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 protocol check-answer nameservers use-cache?))
|
|
(answers (filter-type (message-answers (dns-message-reply dns-msg)) (message-type a))))
|
|
(resource-record-data-a-ip (resource-record-data (car answers))))))
|
|
|
|
;; looks up an ip, returns a hostname
|
|
;; (dns-inverse-lookup <name> [nameserver])
|
|
(define (dns-lookup-ip ip . args)
|
|
(receive (nameservers use-cache?) (lookup-optional-args args)
|
|
(let* ((maybe-ip-string (if (address32? ip)
|
|
(ip-string->in-addr.arpa-string (address32->ip-string ip))
|
|
(ip-string->in-addr.arpa-string ip)))
|
|
(query (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
|
|
(make-simple-query-message maybe-ip-string (message-type ptr) (message-class in))
|
|
(dns-error 'not-a-ip)))
|
|
(protocol (network-protocol udp))
|
|
(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 protocol check-answer nameservers use-cache?))
|
|
(answers (filter-type (message-answers (dns-message-reply dns-msg)) (message-type ptr))))
|
|
(resource-record-data-ptr-name (resource-record-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 . args)
|
|
(receive (nameservers use-cache?) (lookup-optional-args args)
|
|
(let* ((maybe-ip-string (if (address32? name)
|
|
(ip-string->in-addr.arpa-string (address32->ip-string name))
|
|
(ip-string->in-addr.arpa-string 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-message
|
|
name (message-type ns) (message-class in))))
|
|
(protocol (network-protocol udp))
|
|
(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 protocol check-answer nameservers use-cache?))
|
|
(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 (resource-record-data-soa-mname (resource-record-data (car soa)))))
|
|
(map (lambda (elem) (resource-record-data-a-ip (resource-record-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 . args)
|
|
(receive (nameservers use-cache?) (lookup-optional-args args)
|
|
(let* ((ip-string (if (address32? name)
|
|
(ip-string->in-addr.arpa-string (address32->ip-string name))
|
|
(ip-string->in-addr.arpa-string 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-message
|
|
name (message-type mx) (message-class in))))
|
|
(protocol (network-protocol tcp))
|
|
(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 protocol check-answer nameservers use-cache?))
|
|
(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 (resource-record-data-a-ip (resource-record-data (car a)))))
|
|
((not (null? cname))
|
|
(dns-lookup-mail-exchanger (resource-record-data-cname-name (resource-record-data (car cname)))))
|
|
((null? mx)
|
|
(list (resource-record-data-soa-rname (resource-record-data (car soa)))))
|
|
(else
|
|
(map (lambda (elem) (resource-record-data-mx-exchanger (resource-record-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 (network-protocol tcp)) "TCP")
|
|
((eq? protocol (network-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)))))
|
|
((resource-record? dns-msg)
|
|
(begin
|
|
(d 4 "name " (resource-record-name dns-msg))
|
|
(d 4 "type "(message-type-name (resource-record-type dns-msg)))
|
|
(d 4 "class" (message-class-name (resource-record-class dns-msg)))
|
|
(d 4 "ttl " (resource-record-ttl dns-msg))
|
|
(d 4 "data " "") (show-dns-message (resource-record-data dns-msg))))
|
|
((resource-record-data-a? dns-msg)
|
|
(d 5 "ip " (address32->ip-string (resource-record-data-a-ip dns-msg))))
|
|
((resource-record-data-aaaa? dns-msg)
|
|
(d 5 "ipv6 " (resource-record-data-aaaa-ipv6 dns-msg)))
|
|
((resource-record-data-ns? dns-msg)
|
|
(d 5 "name " (resource-record-data-ns-name dns-msg)))
|
|
((resource-record-data-cname? dns-msg)
|
|
(d 5 "name " (resource-record-data-cname-name dns-msg)))
|
|
((resource-record-data-mx? dns-msg)
|
|
(begin
|
|
(d 5 "preference " (resource-record-data-mx-preference dns-msg))
|
|
(d 5 "exchanger " (resource-record-data-mx-exchanger dns-msg))))
|
|
((resource-record-data-ptr? dns-msg)
|
|
(d 5 "name " (resource-record-data-ptr-name dns-msg)))
|
|
((resource-record-data-soa? dns-msg)
|
|
(begin
|
|
(d 5 "mname " (resource-record-data-soa-mname dns-msg))
|
|
(d 5 "rname " (resource-record-data-soa-rname dns-msg))
|
|
(d 5 "serial " (resource-record-data-soa-serial dns-msg))
|
|
(d 5 "refresh " (resource-record-data-soa-refresh dns-msg))
|
|
(d 5 "retry " (resource-record-data-soa-retry dns-msg))
|
|
(d 5 "expire " (resource-record-data-soa-expire dns-msg))
|
|
(d 5 "minimum " (resource-record-data-soa-minimum dns-msg))))
|
|
;; ###
|
|
((resource-record-data-hinfo? dns-msg)
|
|
(d 5 "data " (resource-record-data-hinfo-data dns-msg)))
|
|
((resource-record-data-txt? dns-msg)
|
|
(d 5 "text " (resource-record-data-txt-text dns-msg)))
|
|
((resource-record-data-wks? dns-msg)
|
|
(d 5 "data " (resource-record-data-wks-data dns-msg)))
|
|
))
|
|
(show-dns-message dns-msg)))))
|
|
|
|
(define (socket-address->fqdn addr . args)
|
|
(receive (ip32 port)
|
|
(socket-address->internet-address addr)
|
|
(apply dns-lookup-ip ip32 args)))
|
|
|
|
;; Some code to test the components of domain names
|
|
;;(define label-regexp
|
|
;; (rx (: alpha (? (* (| alphanumeric "-")) alphanumeric))))
|
|
;;(define (unqualified-hostname name)
|
|
;; (regexp-search? (rx (: ,label-regexp)) name))
|
|
|
|
|
|
(define (maybe-dns-lookup-name name . args)
|
|
(call-with-current-continuation
|
|
(lambda (k)
|
|
(with-handler (lambda (cond more)
|
|
(if (dns-error? cond)
|
|
(k #f)
|
|
(more)))
|
|
(lambda ()
|
|
(apply dns-lookup-name name args))))))
|
|
|
|
(define (maybe-dns-lookup-ip ip-addr . args)
|
|
(call-with-current-continuation
|
|
(lambda (k)
|
|
(with-handler (lambda (cond more)
|
|
(if (dns-error? cond)
|
|
(k #f)
|
|
(more)))
|
|
(lambda ()
|
|
(apply dns-lookup-ip ip-addr args))))))
|
|
|
|
(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 . args)
|
|
(if (socket-address? name-or-socket-address)
|
|
(apply socket-address->fqdn name-or-socket-address args)
|
|
(let ((name name-or-socket-address))
|
|
(cond ((apply maybe-dns-lookup-name name args)
|
|
=> (lambda (ip)
|
|
(apply dns-lookup-ip ip args)))
|
|
(else
|
|
(let lp ((domains (domains-for-search)))
|
|
(if (null? domains)
|
|
#f
|
|
(cond ((apply maybe-dns-lookup-name
|
|
(string-append name "." (car domains)) args)
|
|
=> (lambda (ip)
|
|
(apply dns-lookup-ip ip args)))
|
|
(else (lp (cdr domains)))))))))))
|
|
|
|
(define (system-fqdn . args)
|
|
(apply host-fqdn (system-name) args))
|