diff --git a/proxy.rkt b/proxy.rkt index 8ebec94..d67ed9f 100644 --- a/proxy.rkt +++ b/proxy.rkt @@ -90,6 +90,42 @@ ;; ServerState (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. +(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 -> Void ;; Starts a proxy service that will answer questions received on the ;; given UDP port based on the NS RRs it is given. @@ -163,45 +199,71 @@ request-source request-target) 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) - (outbound-messages '()) - (w old-world) - (temporary-cache (world-roots old-world))) - (if (null? remaining-questions) - (values outbound-messages w) - (let ((q (car remaining-questions))) - (define-values (answer new-w new-cache) (answer-question q w temporary-cache)) - (loop (cdr remaining-questions) - (if answer - (cons answer outbound-messages) - outbound-messages) - new-w - new-cache))))) +;; resolve-iteratively : Question SetOf -> QuestionResult +;; Follows a chain of referrals until it finds an answer to its +;; question. +(define (resolve-iteratively q ns-rrset) + (let search ((seen (set)) + (remaining (set->list ns-rrset))) + (cond + [(null? remaining) #f] ;; no answer available + [(set-member? (car remaining) seen) (search seen (cdr remaining))] + [else + (define first-ns-rr (car remaining)) + (define ns-name (rr-name first-ns-rr)) + (define ns-addr + ....... + 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 + + (error 'resolve-iteratively "Gah!")) -;; TODO: OMG this is a total toy proxy implementation. Pays attention -;; 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) - - - (values ( (world-message (dns-message query-id - 'response - 'query - 'non-authoritative - 'not-truncated - recursion-desired - 'recursion-available - 'no-error - questions - (list) - (list) - (list)) - #f - request-source)) - old-world)) +;; TODO: Make sure we follow the guidelines and rules for implementing +;; 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 + 'query + 'non-authoritative + 'not-truncated + recursion-desired + 'recursion-available + 'no-error + (list q) + ns + us + ds) + #f + request-source))) + (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) (error 'handle-reply "Unimplemented")) diff --git a/simplified-driver.rkt b/simplified-driver.rkt index 48496a0..f030f28 100644 --- a/simplified-driver.rkt +++ b/simplified-driver.rkt @@ -79,6 +79,11 @@ (match-define (dns-reply message host port) r) (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) (match-define (dns-request request-message request-host request-port) request) @@ -111,13 +116,9 @@ ;; ;; TODO: We support returning out-of-bailiwick records (glue) ;; here. Reexamine the rules for doing so. - (define (build-referral q ns-rrset) - (question-result q - zone - ns-rrset - (set soa-rr) - (additional-section/a zone (set-map ns-rrset rr-rdata)))) - (match (resolve q soa-rr zone build-referral) + (match (resolve-from-zone q soa-rr zone + (lambda (q ns-rrset) + (build-referral q soa-rr zone ns-rrset))) [#f (make-reply (question-name q) (in-bailiwick? (question-name q) (rr-name soa-rr)) @@ -135,7 +136,7 @@ ;; TODO: think again about multiple questions in one packet (map (lambda (q) (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") (start-server 5555 test-soa-rr test-rrs) diff --git a/zonedb.rkt b/zonedb.rkt index d0a6629..bb35e15 100644 --- a/zonedb.rkt +++ b/zonedb.rkt @@ -16,7 +16,8 @@ filter-rrs rr-set->list - resolve) + resolve-from-zone + build-referral) ;; A CompiledZone is a Hash>, representing a ;; collection of DNS RRSets indexed by DomainName. @@ -57,11 +58,10 @@ (set-filter (lambda (rr) (eqv? (rr-type rr) type)) rrset)) ;; TODO: Make limit maybe #f?? Representing no limit, for DNS roots?? -(define (referral-for name soa-rr zone) - (define limit (rr-name soa-rr)) +(define (referral-for name limit zone) (let search ((name name)) (cond - ((or (null? name) (equal? name limit)) + ((equal? name limit) ;; We've walked up the tree to the top of the zone. No referrals ;; are possible. #f) @@ -74,8 +74,12 @@ (search (cdr name)) ;; no NS records for this suffix. Keep looking. ns-rrset))) (else - ;; Nothing for this suffix. Keep lookup. - (search (cdr name)))))) + ;; Nothing for this suffix. + (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 ;; Implements the "additional section" rules from RFC 1035 (and the @@ -129,7 +133,7 @@ (set-union u1 u2) (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: (match-define (question name qtype qclass) q) ;; Examine knowledgebase: @@ -142,7 +146,7 @@ (define base-reply (question-result q knowledge (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)) (set))) @@ -151,14 +155,15 @@ (not (eqv? qtype 'cname))) (foldl (lambda (cname-rr current-reply) (merge-replies current-reply - (resolve (question (rr-rdata cname-rr) qtype qclass) - soa-rr - (question-result-knowledge current-reply) - recursive-resolver))) + (resolve-from-zone + (question (rr-rdata cname-rr) qtype qclass) + soa-rr + (question-result-knowledge current-reply) + recursive-resolver))) base-reply (set->list cnames)) 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 ;; but within the knowledge we have. (lambda (ns-rrset) @@ -169,3 +174,13 @@ ;; the caller to decide whether this means NXDOMAIN or simply an ;; empty reply. #f])) + +;; build-referral : Question RR CompiledZone SetOf -> 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))))