754 lines
25 KiB
Scheme
754 lines
25 KiB
Scheme
|
; ----------------
|
||
|
; --- Resolver ---
|
||
|
; ----------------
|
||
|
|
||
|
; A DNS-Server based on the RFCs: 1034 / 1035
|
||
|
|
||
|
; This file is part of the Scheme Untergrund Networking package
|
||
|
|
||
|
; Copyright (c) 2005/2006 by Norbert Freudemann
|
||
|
; <nofreude@informatik.uni-tuebingen.de>
|
||
|
|
||
|
; For copyright information, see the file COPYING which comes with
|
||
|
; the distribution.
|
||
|
|
||
|
; Interface:
|
||
|
; ----------
|
||
|
|
||
|
;(dnsd-ask-resolver-rec message protocol dnsd-options)
|
||
|
|
||
|
;(dnsd-ask-resolver-direct message list-of-nameservers protocol dnsd-options)
|
||
|
|
||
|
|
||
|
;; The modified send-receive-message socket-interface from dns.scm:
|
||
|
;; ----------------------------------------------------------------
|
||
|
|
||
|
;; Delete the given element(s) from the list:
|
||
|
;; TYPE: list x list -> list
|
||
|
(define (delete-list elems list)
|
||
|
(cond
|
||
|
((null? elems) list)
|
||
|
((null? list) '())
|
||
|
(else (delete-list (cdr elems) (delete (car elems) list)))))
|
||
|
|
||
|
|
||
|
;; dnsd wants the message, not the dns-error codes.
|
||
|
(define (dnsd-acceptable? reply query)
|
||
|
(if (not (= (header-id (message-header reply))
|
||
|
(header-id (message-header query))))
|
||
|
(error "send-receive-message: Bad reply-ID from server.")))
|
||
|
|
||
|
|
||
|
(define (dnsd-send-receive-message-tcp nameserver query dnsd-options)
|
||
|
(send-receive-message-tcp-int nameserver query dnsd-acceptable? dnsd-options))
|
||
|
|
||
|
(define (send-receive-message-tcp-int nameservers query accept? dnsd-options)
|
||
|
(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)))
|
||
|
;; Ignore return value and select unconditionally later
|
||
|
(with-fatal-error-handler*
|
||
|
(lambda (condition decline) #f)
|
||
|
(lambda ()
|
||
|
(connect-socket-no-wait sock addr) sock))))
|
||
|
nameservers))
|
||
|
(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)))
|
||
|
(with-fatal-error-handler*
|
||
|
(lambda (condition decline)
|
||
|
(for-each close-socket sockets)
|
||
|
decline)
|
||
|
(lambda ()
|
||
|
(dynamic-wind
|
||
|
(lambda () 'nothing-to-be-done-before)
|
||
|
(lambda ()
|
||
|
(let loop-port-channels ((tried-channels '())
|
||
|
(number-tries 1))
|
||
|
;; No channels left to try?
|
||
|
(if (or (null? (delete-list tried-channels ws))
|
||
|
(= (length tried-channels) (length ws))
|
||
|
(>= number-tries
|
||
|
(dnsd-options-socket-max-tries dnsd-options)))
|
||
|
(values query #f nameservers)
|
||
|
(let ((ready
|
||
|
(apply select-ports
|
||
|
(dnsd-options-socket-timeout dnsd-options)
|
||
|
ws)))
|
||
|
(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)))
|
||
|
(with-fatal-error-handler*
|
||
|
(lambda (condition decline)
|
||
|
(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))))
|
||
|
(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)))
|
||
|
|
||
|
|
||
|
(define (dnsd-send-receive-message-udp nameserver query dnsd-options)
|
||
|
(send-receive-message-udp-int nameserver query dnsd-acceptable? dnsd-options))
|
||
|
|
||
|
|
||
|
(define (send-receive-message-udp-int nameservers query accept? dnsd-options)
|
||
|
(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))
|
||
|
(rs (map socket:inport sockets))
|
||
|
(ws (map socket:outport sockets)))
|
||
|
(with-fatal-error-handler*
|
||
|
(lambda (condition decline)
|
||
|
(for-each close-socket sockets)
|
||
|
decline)
|
||
|
(lambda ()
|
||
|
(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))
|
||
|
(let ((rs-new (delete-list tried-channels rs)))
|
||
|
(if (or (null? rs-new)
|
||
|
(>= number-tries (dnsd-options-socket-max-tries dnsd-options))
|
||
|
(= (length tried-channels) (length rs)))
|
||
|
(values query #f nameservers)
|
||
|
(let ((ready (apply select-ports
|
||
|
(dnsd-options-socket-timeout dnsd-options)
|
||
|
rs-new)))
|
||
|
(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))))
|
||
|
|
||
|
|
||
|
(define (dnsd-send-receive-message nameservers query protocol dnsd-options)
|
||
|
((cond
|
||
|
((eq? protocol (network-protocol tcp)) dnsd-send-receive-message-tcp)
|
||
|
((eq? protocol (network-protocol udp)) dnsd-send-receive-message-udp))
|
||
|
nameservers query dnsd-options))
|
||
|
|
||
|
|
||
|
;; Stuff:
|
||
|
;; ------
|
||
|
|
||
|
; Filter a list of rrs of the given type:
|
||
|
; TYPE: list-of-rrs -> list-of-rrs
|
||
|
(define (filter-rr-type type list)
|
||
|
(filter (lambda (e) (eq? (resource-record-type e) type)) list))
|
||
|
|
||
|
|
||
|
;; Randomize a list (needs srfi-1 & srfi-27):
|
||
|
;; TYPE: list -> list
|
||
|
(define (shake-list l)
|
||
|
(define (shake-list-int l res)
|
||
|
(if (null? l)
|
||
|
res
|
||
|
(let ((random-value (random-integer (length l))))
|
||
|
(shake-list-int
|
||
|
(append (take l random-value) (drop l (+ 1 random-value)))
|
||
|
(cons (list-ref l random-value) res)))))
|
||
|
(shake-list-int l '()))
|
||
|
|
||
|
|
||
|
|
||
|
;; Check a message for its response-code:
|
||
|
;; --------------------------------------
|
||
|
|
||
|
;; RCODE-0-Message? (Error-Free)
|
||
|
;; TYPE: message -> boolean
|
||
|
(define (rcode-0-reply? msg)
|
||
|
(eq? 'dns-no-error (flags-response-code (header-flags (message-header msg)))))
|
||
|
|
||
|
|
||
|
;; RCODE-3-Message? (Name-Error (does not exist))
|
||
|
;; TYPE: message -> boolean
|
||
|
(define (rcode-3-reply? msg)
|
||
|
(eq? 'dns-name-error (flags-response-code
|
||
|
(header-flags (message-header msg)))))
|
||
|
|
||
|
|
||
|
;; RCODE-2-Message? Server-Failure
|
||
|
;; TYPE: message -> boolean
|
||
|
(define (rcode-2-reply? msg)
|
||
|
(eq? 'dns-server-failure (flags-response-code
|
||
|
(header-flags (message-header msg)))))
|
||
|
|
||
|
|
||
|
;; RCODE-4-Message? Not Implemented
|
||
|
;; TYPE: message -> boolean
|
||
|
(define (rcode-4-reply? msg)
|
||
|
(eq? 'dns-not-implemented (flags-response-code
|
||
|
(header-flags (message-header msg)))))
|
||
|
|
||
|
;; RCODE-5-Message? (Refused to answer query.)
|
||
|
;; TYPE: message -> boolean
|
||
|
(define (rcode-5-reply? msg)
|
||
|
(eq? 'dns-refused (flags-response-code (header-flags (message-header msg)))))
|
||
|
|
||
|
|
||
|
;; Are there just CNAMEs in the answer-section of a reply?
|
||
|
;; TYPE message -> boolean
|
||
|
(define (cname-answer? msg)
|
||
|
(let ((cnames (fold-right
|
||
|
(lambda (e b)
|
||
|
(or (eq? (message-type cname) (resource-record-type e)) b))
|
||
|
#f (message-answers msg)))
|
||
|
(other (fold-right
|
||
|
(lambda (e b)
|
||
|
(or (not (eq? (message-type cname)
|
||
|
(resource-record-type e))) b))
|
||
|
#f (message-answers msg))))
|
||
|
(if other #f cnames)))
|
||
|
|
||
|
|
||
|
;; Interpreting the results of dbi-lookup-rec - Zone found, but not the name.
|
||
|
;; TYPE res-list-of-db-lookup-rec -> boolean
|
||
|
(define (no-entry? res-l)
|
||
|
(and (null? (car res-l)) (null? (cadr res-l))
|
||
|
(null? (caddr res-l)) (cadddr res-l)))
|
||
|
|
||
|
|
||
|
;; Is the query a cname-question?
|
||
|
;; TYPE: message -> boolean
|
||
|
(define (cname-question? msg)
|
||
|
(eq? (message-type cname) (question-type (car (message-questions msg)))))
|
||
|
|
||
|
|
||
|
;; Create a reply from the internally found (db or cache) information.
|
||
|
;; NOTE: This function is part of the exported functions.
|
||
|
;; TYPE: message x res-list-of-db-lookup-rec x dnsd-options -> message
|
||
|
(define (make-response message r-list dnsd-options)
|
||
|
(let* ((use-recursion? (dnsd-options-use-recursion? dnsd-options))
|
||
|
(error-code (if (no-entry? r-list) 'dns-name-error 'dns-no-error))
|
||
|
(msg-header (message-header message))
|
||
|
(msg-flags (header-flags msg-header))
|
||
|
(anli (car r-list))
|
||
|
(auli (cadr r-list))
|
||
|
(adli (caddr r-list))
|
||
|
(aufl (cadddr r-list)))
|
||
|
(make-message
|
||
|
(make-header (header-id msg-header)
|
||
|
(make-flags
|
||
|
'response
|
||
|
(flags-opcode msg-flags)
|
||
|
aufl
|
||
|
(flags-truncated? msg-flags)
|
||
|
(flags-recursion-desired? msg-flags)
|
||
|
use-recursion?
|
||
|
(flags-zero msg-flags)
|
||
|
error-code)
|
||
|
(header-question-count msg-header)
|
||
|
(length anli)
|
||
|
(length auli)
|
||
|
(length adli))
|
||
|
(message-questions message)
|
||
|
anli auli adli '())))
|
||
|
|
||
|
|
||
|
;; Increment the answer-section (for adding a cname)
|
||
|
;; TYPE: message -> message
|
||
|
(define (msg-inc-answers msg-header)
|
||
|
(let ((msg-flags (header-flags msg-header)))
|
||
|
(make-header (header-id msg-header)
|
||
|
msg-flags
|
||
|
(header-question-count msg-header)
|
||
|
(+ 1 (header-answer-count msg-header))
|
||
|
(header-nameserver-count msg-header)
|
||
|
(header-additional-count msg-header))))
|
||
|
|
||
|
|
||
|
;; Change the type of a question to (message-type cname)
|
||
|
;; TYPE: messag -> message
|
||
|
(define (msg->cname-msg msg)
|
||
|
(let ((q (car (message-questions msg))))
|
||
|
(make-message (message-header msg)
|
||
|
(list (make-question (question-name q)
|
||
|
(message-type cname)
|
||
|
(question-class q)))
|
||
|
(message-answers msg)
|
||
|
(message-nameservers msg)
|
||
|
(message-additionals msg) '())))
|
||
|
|
||
|
|
||
|
;; Assignment procs:
|
||
|
;; -----------------
|
||
|
|
||
|
;; Set the recursion-aviable flag:
|
||
|
;; TYPE: message x boolean -> message
|
||
|
(define (msg-set-recursion-aviable! msg bool)
|
||
|
(set-flags-recursion-available! (header-flags (message-header msg)) bool))
|
||
|
|
||
|
|
||
|
;; Set the response-code of a message:
|
||
|
;; NOTE: This function is part of the exported functions.
|
||
|
;; TYPE: message x rcode -> message
|
||
|
(define (msg-set-rcode! msg code)
|
||
|
(let ((rcode (case code
|
||
|
((0) 'dns-no-error)
|
||
|
((1) 'dns-format-error)
|
||
|
((2) 'dns-server-failure)
|
||
|
((3) 'dns-name-error)
|
||
|
((4) 'dns-not-implemented)
|
||
|
((5) 'dns-refused)
|
||
|
(else code))))
|
||
|
(set-flags-response-code! (header-flags (message-header msg)) rcode)))
|
||
|
|
||
|
|
||
|
;; Direct lookup:
|
||
|
;; --------------
|
||
|
|
||
|
;; Direct lookup of a query asking the given Nameserves:
|
||
|
;; TYPE: message x list-of-address32 tcp/udp x dnsd-options -> message
|
||
|
(define (dnsd-lookup-direct msg ns-list proto dnsd-options)
|
||
|
(receive (msg hit-ip other-ips)
|
||
|
(dnsd-send-receive-message
|
||
|
ns-list
|
||
|
(make-message (message-header msg) (message-questions msg)
|
||
|
(message-answers msg) (message-nameservers msg)
|
||
|
(message-additionals msg) (mc-message->octets msg))
|
||
|
proto dnsd-options)
|
||
|
(if hit-ip
|
||
|
msg
|
||
|
(begin
|
||
|
(dnsd-log (syslog-level info)
|
||
|
"dnsd-direct-lookup. Nameservers ~S not reachable."
|
||
|
ns-list)
|
||
|
(error "dnsd-direct-lookup. No NS reachable.")))))
|
||
|
|
||
|
|
||
|
|
||
|
|
||
|
;; Stuff for recursive lookup:
|
||
|
;; ---------------------------
|
||
|
|
||
|
|
||
|
;; SBELT:
|
||
|
;; ------
|
||
|
|
||
|
;; Fallback nameserver for recursive lookup. This is the default value which
|
||
|
;; can be changed by the dnsd-options:
|
||
|
(define *sbelt*
|
||
|
(list ;(ip-string->address32 "192.5.5.241")
|
||
|
(ip-string->address32 "192.36.148.17")
|
||
|
(ip-string->address32 "192.5.5.241")))
|
||
|
|
||
|
|
||
|
;; Some nameserver IPs:
|
||
|
;; --------------------
|
||
|
|
||
|
;; 192.36.148.17 i.root-servers.net. (for .)
|
||
|
;; 192.5.5.241 f.root-server.net. (for .)
|
||
|
|
||
|
;; 192.5.6.30 A.GTLD-SERVERS.NET. (for .com.
|
||
|
;; 193.159.170.187 deNIC-NS (for .de.)
|
||
|
|
||
|
|
||
|
;; Record-Type for additional information needed by the lookup:
|
||
|
;; cnames is a list of all seen CNAMES to avoid CNAME-loops.
|
||
|
;; ips is a list of used NS-IPs for the query.
|
||
|
;; timestamp is the creation-time of the context and used for timeouts.
|
||
|
(define-record-type context :context
|
||
|
(really-make-context cnames ips timestamp)
|
||
|
context?
|
||
|
(cnames get-context-cnames set-context-cnames!)
|
||
|
(ips get-context-ips set-context-ips!)
|
||
|
(timestamp get-context-timestamp))
|
||
|
|
||
|
|
||
|
;; Makes the lookup-context for a given query.
|
||
|
;; TYPE: message -> context
|
||
|
(define (make-context message)
|
||
|
(really-make-context
|
||
|
(list (question-name (car (message-questions message))))
|
||
|
'()
|
||
|
(time)))
|
||
|
|
||
|
;; Add a name to the context.
|
||
|
;; TYPE: context x string -> context
|
||
|
(define (update-context-cnames! context value)
|
||
|
(set-context-cnames! context (cons value (get-context-cnames context)))
|
||
|
context)
|
||
|
|
||
|
;; Add a IP to the context.
|
||
|
;; TYPE: context x address32 -> context
|
||
|
(define (update-context-ips! context value)
|
||
|
(set-context-ips! context (cons value (get-context-ips context)))
|
||
|
context)
|
||
|
|
||
|
|
||
|
;; Search the SLIST for the best 'nearest' nameserver to query for a message.
|
||
|
;; The nearest server is the server for the domain with the most matching labels
|
||
|
;; seen from the root: 1) www.example.com. 2) example.com. 3) com. 4) . 5) SBELT
|
||
|
;; TYPE: message x dnsd-options -> list-of-nameserver-ips x zone-name-of-ns
|
||
|
(define (search-for-ns-ips msg dnsd-options)
|
||
|
(let* ((q (car (message-questions msg)))
|
||
|
(name (question-name q))
|
||
|
(class (question-class q)))
|
||
|
(let loop ((name name))
|
||
|
(let ((ip-list (dnsd-slist-lookup
|
||
|
(make-simple-query-message name (message-type ns) class)
|
||
|
dnsd-options)))
|
||
|
(if ip-list
|
||
|
(values ip-list name #f)
|
||
|
(if (string=? "." name)
|
||
|
(let* ((sbelt-string (dnsd-options-nameservers dnsd-options))
|
||
|
(sbelt (map ip-string->address32 sbelt-string)))
|
||
|
(if (null? sbelt)
|
||
|
(values *sbelt* name #t)
|
||
|
(values sbelt name #t)))
|
||
|
(loop (cut-name name))))))))
|
||
|
|
||
|
|
||
|
;; Ask the message to some NS from the SLIST. Keep track which NSs were already
|
||
|
;; contacted for the given query in 'context'.
|
||
|
;; TYPE: message x udp/tcp x dnsd-options x context
|
||
|
;; -> message-answer x context x nearest-NS-string x address32
|
||
|
(define (ask-nameservers msg protocol dnsd-options context)
|
||
|
(receive
|
||
|
(ip-list name sbelt?)
|
||
|
(search-for-ns-ips msg dnsd-options)
|
||
|
;; Use only IPs which haven't been tried jet
|
||
|
(let ((good-ips (filter (lambda (e)
|
||
|
(not (fold-right
|
||
|
(lambda (e1 b)
|
||
|
(or b (= e1 e)))
|
||
|
#f (get-context-ips context))))
|
||
|
ip-list)))
|
||
|
;; randomize the list for some simple load-balancing...
|
||
|
(let loop ((good-ips (shake-list good-ips)))
|
||
|
(if (null? good-ips)
|
||
|
(error "ask-nameservers: Tried all known Nameservers.")
|
||
|
(receive
|
||
|
(msg hit-ip other-ips)
|
||
|
(dnsd-send-receive-message
|
||
|
(list (car good-ips))
|
||
|
(make-message (message-header msg) (message-questions msg)
|
||
|
(message-answers msg) (message-nameservers msg)
|
||
|
(message-additionals msg) (mc-message->octets msg))
|
||
|
protocol dnsd-options)
|
||
|
(if hit-ip
|
||
|
(values msg (update-context-ips! context hit-ip)
|
||
|
name hit-ip)
|
||
|
(begin
|
||
|
(if (not sbelt?) (dnsd-blacklist! (car good-ips)))
|
||
|
(loop (cdr good-ips))))))))))
|
||
|
|
||
|
|
||
|
|
||
|
;; Some responses contain nameserver-names but sadly not their IPs.
|
||
|
;; This function searches for those IPs, add the results to the
|
||
|
;; cache and restarts the recursive lookup.
|
||
|
;; TYPE: message x udp/tcp x list-of-rrs x dnsd-options -> unspecific
|
||
|
(define (lookup-nameserver-ips msg protocol ns-rrs dnsd-options)
|
||
|
(let* ((ns-names (map (lambda (e) (resource-record-data-ns-name
|
||
|
(resource-record-data e))) ns-rrs))
|
||
|
(ns-queries (map (lambda (e)
|
||
|
;;(display-debug "Looking for this names: " e)
|
||
|
(make-simple-query-message
|
||
|
e (message-type a)
|
||
|
(question-class
|
||
|
(car (message-questions msg))))) ns-names))
|
||
|
; ;; This step might take a while :-(
|
||
|
; (answers (map (lambda (e)
|
||
|
; (dnsd-ask-resolver-rec e protocol dnsd-options))
|
||
|
; ns-queries))
|
||
|
;; Concurrent lookup of the IPs:
|
||
|
(ch-list (map
|
||
|
(lambda (msg)
|
||
|
(let ((ch-res (make-channel)))
|
||
|
(fork-thread
|
||
|
(lambda ()
|
||
|
(sync (send-rv
|
||
|
ch-res
|
||
|
;; Use dnsd-ask-r... because of the 'good'
|
||
|
;; return value.
|
||
|
(dnsd-ask-resolver-rec msg protocol
|
||
|
dnsd-options)))))
|
||
|
ch-res))
|
||
|
ns-queries))
|
||
|
;; Wait for all results:
|
||
|
(answers (map (lambda (ch) (sync (receive-rv ch))) ch-list))
|
||
|
(good-answers (filter (lambda (e) (rcode-0-reply? e)) answers))
|
||
|
(ip-rrs (map (lambda (msg) (filter-rr-type (message-type a)
|
||
|
(message-answers msg)))
|
||
|
good-answers))
|
||
|
(flat-ns-list (fold-right (lambda (e l) (append e l)) '() ip-rrs)))
|
||
|
(if (null? flat-ns-list)
|
||
|
#f ;TODO: Do we need a strategy to avoid loops if we don't find NS?
|
||
|
(dnsd-slist-update!
|
||
|
(make-message (message-header msg) (message-questions msg)
|
||
|
'() ns-rrs flat-ns-list '())))))
|
||
|
|
||
|
|
||
|
;; Restart dnsd-get-info-int with question-name changed to the cname.
|
||
|
;; TYPE: query-message x response-message x udp/tcp x dnsd-options x context
|
||
|
;; -> respones-message
|
||
|
(define (cname-lookup msg res protocol dnsd-options context)
|
||
|
(let* ((q (car (message-questions msg)))
|
||
|
(msg-name (question-name q))
|
||
|
(cname-rr (fold-right
|
||
|
(lambda (e a)
|
||
|
(if a a
|
||
|
(if (and (eq? (message-type cname)
|
||
|
(resource-record-type e))
|
||
|
(string-ci=? (resource-record-name e)
|
||
|
msg-name))
|
||
|
e a)))
|
||
|
#f (message-answers res)))
|
||
|
(cname (resource-record-data-cname-name
|
||
|
(resource-record-data cname-rr)))
|
||
|
(found-loop? (fold-right (lambda (e b)
|
||
|
(or (string-ci=? cname e) b))
|
||
|
#f (get-context-cnames context))))
|
||
|
(if found-loop? ; Check for CNAME-Loop
|
||
|
(begin ;;(display-debug "Found a CNAME-loop. Aborting!")
|
||
|
(error "Found a CNAME-loop. Aborting recursive lookup."))
|
||
|
(let* ((new-msg (make-message (message-header msg)
|
||
|
(list (make-question cname
|
||
|
(question-type q)
|
||
|
(question-class q)))
|
||
|
'() '() '() '()))
|
||
|
(res (dnsd-get-info-int new-msg protocol dnsd-options
|
||
|
;; Keep timout, allow all IPs again...
|
||
|
(really-make-context
|
||
|
(cons cname (get-context-cnames context))
|
||
|
'()
|
||
|
(get-context-timestamp context))))
|
||
|
(new-res (make-message (msg-inc-answers (message-header res))
|
||
|
(message-questions msg)
|
||
|
(cons cname-rr (message-answers res))
|
||
|
(message-nameservers res)
|
||
|
(message-additionals res) '())))
|
||
|
new-res))))
|
||
|
|
||
|
|
||
|
|
||
|
;; Recursive Lookup as seen in RFC 1034:
|
||
|
;; -------------------------------------
|
||
|
|
||
|
;; 1) Check local information and (if present) return it to the client.
|
||
|
;; 2) Search for server(s) to ask. Wait for a response.
|
||
|
;; 3) Analyze the response:
|
||
|
;; 3.1 cache answers or name error.
|
||
|
;; 3.2 cache delegation info to other servers. Retry.
|
||
|
;; 3.3 if the response shows a CNAME and that is not the
|
||
|
;; answer itself, cache the CNAME, change the SNAME to the
|
||
|
;; canonical name in the CNAME RR and go to step 1.
|
||
|
;; 3.4 servers failure etc.: delete server from cache. Retry.
|
||
|
|
||
|
|
||
|
;; Start the recursive lookup and initialize the first context-list
|
||
|
;; with the name of the question (to avoid CNAME-Loops).
|
||
|
;; TYPE: message x udp/tcp x dnsd-options -> message
|
||
|
(define (dnsd-get-information message protocol dnsd-options)
|
||
|
(dnsd-get-info-int message protocol dnsd-options (make-context message)))
|
||
|
|
||
|
|
||
|
;; TYPE: message x udp/tcp x dnsd-options x context -> message
|
||
|
(define (dnsd-get-info-int message protocol dnsd-options context)
|
||
|
; 1) Search local information:
|
||
|
(let* ((use-cache? (dnsd-options-use-cache? dnsd-options))
|
||
|
(local-res (if use-cache? (dnsd-cache-lookup? message) #f)))
|
||
|
;; Timeout?
|
||
|
(if (> (- (time) (get-context-timestamp context))
|
||
|
(dnsd-options-rec-timeout dnsd-options))
|
||
|
(error "dnsd-get-info-int: Global timeout.")
|
||
|
(if local-res (make-response message local-res dnsd-options)
|
||
|
;; 2) Could be: Search for the best nameserver to ask.
|
||
|
;; Now it's: Ask all servers concurrent and take
|
||
|
;; the first result.
|
||
|
(receive
|
||
|
(rec-res context followed-name hit-ip)
|
||
|
(ask-nameservers message protocol dnsd-options context)
|
||
|
;; 3) Analyze the response:
|
||
|
(let* ((ns-rrs (filter-rr-type (message-type ns)
|
||
|
(message-nameservers rec-res)))
|
||
|
(a-rrs (filter-rr-type (message-type a)
|
||
|
(message-additionals rec-res))))
|
||
|
(cond
|
||
|
;; 3.4) Bad answer: Some NS are to 'lazy' to return cnames
|
||
|
;; and return RCODE 5 instead. The NS of sourceforge.net.
|
||
|
;; are a good bad example.
|
||
|
((rcode-5-reply? rec-res)
|
||
|
(if (not (cname-question? rec-res))
|
||
|
(let ((cname-query
|
||
|
(dnsd-get-information (msg->cname-msg message)
|
||
|
protocol dnsd-options)))
|
||
|
(if (cname-answer? cname-query)
|
||
|
(cname-lookup message cname-query protocol
|
||
|
dnsd-options context)
|
||
|
(begin (dnsd-blacklist! hit-ip)
|
||
|
rec-res)))
|
||
|
(begin (dnsd-blacklist! hit-ip) rec-res)))
|
||
|
;; 3.4) Try again with other servers.
|
||
|
((rcode-2-reply? rec-res)
|
||
|
(dnsd-blacklist! hit-ip)
|
||
|
(dnsd-get-info-int message protocol dnsd-options context))
|
||
|
((rcode-4-reply? rec-res)
|
||
|
(dnsd-blacklist! hit-ip
|
||
|
(dnsd-options-blacklist-value dnsd-options))
|
||
|
(dnsd-get-info-int message protocol dnsd-options context))
|
||
|
(else
|
||
|
;; A "good" reply.
|
||
|
(dnsd-blacklist-unlist! hit-ip dnsd-options)
|
||
|
(cond
|
||
|
;; 3.1) Found a name-error.
|
||
|
((rcode-3-reply? rec-res)
|
||
|
(dnsd-cache-update! rec-res) rec-res)
|
||
|
;; 3.4) Whatever error is left... .
|
||
|
((not (rcode-0-reply? rec-res)) rec-res)
|
||
|
;; 3.1) Found an answer.
|
||
|
((not (null? (message-answers rec-res)))
|
||
|
;; 3.3) CNAME?
|
||
|
(if (and (not (cname-question? rec-res))
|
||
|
(cname-answer? rec-res))
|
||
|
(begin
|
||
|
(dnsd-cache-update! (msg->cname-msg rec-res))
|
||
|
;;(display-debug "Starting CNAME Lookup!")
|
||
|
(cname-lookup message rec-res protocol
|
||
|
dnsd-options context))
|
||
|
;; Returning of not-authoritative data
|
||
|
;; may be a bad habbit...
|
||
|
(if (flags-authoritative?
|
||
|
(header-flags (message-header rec-res)))
|
||
|
rec-res
|
||
|
rec-res)))
|
||
|
(else
|
||
|
;; 3.2) Redirection to other Nameservers?
|
||
|
(cond
|
||
|
((null? ns-rrs) rec-res)
|
||
|
((null? a-rrs)
|
||
|
;; Only nameserver resource-records, search for IPs
|
||
|
(lookup-nameserver-ips rec-res protocol
|
||
|
ns-rrs dnsd-options)
|
||
|
(dnsd-get-info-int message protocol dnsd-options context))
|
||
|
(else
|
||
|
(dnsd-slist-update! rec-res)
|
||
|
(dnsd-get-info-int message protocol
|
||
|
dnsd-options context)))))))))))))
|
||
|
|
||
|
|
||
|
|
||
|
;; ---------------------------------
|
||
|
;; --- Server/Resolver-Interface ---
|
||
|
;; ---------------------------------
|
||
|
|
||
|
;; (dnsd-ask-resolver-direct msg nameserver-list protocol dnsd-options)
|
||
|
;; - Ask a specific nameserver (& don't use the SLIST-Interface.)
|
||
|
;; (E.g. for the AXFR-Update algorihms.)
|
||
|
;;
|
||
|
;; (dnsd-ask-resolver-rec msg protocol dnsd-options)
|
||
|
;; - Ask indirect (and recursive) via the SLIST-Cache.
|
||
|
|
||
|
|
||
|
;; TYPE: message x upd/tcp x dnsd-options -> message
|
||
|
(define (dnsd-ask-resolver-rec msg proto dnsd-options)
|
||
|
(set-message-source! msg (mc-message->octets msg))
|
||
|
(let ((ch-timeout (make-channel))
|
||
|
(ch-res (make-channel)))
|
||
|
(fork-thread
|
||
|
(lambda ()
|
||
|
(sleep (* 1000 (dnsd-options-rec-timeout dnsd-options)))
|
||
|
(sync (send-rv ch-timeout #t))))
|
||
|
(fork-thread
|
||
|
(lambda ()
|
||
|
(with-fatal-error-handler*
|
||
|
(lambda (condition decline)
|
||
|
(dnsd-log (syslog-level debug)
|
||
|
"Error during recursive lookup.")
|
||
|
(msg-set-rcode! msg 2)
|
||
|
msg)
|
||
|
(lambda ()
|
||
|
(sync (send-rv ch-res (dnsd-get-information msg
|
||
|
proto dnsd-options)))))))
|
||
|
(sync
|
||
|
(choose
|
||
|
(wrap (receive-rv ch-timeout)
|
||
|
(lambda (ignore)
|
||
|
(dnsd-log (syslog-level info)
|
||
|
"Timeout during recursive lookup. Current value is ~Ds"
|
||
|
(dnsd-options-rec-timeout dnsd-options))
|
||
|
(msg-set-rcode! msg 2) msg))
|
||
|
(wrap (receive-rv ch-res)
|
||
|
(lambda (value)
|
||
|
value))))))
|
||
|
|
||
|
|
||
|
;; TYPE: message x list-of-address32 x upd/tcp x dnsd-options -> message
|
||
|
(define (dnsd-ask-resolver-direct msg nameservers proto dnsd-options)
|
||
|
(set-message-source! msg (mc-message->octets msg))
|
||
|
(with-fatal-error-handler*
|
||
|
(lambda (condition decline)
|
||
|
(dnsd-log (syslog-level debug)
|
||
|
"Error during direct lookup.")
|
||
|
(msg-set-rcode! msg 2)
|
||
|
msg)
|
||
|
(lambda ()
|
||
|
(dnsd-lookup-direct msg nameservers proto dnsd-options))))
|
||
|
|
||
|
|
||
|
|