Steps toward a working proxy. Next: another stab at the resolution algorithm
This commit is contained in:
parent
6c8727f15c
commit
198cafba3c
118
proxy.rkt
118
proxy.rkt
|
@ -90,6 +90,42 @@
|
||||||
;; ServerState
|
;; ServerState
|
||||||
(struct world (roots continuations) #:prefab)
|
(struct world (roots continuations) #:prefab)
|
||||||
|
|
||||||
|
(define action-prompt (make-continuation-prompt-tag 'world-action))
|
||||||
|
|
||||||
|
;; TODO: Avoid attack amplification by not starting work on questions
|
||||||
|
;; that are already underway
|
||||||
|
|
||||||
|
;; TODO: Timeouts!!
|
||||||
|
|
||||||
|
(define (send/suspend outbound-messages awaken-key)
|
||||||
|
(call-with-composable-continuation
|
||||||
|
(lambda (k)
|
||||||
|
(abort-current-continuation action-prompt
|
||||||
|
(lambda () (values (lambda (w k)
|
||||||
|
(values outbound-messages
|
||||||
|
(struct-copy world w
|
||||||
|
[continuations (hash-set (world-continuations w)
|
||||||
|
awaken-key
|
||||||
|
k)])))
|
||||||
|
k))))
|
||||||
|
action-prompt))
|
||||||
|
|
||||||
|
;; ( -> X) ServerState -> X ServerState
|
||||||
|
;; In this specific instance, X is likely to be ListOf<WorldMessage>.
|
||||||
|
(define (run-inferior boot world)
|
||||||
|
(call-with-continuation-barrier ;; TODO: ???
|
||||||
|
(lambda ()
|
||||||
|
(define-values (computation-step-result computation-step-continuation)
|
||||||
|
(call-with-continuation-prompt (lambda () (values (boot) #f)) action-prompt))
|
||||||
|
(cond
|
||||||
|
((eq? computation-step-continuation #f)
|
||||||
|
;; The computation is finished, and has yielded a result.
|
||||||
|
(values computation-step-result world))
|
||||||
|
(else
|
||||||
|
;; The computation is not finished, but is waiting for an
|
||||||
|
;; action to complete.
|
||||||
|
(computation-step-result world computation-step-continuation))))))
|
||||||
|
|
||||||
;; start-proxy : UInt16 ListOf<RR> -> Void
|
;; start-proxy : UInt16 ListOf<RR> -> Void
|
||||||
;; Starts a proxy service that will answer questions received on the
|
;; Starts a proxy service that will answer questions received on the
|
||||||
;; given UDP port based on the NS RRs it is given.
|
;; given UDP port based on the NS RRs it is given.
|
||||||
|
@ -163,31 +199,51 @@
|
||||||
request-source
|
request-source
|
||||||
request-target)
|
request-target)
|
||||||
r)
|
r)
|
||||||
|
(if (null? questions)
|
||||||
|
(values '() old-world)
|
||||||
|
;; TODO: ignoring all but the car - good? bad? hmm?
|
||||||
|
(answer-question (car questions) old-world (world-roots old-world)
|
||||||
|
query-id recursion-desired request-source)))
|
||||||
|
|
||||||
(let loop ((remaining-questions questions)
|
;; resolve-iteratively : Question SetOf<RR> -> QuestionResult
|
||||||
(outbound-messages '())
|
;; Follows a chain of referrals until it finds an answer to its
|
||||||
(w old-world)
|
;; question.
|
||||||
(temporary-cache (world-roots old-world)))
|
(define (resolve-iteratively q ns-rrset)
|
||||||
(if (null? remaining-questions)
|
(let search ((seen (set))
|
||||||
(values outbound-messages w)
|
(remaining (set->list ns-rrset)))
|
||||||
(let ((q (car remaining-questions)))
|
(cond
|
||||||
(define-values (answer new-w new-cache) (answer-question q w temporary-cache))
|
[(null? remaining) #f] ;; no answer available
|
||||||
(loop (cdr remaining-questions)
|
[(set-member? (car remaining) seen) (search seen (cdr remaining))]
|
||||||
(if answer
|
[else
|
||||||
(cons answer outbound-messages)
|
(define first-ns-rr (car remaining))
|
||||||
outbound-messages)
|
(define ns-name (rr-name first-ns-rr))
|
||||||
new-w
|
(define ns-addr
|
||||||
new-cache)))))
|
.......
|
||||||
|
Should the main algorithm iterate to solution/fixpoint instead of recursing?
|
||||||
|
If so, how should it treat cnames?
|
||||||
|
(pretty-print 'resolve-iteratively)
|
||||||
|
(define sub-query-id (random 65536)
|
||||||
|
(define sub-query (dns-message sub-query-id
|
||||||
|
'request
|
||||||
|
'query
|
||||||
|
'non-authoritative
|
||||||
|
'not-truncated
|
||||||
|
#f
|
||||||
|
'no-recursion-available
|
||||||
|
'no-error
|
||||||
|
(list q)
|
||||||
|
(list)
|
||||||
|
(list)
|
||||||
|
(list)))
|
||||||
|
(pretty-print `(back with ,(send/suspend
|
||||||
|
|
||||||
;; TODO: OMG this is a total toy proxy implementation. Pays attention
|
(error 'resolve-iteratively "Gah!"))
|
||||||
;; to NONE of the sensible guidelines or even the rules for
|
|
||||||
;; implementing DNS. It's pushing it and in slightly bad taste to even
|
|
||||||
;; call this DNS.
|
|
||||||
(define (answer-question q w cache)
|
|
||||||
(match-define (struct* question ([name name])) q)
|
|
||||||
|
|
||||||
|
;; TODO: Make sure we follow the guidelines and rules for implementing
|
||||||
(values ( (world-message (dns-message query-id
|
;; DNS proxies more strictly.
|
||||||
|
(define (answer-question q w cache query-id recursion-desired request-source)
|
||||||
|
(define (make-answer ns us ds)
|
||||||
|
(list (world-message (dns-message query-id
|
||||||
'response
|
'response
|
||||||
'query
|
'query
|
||||||
'non-authoritative
|
'non-authoritative
|
||||||
|
@ -195,13 +251,19 @@
|
||||||
recursion-desired
|
recursion-desired
|
||||||
'recursion-available
|
'recursion-available
|
||||||
'no-error
|
'no-error
|
||||||
questions
|
(list q)
|
||||||
(list)
|
ns
|
||||||
(list)
|
us
|
||||||
(list))
|
ds)
|
||||||
#f
|
#f
|
||||||
request-source))
|
request-source)))
|
||||||
old-world))
|
(run-inferior (lambda ()
|
||||||
|
(match (resolve-from-zone q #f cache resolve-iteratively)
|
||||||
|
[#f
|
||||||
|
(make-answer '() '() '())]
|
||||||
|
[(question-result _ new-cache answers authorities additional)
|
||||||
|
(make-answer answers authorities additional)]))
|
||||||
|
w))
|
||||||
|
|
||||||
(define (handle-reply r old-world)
|
(define (handle-reply r old-world)
|
||||||
(error 'handle-reply "Unimplemented"))
|
(error 'handle-reply "Unimplemented"))
|
||||||
|
|
|
@ -79,6 +79,11 @@
|
||||||
(match-define (dns-reply message host port) r)
|
(match-define (dns-reply message host port) r)
|
||||||
(udp-packet (dns-message->packet message) host port))
|
(udp-packet (dns-message->packet message) host port))
|
||||||
|
|
||||||
|
(define (first-only xs)
|
||||||
|
(if (null? xs)
|
||||||
|
xs
|
||||||
|
(cons (car xs) '())))
|
||||||
|
|
||||||
(define (handle-request soa-rr zone request)
|
(define (handle-request soa-rr zone request)
|
||||||
(match-define (dns-request request-message request-host request-port) request)
|
(match-define (dns-request request-message request-host request-port) request)
|
||||||
|
|
||||||
|
@ -111,13 +116,9 @@
|
||||||
;;
|
;;
|
||||||
;; TODO: We support returning out-of-bailiwick records (glue)
|
;; TODO: We support returning out-of-bailiwick records (glue)
|
||||||
;; here. Reexamine the rules for doing so.
|
;; here. Reexamine the rules for doing so.
|
||||||
(define (build-referral q ns-rrset)
|
(match (resolve-from-zone q soa-rr zone
|
||||||
(question-result q
|
(lambda (q ns-rrset)
|
||||||
zone
|
(build-referral q soa-rr zone ns-rrset)))
|
||||||
ns-rrset
|
|
||||||
(set soa-rr)
|
|
||||||
(additional-section/a zone (set-map ns-rrset rr-rdata))))
|
|
||||||
(match (resolve q soa-rr zone build-referral)
|
|
||||||
[#f
|
[#f
|
||||||
(make-reply (question-name q)
|
(make-reply (question-name q)
|
||||||
(in-bailiwick? (question-name q) (rr-name soa-rr))
|
(in-bailiwick? (question-name q) (rr-name soa-rr))
|
||||||
|
@ -135,7 +136,7 @@
|
||||||
;; TODO: think again about multiple questions in one packet
|
;; TODO: think again about multiple questions in one packet
|
||||||
(map (lambda (q)
|
(map (lambda (q)
|
||||||
(dns-reply (answer-question q make-reply) request-host request-port))
|
(dns-reply (answer-question q make-reply) request-host request-port))
|
||||||
(dns-message-questions request-message)))
|
(first-only (dns-message-questions request-message))))
|
||||||
|
|
||||||
(require "test-rrs.rkt")
|
(require "test-rrs.rkt")
|
||||||
(start-server 5555 test-soa-rr test-rrs)
|
(start-server 5555 test-soa-rr test-rrs)
|
||||||
|
|
35
zonedb.rkt
35
zonedb.rkt
|
@ -16,7 +16,8 @@
|
||||||
filter-rrs
|
filter-rrs
|
||||||
rr-set->list
|
rr-set->list
|
||||||
|
|
||||||
resolve)
|
resolve-from-zone
|
||||||
|
build-referral)
|
||||||
|
|
||||||
;; A CompiledZone is a Hash<DomainName,SetOf<RR>>, representing a
|
;; A CompiledZone is a Hash<DomainName,SetOf<RR>>, representing a
|
||||||
;; collection of DNS RRSets indexed by DomainName.
|
;; collection of DNS RRSets indexed by DomainName.
|
||||||
|
@ -57,11 +58,10 @@
|
||||||
(set-filter (lambda (rr) (eqv? (rr-type rr) type)) rrset))
|
(set-filter (lambda (rr) (eqv? (rr-type rr) type)) rrset))
|
||||||
|
|
||||||
;; TODO: Make limit maybe #f?? Representing no limit, for DNS roots??
|
;; TODO: Make limit maybe #f?? Representing no limit, for DNS roots??
|
||||||
(define (referral-for name soa-rr zone)
|
(define (referral-for name limit zone)
|
||||||
(define limit (rr-name soa-rr))
|
|
||||||
(let search ((name name))
|
(let search ((name name))
|
||||||
(cond
|
(cond
|
||||||
((or (null? name) (equal? name limit))
|
((equal? name limit)
|
||||||
;; We've walked up the tree to the top of the zone. No referrals
|
;; We've walked up the tree to the top of the zone. No referrals
|
||||||
;; are possible.
|
;; are possible.
|
||||||
#f)
|
#f)
|
||||||
|
@ -74,8 +74,12 @@
|
||||||
(search (cdr name)) ;; no NS records for this suffix. Keep looking.
|
(search (cdr name)) ;; no NS records for this suffix. Keep looking.
|
||||||
ns-rrset)))
|
ns-rrset)))
|
||||||
(else
|
(else
|
||||||
;; Nothing for this suffix. Keep lookup.
|
;; Nothing for this suffix.
|
||||||
(search (cdr name))))))
|
(if (null? name)
|
||||||
|
;; No further possibilities, and we've already checked the root.
|
||||||
|
#f
|
||||||
|
;; Remove a label and keep looking.
|
||||||
|
(search (cdr name)))))))
|
||||||
|
|
||||||
;; additional-section/a : CompiledZone ListOf<DomainName>
|
;; additional-section/a : CompiledZone ListOf<DomainName>
|
||||||
;; Implements the "additional section" rules from RFC 1035 (and the
|
;; Implements the "additional section" rules from RFC 1035 (and the
|
||||||
|
@ -129,7 +133,7 @@
|
||||||
(set-union u1 u2)
|
(set-union u1 u2)
|
||||||
(set-union d1 d2))]))
|
(set-union d1 d2))]))
|
||||||
|
|
||||||
(define (resolve q soa-rr knowledge recursive-resolver)
|
(define (resolve-from-zone q soa-rr knowledge recursive-resolver)
|
||||||
;; Extract the pieces of the question:
|
;; Extract the pieces of the question:
|
||||||
(match-define (question name qtype qclass) q)
|
(match-define (question name qtype qclass) q)
|
||||||
;; Examine knowledgebase:
|
;; Examine knowledgebase:
|
||||||
|
@ -142,7 +146,7 @@
|
||||||
(define base-reply (question-result q
|
(define base-reply (question-result q
|
||||||
knowledge
|
knowledge
|
||||||
(set-union cnames filtered-rrs)
|
(set-union cnames filtered-rrs)
|
||||||
(if (in-bailiwick? name (rr-name soa-rr))
|
(if (and soa-rr (in-bailiwick? name (rr-name soa-rr)))
|
||||||
(set soa-rr)
|
(set soa-rr)
|
||||||
(set))
|
(set))
|
||||||
(set)))
|
(set)))
|
||||||
|
@ -151,14 +155,15 @@
|
||||||
(not (eqv? qtype 'cname)))
|
(not (eqv? qtype 'cname)))
|
||||||
(foldl (lambda (cname-rr current-reply)
|
(foldl (lambda (cname-rr current-reply)
|
||||||
(merge-replies current-reply
|
(merge-replies current-reply
|
||||||
(resolve (question (rr-rdata cname-rr) qtype qclass)
|
(resolve-from-zone
|
||||||
|
(question (rr-rdata cname-rr) qtype qclass)
|
||||||
soa-rr
|
soa-rr
|
||||||
(question-result-knowledge current-reply)
|
(question-result-knowledge current-reply)
|
||||||
recursive-resolver)))
|
recursive-resolver)))
|
||||||
base-reply
|
base-reply
|
||||||
(set->list cnames))
|
(set->list cnames))
|
||||||
base-reply))]
|
base-reply))]
|
||||||
[(referral-for name soa-rr knowledge) =>
|
[(referral-for name (and soa-rr (rr-name soa-rr)) knowledge) =>
|
||||||
;; No full name match, but a referral to somewhere beneath our SOA
|
;; No full name match, but a referral to somewhere beneath our SOA
|
||||||
;; but within the knowledge we have.
|
;; but within the knowledge we have.
|
||||||
(lambda (ns-rrset)
|
(lambda (ns-rrset)
|
||||||
|
@ -169,3 +174,13 @@
|
||||||
;; the caller to decide whether this means NXDOMAIN or simply an
|
;; the caller to decide whether this means NXDOMAIN or simply an
|
||||||
;; empty reply.
|
;; empty reply.
|
||||||
#f]))
|
#f]))
|
||||||
|
|
||||||
|
;; build-referral : Question RR CompiledZone SetOf<RR> -> QuestionResult
|
||||||
|
;; Used when servers choose iterative referral over recursive
|
||||||
|
;; resolution. The RRs in ns-rrset must be NS RRs.
|
||||||
|
(define (build-referral q soa-rr zone ns-rrset)
|
||||||
|
(question-result q
|
||||||
|
zone
|
||||||
|
ns-rrset
|
||||||
|
(and soa-rr (set soa-rr))
|
||||||
|
(additional-section/a zone (set-map ns-rrset rr-rdata))))
|
||||||
|
|
Loading…
Reference in New Issue