2011-12-13 16:57:42 +00:00
|
|
|
#lang racket/base
|
|
|
|
|
2012-01-25 18:50:49 +00:00
|
|
|
;; DNS proxy using os-big-bang.rkt and os-udp.rkt.
|
2011-12-13 16:57:42 +00:00
|
|
|
|
|
|
|
(require racket/match)
|
|
|
|
(require racket/set)
|
|
|
|
(require racket/bool)
|
|
|
|
(require "../racket-bitsyntax/main.rkt")
|
|
|
|
(require "api.rkt")
|
|
|
|
(require "codec.rkt")
|
|
|
|
(require "zonedb.rkt")
|
2012-01-25 18:50:49 +00:00
|
|
|
(require "network-query.rkt")
|
|
|
|
(require "resolver.rkt")
|
2011-12-13 16:57:42 +00:00
|
|
|
(require "dump-bytes.rkt")
|
2012-01-25 18:50:49 +00:00
|
|
|
(require "os.rkt")
|
|
|
|
(require "os-big-bang.rkt")
|
|
|
|
(require "os-udp.rkt")
|
|
|
|
(require "os-dns.rkt")
|
2012-01-25 20:06:49 +00:00
|
|
|
(require "os-timer.rkt")
|
2011-12-28 18:53:19 +00:00
|
|
|
|
2011-12-13 16:57:42 +00:00
|
|
|
;; Instantiated with a collection of trusted roots to begin its
|
|
|
|
;; searches from. Performs recursive queries. Doesn't yet cache
|
|
|
|
;; responses, but will do so in future.
|
|
|
|
|
2012-01-25 20:07:33 +00:00
|
|
|
;; For discarding retransmitted requests that we're still working on.
|
|
|
|
(struct active-request (source id) #:transparent)
|
|
|
|
|
2011-12-13 16:57:42 +00:00
|
|
|
;; start-proxy : UInt16 ListOf<RR> -> Void
|
2012-01-25 18:50:49 +00:00
|
|
|
(require racket/pretty)
|
|
|
|
(define (start-proxy port-number rrs)
|
|
|
|
;; Compile the zone hash table
|
|
|
|
(define zone (compile-zone-db rrs))
|
|
|
|
(pretty-print zone)
|
|
|
|
|
|
|
|
(define boot-server
|
2012-01-25 20:07:33 +00:00
|
|
|
(os-big-bang (set) ;; SetOf<ActiveRequest>
|
2012-01-25 19:20:20 +00:00
|
|
|
;;(spawn dns-spy)
|
2012-01-25 20:06:49 +00:00
|
|
|
(spawn (timer-relay))
|
2012-01-25 18:50:49 +00:00
|
|
|
(send-meta-message `(request create-server-socket (udp new ,port-number 512)))
|
|
|
|
(subscribe 'wait-for-server-socket
|
|
|
|
(meta-message-handlers w
|
|
|
|
[`(reply create-server-socket ,s)
|
|
|
|
(transition w
|
|
|
|
(unsubscribe 'wait-for-server-socket)
|
|
|
|
(send-meta-message
|
|
|
|
`(request create-client-socket (udp new 0 512)))
|
|
|
|
(client-socket-waiter s))]))))
|
|
|
|
|
|
|
|
(define (client-socket-waiter s)
|
|
|
|
(subscribe 'wait-for-client-socket
|
|
|
|
(meta-message-handlers w
|
|
|
|
[`(reply create-client-socket ,c)
|
|
|
|
(transition w
|
|
|
|
(unsubscribe 'wait-for-client-socket)
|
2012-01-25 20:07:33 +00:00
|
|
|
(spawn (dns-read-driver s))
|
|
|
|
(spawn (dns-write-driver s))
|
2012-01-25 18:50:49 +00:00
|
|
|
(spawn (dns-read-driver c))
|
|
|
|
(spawn (dns-write-driver c))
|
|
|
|
(subscribe 'packet-handler (packet-handler s c)))])))
|
|
|
|
|
|
|
|
(define (packet-handler s c)
|
2012-01-25 20:07:33 +00:00
|
|
|
(message-handlers old-active-requests
|
2012-01-25 18:50:49 +00:00
|
|
|
[(? bad-dns-packet? p)
|
|
|
|
(pretty-print p) ;; TODO: perhaps use metalevel events? perhaps don't bother though
|
2012-01-25 20:07:33 +00:00
|
|
|
old-active-requests]
|
|
|
|
[(and r (dns-request m source (== s))) ;; We only listen for requests on our server socket
|
|
|
|
(define req-id (active-request source (dns-message-id m)))
|
|
|
|
;; TODO: when we have presence/error-handling, remove req-id
|
|
|
|
;; from active requests once request-handler pseudothread exits.
|
|
|
|
(if (set-member? old-active-requests req-id)
|
|
|
|
old-active-requests ;; ignore retransmitted duplicates
|
|
|
|
(transition (set-add old-active-requests req-id)
|
|
|
|
(spawn (request-handler zone r c))))]
|
|
|
|
[(and r (dns-reply m (== s) sink))
|
|
|
|
(define req-id (active-request sink (dns-message-id m)))
|
|
|
|
(set-remove old-active-requests req-id)]))
|
2012-01-25 18:50:49 +00:00
|
|
|
|
|
|
|
(ground-vm (os-big-bang (void)
|
2012-01-25 19:20:20 +00:00
|
|
|
;;(spawn udp-spy)
|
2012-01-25 18:50:49 +00:00
|
|
|
(spawn udp-driver)
|
2012-01-25 20:06:49 +00:00
|
|
|
(spawn (timer-driver))
|
2012-01-25 18:50:49 +00:00
|
|
|
(spawn (nested-vm boot-server)))))
|
|
|
|
|
|
|
|
(define (request-handler zone request client-sock)
|
|
|
|
;; 1. try resolving locally
|
|
|
|
;; 2. if it answers, send that out. otherwise, it needs to request something recursively.
|
|
|
|
;; 3. if the socket doesn't exist, request it, and wait for the reply.
|
|
|
|
;; 4. start processing the network query: it will result in a send/receive/timeout combo
|
|
|
|
;; 5. on timeout, try a different server, or if there aren't any
|
|
|
|
;; more, report failure to the resolver
|
|
|
|
;; 6. on packet, report success to the resolver and goto 2.
|
|
|
|
;; -. remember to release the socket when we're done!
|
|
|
|
|
|
|
|
(match-define (dns-request request-message request-source request-sink) request)
|
|
|
|
(define question (and (pair? (dns-message-questions request-message))
|
|
|
|
(car (dns-message-questions request-message))))
|
|
|
|
|
2012-01-25 20:06:49 +00:00
|
|
|
(write `(Looking up ,question with query id ,(dns-message-id request-message))) (newline)
|
2012-01-25 19:20:20 +00:00
|
|
|
|
2012-01-25 18:50:49 +00:00
|
|
|
(define (make-reply answers authorities additional)
|
|
|
|
(dns-message (dns-message-id request-message)
|
|
|
|
'response
|
|
|
|
'query
|
|
|
|
'non-authoritative
|
|
|
|
'not-truncated
|
|
|
|
(dns-message-recursion-desired request-message)
|
|
|
|
'recursion-available
|
|
|
|
'no-error
|
|
|
|
(list question)
|
|
|
|
(rr-set->list answers)
|
|
|
|
(rr-set->list authorities)
|
|
|
|
(rr-set->list additional)))
|
|
|
|
|
|
|
|
(define (resolver-actions qr)
|
|
|
|
(match qr
|
2012-01-31 13:11:31 +00:00
|
|
|
[(resolver-network-query q zone-origin addresses k) ;; need subquestion answered
|
2012-01-25 19:20:20 +00:00
|
|
|
;;(write `(INTERMEDIATE ,q ,ns-rr (,(length addresses) addresses))) (newline)
|
2012-01-31 13:11:31 +00:00
|
|
|
(network-query/addresses client-sock q zone-origin addresses
|
|
|
|
(lambda (rrs) (resolver-actions (k rrs))))]
|
2012-01-25 18:50:49 +00:00
|
|
|
[#f ;; got a name-error/NXDOMAIN from some nameserver
|
|
|
|
;; TODO: re-examine my reasoning for not sending name-error/NXDOMAIN here
|
|
|
|
(send-message (dns-reply (make-reply (set) (set) (set)) request-sink request-source))]
|
|
|
|
[(question-result _ _ anss auths adds)
|
|
|
|
(send-message (dns-reply (make-reply anss auths adds) request-sink request-source))]))
|
|
|
|
|
|
|
|
(if (eq? question #f)
|
|
|
|
(os-big-bang 'no-questions-no-processing-no-answers)
|
|
|
|
(os-big-bang '???
|
|
|
|
(resolver-actions
|
|
|
|
(resolve-from-zone question
|
|
|
|
zone
|
|
|
|
#f ;; no SOA, since we're not authoritative for anything
|
|
|
|
#t ;; we *are* however recursive.
|
|
|
|
(set) ;; haven't tried any nameservers yet
|
|
|
|
values)))))
|
|
|
|
|
|
|
|
(require "test-rrs.rkt")
|
|
|
|
(start-proxy 5555 test-roots)
|