Convert network-query to evented style and implement proxy.
Create os-dns.rkt from code in big-bang-driver.rkt.
This commit is contained in:
Tony Garnock-Jones
parent
a447ddfd7d
commit
26aa40053b
|
|
@ -9,12 +9,12 @@
|
|||
(require "api.rkt")
|
||||
(require "codec.rkt")
|
||||
(require "zonedb.rkt")
|
||||
(require "network-query.rkt")
|
||||
(require "resolver.rkt")
|
||||
(require "dump-bytes.rkt")
|
||||
(require "os.rkt")
|
||||
(require "os-big-bang.rkt")
|
||||
(require "os-udp.rkt")
|
||||
(require "os-dns.rkt")
|
||||
|
||||
;; Instantiated with a SOA record for the zone it is serving as well
|
||||
;; as a zone's worth of DNS data which is used to answer queries
|
||||
|
|
@ -29,14 +29,6 @@
|
|||
;; determines subzones based on the RRs it is configured with at
|
||||
;; startup.
|
||||
|
||||
(struct bad-dns-packet (detail source sink reason) #:prefab)
|
||||
(struct dns-request (message source) #:prefab)
|
||||
(struct dns-reply (message sink) #:prefab)
|
||||
|
||||
;; (define (spy label)
|
||||
;; (os-big-bang 'none
|
||||
;; (subscribe 'spy (message-handlers w [x (write `(,label ,x)) (newline)]))))
|
||||
|
||||
;; start-server : UInt16 RR ListOf<RR> -> Void
|
||||
;; Starts a server that will answer questions received on the given
|
||||
;; UDP port based on the RRs it is given and the zone origin specified
|
||||
|
|
@ -57,7 +49,6 @@
|
|||
(unsubscribe 'wait-for-server-socket)
|
||||
(spawn (dns-read-driver s))
|
||||
(spawn (dns-write-driver s))
|
||||
;;(spawn (spy 'DNS-MESSAGE))
|
||||
(subscribe 'packet-handler (packet-handler s)))]))))
|
||||
|
||||
(define (packet-handler s)
|
||||
|
|
@ -72,45 +63,15 @@
|
|||
|
||||
(ground-vm (os-big-bang (void)
|
||||
(spawn udp-driver)
|
||||
;;(spawn (spy 'UDP-MESSAGE))
|
||||
(spawn (nested-vm boot-server)))))
|
||||
|
||||
(define (dns-read-driver s)
|
||||
(os-big-bang 'no-state
|
||||
(subscribe 'packet-reader
|
||||
(meta-message-handlers w
|
||||
[(udp-packet source (== s) body)
|
||||
(transition w
|
||||
(send-message
|
||||
(with-handlers ((exn:fail? (lambda (e)
|
||||
(bad-dns-packet body source s
|
||||
'unparseable))))
|
||||
(define message (packet->dns-message body))
|
||||
(case (dns-message-direction message)
|
||||
((request) (dns-request message source))
|
||||
((response) (bad-dns-packet message source s
|
||||
'unexpected-dns-response))))))]))))
|
||||
|
||||
(define (dns-write-driver s)
|
||||
(os-big-bang 'no-state
|
||||
(subscribe 'packet-writer
|
||||
(message-handlers w
|
||||
[(dns-reply message sink)
|
||||
(transition w
|
||||
(with-handlers ((exn:fail? (lambda (e)
|
||||
(send-message
|
||||
(bad-dns-packet message s sink
|
||||
'unencodable)))))
|
||||
(send-meta-message
|
||||
(udp-packet s sink (dns-message->packet message)))))]))))
|
||||
|
||||
(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-source) request)
|
||||
(match-define (dns-request request-message request-source request-sink) request)
|
||||
|
||||
(define (make-reply name send-name-error? answers authorities additional)
|
||||
(dns-message (dns-message-id request-message)
|
||||
|
|
@ -158,7 +119,7 @@
|
|||
;; TODO: check opcode and direction in request
|
||||
;; TODO: think again about multiple questions in one packet
|
||||
(map (lambda (q)
|
||||
(dns-reply (answer-question q make-reply) request-source))
|
||||
(dns-reply (answer-question q make-reply) request-sink request-source))
|
||||
(first-only (dns-message-questions request-message))))
|
||||
|
||||
(require "test-rrs.rkt")
|
||||
|
|
|
|||
|
|
@ -5,6 +5,9 @@
|
|||
(require "api.rkt")
|
||||
(require "codec.rkt")
|
||||
(require "zonedb.rkt")
|
||||
(require "os-big-bang.rkt")
|
||||
(require "os-udp.rkt")
|
||||
(require "os-dns.rkt")
|
||||
|
||||
(provide network-query/addresses)
|
||||
|
||||
|
|
@ -70,24 +73,23 @@
|
|||
(match-define (vector a b c d) ip-address)
|
||||
(format "~a.~a.~a.~a" a b c d))
|
||||
|
||||
(define (make-network-query-packet q)
|
||||
(dns-message->packet
|
||||
(dns-message (random 65536)
|
||||
'request
|
||||
'query
|
||||
'non-authoritative
|
||||
'not-truncated
|
||||
'no-recursion-desired
|
||||
'no-recursion-available
|
||||
'no-error
|
||||
(list q)
|
||||
'()
|
||||
'()
|
||||
'())))
|
||||
(define (make-dns-query-message q)
|
||||
(dns-message (random 65536)
|
||||
'request
|
||||
'query
|
||||
'non-authoritative
|
||||
'not-truncated
|
||||
'no-recursion-desired
|
||||
'no-recursion-available
|
||||
'no-error
|
||||
(list q)
|
||||
'()
|
||||
'()
|
||||
'()))
|
||||
|
||||
;; incorporate-dns-reply :
|
||||
;; DNSMessage CompiledZone RR<NS> ( -> Maybe<CompiledZone> )
|
||||
;; -> Maybe<CompiledZone>
|
||||
;; DNSMessage CompiledZone RR<NS>
|
||||
;; -> (or Maybe<CompiledZone> 'no-answer)
|
||||
;;
|
||||
;; Incorporates RRs from the answer, authorities, and additional
|
||||
;; sections of the passed-in `message` to the passed-in `zone`,
|
||||
|
|
@ -95,10 +97,8 @@
|
|||
;; `rr-name` falls in the bailiwick of the given `ns-rr`. All of this
|
||||
;; only happens if the passed-in message's `dns-message-response-code`
|
||||
;; is `'no-error`: if it's `'name-error`, then `#f` is returned, and
|
||||
;; if it's any other code,the `keep-trying` thunk is invoked. (If the
|
||||
;; caller is `network-query/addresses`, then `keep-trying` will try
|
||||
;; other servers from the list of IPs available.)
|
||||
(define (incorporate-dns-reply message zone ns-rr keep-trying)
|
||||
;; if it's any other code, `'no-answer` is returned.
|
||||
(define (incorporate-dns-reply message zone ns-rr)
|
||||
(case (dns-message-response-code message)
|
||||
[(no-error)
|
||||
(foldl (lambda (claim-rr zone)
|
||||
|
|
@ -110,53 +110,51 @@
|
|||
(dns-message-authorities message)
|
||||
(dns-message-additional message)))]
|
||||
[(name-error) #f]
|
||||
[else (keep-trying)]))
|
||||
[else 'no-answer]))
|
||||
|
||||
;; network-query/addresses :
|
||||
;; Question CompiledZone RR<NS> ListOf<IPv4> -> Maybe<CompiledZone>
|
||||
;; UdpAddress Question CompiledZone RR<NS> ListOf<IPv4>
|
||||
;; (Maybe<CompiledZone> -> ListOf<Action>) -> ListOf<Action>
|
||||
;;
|
||||
;; Repeatedly uses `network-query/addresses/timeout` to try asking the
|
||||
;; whole of `server-ips` the question `q`, starting with a timeout of
|
||||
;; `first-timeout` seconds and increasing each time
|
||||
;; `network-query/addresses/timeout` returns `'no-answer` up to a
|
||||
;; give-up timeout limit.
|
||||
(define (network-query/addresses q zone ns-rr server-ips)
|
||||
(let ((s (udp-open-socket #f #f)))
|
||||
(let try-with-timeout ((timeout first-timeout))
|
||||
(match (network-query/addresses/timeout s q zone ns-rr server-ips timeout)
|
||||
['no-answer
|
||||
(define new-timeout (next-timeout timeout))
|
||||
(if new-timeout
|
||||
(try-with-timeout new-timeout)
|
||||
zone)]
|
||||
[result result]))))
|
||||
(define (network-query/addresses s q zone ns-rr server-ips k)
|
||||
(let try-with-timeout ((timeout first-timeout))
|
||||
(network-query/addresses/timeout s q zone ns-rr server-ips timeout
|
||||
(lambda (result)
|
||||
(if (eq? result 'no-answer)
|
||||
(let ((new-timeout (next-timeout timeout)))
|
||||
(if new-timeout
|
||||
(try-with-timeout new-timeout)
|
||||
(k zone)))
|
||||
(k result))))))
|
||||
|
||||
;; network-query/addresses/timeout :
|
||||
;; UdpSocket Question CompiledZone RR<NS> ListOf<IPv4> Seconds
|
||||
;; -> (or Maybe<CompiledZone> 'no-answer)
|
||||
;; UdpAddress Question CompiledZone RR<NS> ListOf<IPv4> Seconds
|
||||
;; ((or Maybe<CompiledZone> 'no-answer) -> ListOf<Action>) -> ListOf<Action>
|
||||
;;
|
||||
;; Sends the question to each of the servers whose addresses are given
|
||||
;; in `server-ips` using `network-query/address/timeout`, one at a
|
||||
;; time, in order, trying the next in the list only if `'no-answer`
|
||||
;; results from the most recent communication attempt. If and when the
|
||||
;; list is exhausted, `'no-answer` is returned.
|
||||
(define (network-query/addresses/timeout s q zone ns-rr server-ips timeout)
|
||||
(define (network-query/addresses/timeout s q zone ns-rr server-ips timeout k)
|
||||
;; TODO: randomize ordering of servers in list.
|
||||
(let search ((remaining-ips server-ips))
|
||||
(if (null? remaining-ips)
|
||||
'no-answer
|
||||
(match (network-query/address/timeout s q zone ns-rr (car remaining-ips) timeout)
|
||||
['no-answer (search (cdr remaining-ips))]
|
||||
[result result]))))
|
||||
|
||||
(define (udp-receive/timeout s buffer timeout-seconds)
|
||||
(sync/timeout timeout-seconds (udp-receive!-evt s buffer)))
|
||||
|
||||
(require racket/pretty) ;; TODO: remove
|
||||
(k 'no-answer)
|
||||
(network-query/address/timeout s q zone ns-rr (car remaining-ips) timeout
|
||||
(lambda (result)
|
||||
(if (eq? result 'no-answer)
|
||||
(search (cdr remaining-ips))
|
||||
(k result)))))))
|
||||
|
||||
;; network-query/address/timeout :
|
||||
;; UdpSocket Question CompiledZone RR<NS> IPv4 Seconds
|
||||
;; -> (or Maybe<CompiledZone> 'no-answer)
|
||||
;; UdpAddress Question CompiledZone RR<NS> IPv4 Seconds
|
||||
;; ((or Maybe<CompiledZone> 'no-answer) -> ListOf<Action>) -> ListOf<Action>
|
||||
;;
|
||||
;; Sends the question to the server address `server-ip` given. Waits
|
||||
;; `timeout` seconds for an answer: if one arrives, it is incorporated
|
||||
|
|
@ -164,23 +162,22 @@
|
|||
;; result is returned to the caller. If the timeout expires before a
|
||||
;; reply is received, or some error result is received from the
|
||||
;; server, `'no-answer` is returned to the caller.
|
||||
(define (network-query/address/timeout s q zone ns-rr server-ip timeout)
|
||||
(define (network-query/address/timeout s q zone ns-rr server-ip timeout k)
|
||||
(define server-host-name (ip->host-name server-ip))
|
||||
(define server-port 53)
|
||||
(write `(querying ,server-host-name ,server-port with timeout ,timeout)) (newline)
|
||||
(udp-send-to s server-host-name server-port (make-network-query-packet q))
|
||||
(define buffer (make-bytes 512)) ;; maximum DNS reply length
|
||||
(define result (udp-receive/timeout s buffer timeout))
|
||||
;; TODO: correlate query-ID
|
||||
;; TODO: maybe receive only specifically from the queried IP address?
|
||||
(if result
|
||||
(let* ((reply-length (car result))
|
||||
(packet (subbytes buffer 0 reply-length))
|
||||
(reply-message (packet->dns-message packet)))
|
||||
(pretty-print `(response ,result ,reply-message))
|
||||
(incorporate-dns-reply reply-message
|
||||
zone
|
||||
ns-rr
|
||||
(lambda () 'no-answer)))
|
||||
'no-answer))
|
||||
|
||||
(define query (make-dns-query-message q))
|
||||
(define req (dns-request query
|
||||
s
|
||||
(udp-address server-host-name server-port)))
|
||||
(define subscription-id (list s (dns-message-id query)))
|
||||
(list (send-message req)
|
||||
;; TODO: timeout!
|
||||
(subscribe subscription-id
|
||||
(message-handlers w
|
||||
[(dns-reply reply-message source (== s))
|
||||
;; TODO: maybe receive only specifically from the queried IP address?
|
||||
(if (not (= (dns-message-id reply-message) (dns-message-id query)))
|
||||
w
|
||||
(transition w
|
||||
(unsubscribe subscription-id)
|
||||
(k (incorporate-dns-reply reply-message zone ns-rr))))]))))
|
||||
|
|
|
|||
|
|
@ -0,0 +1,59 @@
|
|||
#lang racket/base
|
||||
|
||||
;; DNS drivers using os-big-bang.rkt and os-udp.rkt.
|
||||
|
||||
(require racket/match)
|
||||
(require "codec.rkt")
|
||||
(require "os-big-bang.rkt")
|
||||
(require "os-udp.rkt")
|
||||
|
||||
(provide (struct-out bad-dns-packet)
|
||||
(struct-out dns-request)
|
||||
(struct-out dns-reply)
|
||||
dns-read-driver
|
||||
dns-write-driver
|
||||
dns-spy)
|
||||
|
||||
(struct bad-dns-packet (detail source sink reason) #:prefab)
|
||||
(struct dns-request (message source sink) #:prefab)
|
||||
(struct dns-reply (message source sink) #:prefab)
|
||||
|
||||
(define (dns-read-driver s)
|
||||
(os-big-bang 'no-state
|
||||
(subscribe 'packet-reader
|
||||
(meta-message-handlers w
|
||||
[(udp-packet source (== s) body)
|
||||
(transition w
|
||||
(send-message
|
||||
(with-handlers ((exn:fail? (lambda (e)
|
||||
(bad-dns-packet body source s
|
||||
'unparseable))))
|
||||
(define message (packet->dns-message body))
|
||||
(case (dns-message-direction message)
|
||||
((request) (dns-request message source s))
|
||||
((response) (dns-reply message source s))))))]))))
|
||||
|
||||
(define (dns-write-driver s)
|
||||
(define (translate message sink)
|
||||
(with-handlers ((exn:fail? (lambda (e)
|
||||
(send-message (bad-dns-packet message s sink 'unencodable)))))
|
||||
(send-meta-message (udp-packet s sink (dns-message->packet message)))))
|
||||
(os-big-bang 'no-state
|
||||
(subscribe 'packet-writer
|
||||
(message-handlers w
|
||||
[(dns-request message (== s) sink)
|
||||
(transition w (translate message sink))]
|
||||
[(dns-reply message (== s) sink)
|
||||
(transition w (translate message sink))]))))
|
||||
|
||||
(require racket/pretty)
|
||||
(define dns-spy
|
||||
(os-big-bang 'none
|
||||
(subscribe 'spy
|
||||
(message-handlers w
|
||||
[(dns-request message source sink)
|
||||
(pretty-display `(DNS (,source asks ,sink)
|
||||
,@(dns-message-questions message)))]
|
||||
[(dns-reply message source sink)
|
||||
(pretty-display `(DNS (,source answers ,sink) ,message))]
|
||||
[x (write `(DNS ,x)) (newline)]))))
|
||||
28
os-udp.rkt
28
os-udp.rkt
|
|
@ -9,7 +9,8 @@
|
|||
|
||||
(provide (struct-out udp-address)
|
||||
(struct-out udp-packet)
|
||||
udp-driver)
|
||||
udp-driver
|
||||
udp-spy)
|
||||
|
||||
;; A UdpAddress is one of
|
||||
;; -- a (udp-address String Uint16), representing a remote socket
|
||||
|
|
@ -32,7 +33,9 @@
|
|||
(define s (udp-open-socket #f #f))
|
||||
(when port-number
|
||||
(udp-bind! s #f port-number))
|
||||
(define sname (udp-address #f port-number))
|
||||
(define-values (_local-address local-port _remote-address _remote-port)
|
||||
(udp-addresses s #t))
|
||||
(define sname (udp-address #f local-port))
|
||||
(spawn (userland (udp-sender sname s)))
|
||||
(spawn (userland (udp-receiver sname s buffer-size)))
|
||||
(spawn (userland (udp-closer sname s)))
|
||||
|
|
@ -44,11 +47,7 @@
|
|||
[`(close ,(== sname))
|
||||
(void)]
|
||||
[(udp-packet (== sname) (udp-address host port) body)
|
||||
(meta-send (lambda ()
|
||||
(printf "<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~n~v~n" body)
|
||||
(dump-bytes! body (bytes-length body))
|
||||
(flush-output)
|
||||
(udp-send-to s host port body)))
|
||||
(meta-send (lambda () (udp-send-to s host port body)))
|
||||
(loop)]))))
|
||||
|
||||
(define ((udp-receiver sname s buffer-size))
|
||||
|
|
@ -62,9 +61,6 @@
|
|||
(udp-receive!-evt s buffer)
|
||||
=> (list packet-length host port))
|
||||
(define packet (subbytes buffer 0 packet-length))
|
||||
(printf ">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>~n~v~n" packet)
|
||||
(dump-bytes! buffer packet-length)
|
||||
(flush-output)
|
||||
(send (udp-packet (udp-address host port) sname packet))
|
||||
(loop)]))))
|
||||
|
||||
|
|
@ -72,3 +68,15 @@
|
|||
(wait (message-handlers
|
||||
[`(close ,(== sname))
|
||||
(udp-close s)])))
|
||||
|
||||
(define udp-spy
|
||||
(userland
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(wait (message-handlers
|
||||
[(udp-packet source dest body)
|
||||
(write `(UDP ,source --> ,dest)) (newline)
|
||||
(dump-bytes! body (bytes-length body))]
|
||||
[x
|
||||
(write `(UDP ,x)) (newline)]))
|
||||
(loop)))))
|
||||
|
|
|
|||
285
proxy.rkt
285
proxy.rkt
|
|
@ -1,218 +1,121 @@
|
|||
#lang racket/base
|
||||
|
||||
;; Simple imperative DNS proxy.
|
||||
;; DNS proxy using os-big-bang.rkt and os-udp.rkt.
|
||||
|
||||
(require racket/unit)
|
||||
(require racket/match)
|
||||
(require racket/udp)
|
||||
(require racket/set)
|
||||
(require racket/bool)
|
||||
(require "../racket-bitsyntax/main.rkt")
|
||||
(require "api.rkt")
|
||||
(require "codec.rkt")
|
||||
(require "zonedb.rkt")
|
||||
(require "resolver-unit.rkt")
|
||||
(require "network-query.rkt")
|
||||
(require "resolver.rkt")
|
||||
(require "dump-bytes.rkt")
|
||||
(require "simple-udp-service.rkt")
|
||||
|
||||
(require racket/pretty)
|
||||
|
||||
(define-values/invoke-unit/infer (link resolver@ simple-udp-service-udp-operations@))
|
||||
(require "os.rkt")
|
||||
(require "os-big-bang.rkt")
|
||||
(require "os-udp.rkt")
|
||||
(require "os-dns.rkt")
|
||||
|
||||
;; 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.
|
||||
|
||||
;; An Address can be an (address String Uint16) or #f, where an
|
||||
;; address struct represents nonlocal UDP sockets, and #f represents
|
||||
;; the local socket. This way, we don't need to know the IP or port of
|
||||
;; the local socket, and we can be "multihomed".
|
||||
(struct address (host port) #:prefab) ;; a UDP IP/port-number combination
|
||||
|
||||
(struct bad-dns-packet (detail source target reason) #:prefab)
|
||||
(struct world-message (body source target) #:prefab)
|
||||
|
||||
;; 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<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
|
||||
;; Starts a proxy service that will answer questions received on the
|
||||
;; given UDP port based on the NS RRs it is given.
|
||||
(define (start-proxy port-number raw-roots)
|
||||
;; Compile the table of roots
|
||||
(define roots (compile-zone-db raw-roots))
|
||||
(pretty-print roots)
|
||||
(require racket/pretty)
|
||||
(define (start-proxy port-number rrs)
|
||||
;; Compile the zone hash table
|
||||
(define zone (compile-zone-db rrs))
|
||||
(pretty-print zone)
|
||||
|
||||
(define initial-world (world roots (make-immutable-hash)))
|
||||
(define boot-server
|
||||
(os-big-bang 'no-state
|
||||
(spawn dns-spy)
|
||||
(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)
|
||||
(spawn (dns-read-driver s))
|
||||
(spawn (dns-write-driver s))
|
||||
(send-meta-message
|
||||
`(request create-client-socket (udp new 0 512)))
|
||||
(client-socket-waiter s))]))))
|
||||
|
||||
(start-udp-service
|
||||
port-number
|
||||
udp-packet->message
|
||||
outbound-message?
|
||||
message->udp-packet
|
||||
(message-handlers old-world
|
||||
[(? bad-dns-packet? p)
|
||||
(pretty-print p)
|
||||
(values '() old-world)]
|
||||
[(? request-from-downstream? r)
|
||||
(handle-request r old-world)]
|
||||
[(? reply-from-upstream? r)
|
||||
(handle-reply r old-world)])
|
||||
(lambda (unhandled state)
|
||||
(error 'dns-server "Unhandled packet ~v" unhandled))
|
||||
initial-world
|
||||
#:packet-size-limit 512))
|
||||
(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)
|
||||
(spawn (dns-read-driver c))
|
||||
(spawn (dns-write-driver c))
|
||||
(subscribe 'packet-handler (packet-handler s c)))])))
|
||||
|
||||
(define (udp-packet->message packet)
|
||||
(match-define (udp-packet body host port) packet)
|
||||
(define a (address host port))
|
||||
(with-handlers ((exn:fail? (lambda (e) (bad-dns-packet body a #f 'unparseable))))
|
||||
(define message (packet->dns-message body))
|
||||
(world-message message a #f)))
|
||||
(define (packet-handler s c)
|
||||
(message-handlers old-state
|
||||
[(? bad-dns-packet? p)
|
||||
(pretty-print p) ;; TODO: perhaps use metalevel events? perhaps don't bother though
|
||||
old-state]
|
||||
[(and r (dns-request _ _ (== s))) ;; We only listen for requests on our server socket
|
||||
(transition old-state (spawn (request-handler zone r c)))]))
|
||||
|
||||
(define (message->udp-packet m)
|
||||
(match-define (world-message body _ (address host port)) m)
|
||||
(udp-packet (dns-message->packet body) host port))
|
||||
(ground-vm (os-big-bang (void)
|
||||
(spawn udp-spy)
|
||||
(spawn udp-driver)
|
||||
(spawn (nested-vm boot-server)))))
|
||||
|
||||
(define (local-address? a)
|
||||
(eq? a #f))
|
||||
(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!
|
||||
|
||||
(define (remote-address? a)
|
||||
(address? a))
|
||||
(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))))
|
||||
|
||||
(define (outbound-message? m)
|
||||
(and (world-message? m)
|
||||
(local-address? (world-message-source m))
|
||||
(remote-address? (world-message-target m))))
|
||||
(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 (inbound-message? m)
|
||||
(and (world-message? m)
|
||||
(remote-address? (world-message-source m))
|
||||
(local-address? (world-message-target m))))
|
||||
(define (resolver-actions qr)
|
||||
(match qr
|
||||
[(resolver-network-query q zone ns-rr addresses k) ;; need subquestion answered
|
||||
(write `(INTERMEDIATE ,q ,ns-rr (,(length addresses) addresses))) (newline)
|
||||
(network-query/addresses client-sock q zone ns-rr addresses
|
||||
(lambda (qr) (resolver-actions (k qr))))]
|
||||
[#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))]))
|
||||
|
||||
(define (request-from-downstream? m)
|
||||
(and (inbound-message? m)
|
||||
(eq? (dns-message-direction (world-message-body m)) 'request)
|
||||
(eq? (dns-message-opcode (world-message-body m)) 'query)))
|
||||
(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)))))
|
||||
|
||||
(define (reply-from-upstream? m)
|
||||
(and (inbound-message? m)
|
||||
(eq? (dns-message-direction (world-message-body m)) 'response)
|
||||
(eq? (dns-message-opcode (world-message-body m)) 'query)))
|
||||
|
||||
(define (handle-request r old-world)
|
||||
(match-define (world-message (struct* dns-message
|
||||
([id query-id]
|
||||
[recursion-desired recursion-desired]
|
||||
[questions questions]))
|
||||
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)))
|
||||
|
||||
;; resolve-iteratively : Question SetOf<RR> -> 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: 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 values)
|
||||
[#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"))
|
||||
|
||||
(start-proxy 5555
|
||||
(list (rr '() 'ns 'in 30 '(#"google-public-dns-a" #"google" #"com"))
|
||||
(rr '(#"google-public-dns-a" #"google" #"com") 'a 'in 30 '#(8 8 8 8))))
|
||||
(require "test-rrs.rkt")
|
||||
(start-proxy 5555 test-roots)
|
||||
|
|
|
|||
|
|
@ -11,6 +11,7 @@
|
|||
(require "zonedb.rkt")
|
||||
(require "network-query.rkt")
|
||||
(require "resolver.rkt")
|
||||
(require "test-rrs.rkt")
|
||||
|
||||
;; (require racket/trace)
|
||||
;; (trace ;;resolve-from-zone
|
||||
|
|
@ -31,7 +32,8 @@
|
|||
(match qr
|
||||
[(resolver-network-query q zone ns-rr addresses k)
|
||||
(write `(INTERMEDIATE ,q ,ns-rr (,(length addresses) addresses))) (newline)
|
||||
(drive-resolver (k (network-query/addresses q zone ns-rr addresses)))]
|
||||
(network-query/addresses 'foo q zone ns-rr addresses
|
||||
(lambda (qr) (drive-resolver (k qr))))]
|
||||
[_ qr]))
|
||||
|
||||
(define (run-question name qtype)
|
||||
|
|
@ -40,15 +42,7 @@
|
|||
(compile-zone-db
|
||||
;; (list (rr '() 'ns 'in 30 '(#"google-public-dns-a" #"google" #"com"))
|
||||
;; (rr '(#"google-public-dns-a" #"google" #"com") 'a 'in 30 '#(8 8 8 8)))
|
||||
(list (rr '() 'ns 'in 30 '(#"f" #"root-servers" #"net"))
|
||||
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(198 41 0 4))
|
||||
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 228 79 201))
|
||||
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 33 4 12))
|
||||
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 203 230 10))
|
||||
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 112 36 4))
|
||||
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(128 63 2 53))
|
||||
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 58 128 30))
|
||||
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(193 0 14 129)))
|
||||
test-roots
|
||||
)
|
||||
#f
|
||||
#t
|
||||
|
|
|
|||
16
resolver.rkt
16
resolver.rkt
|
|
@ -11,6 +11,17 @@
|
|||
(provide (struct-out resolver-network-query)
|
||||
resolve-from-zone)
|
||||
|
||||
;; A ResolverResult is one of
|
||||
;; -- a QuestionResult, a complete answer to the issued question, or
|
||||
;; -- a ResolverNetworkQuery, a subquestion that must be answered
|
||||
;; before resolution can continue.
|
||||
|
||||
;; A ResolverContinuation is a (Maybe<CompiledZone> -> ResolverResult).
|
||||
|
||||
;; A ResolverNetworkQuery is a (resolver-network-query Question
|
||||
;; CompiledZone RR<NS> ListOf<IPv4> ResolverContinuation),
|
||||
;; representing a subquestion that must be answered before resolution
|
||||
;; can continue.
|
||||
(struct resolver-network-query (q zone ns-rr addresses k) #:transparent)
|
||||
|
||||
;; Rules:
|
||||
|
|
@ -186,9 +197,11 @@
|
|||
(question-result q
|
||||
zone
|
||||
ns-rrset
|
||||
(and start-of-authority (set start-of-authority))
|
||||
(if start-of-authority (set start-of-authority) (set))
|
||||
(additional-section/a zone (set-map ns-rrset rr-rdata))))
|
||||
|
||||
;; TODO: simplify external API here, supplying such as (set) for
|
||||
;; nameservers-tried and values for k.
|
||||
(define (resolve-from-zone q zone start-of-authority recursion-desired? nameservers-tried k)
|
||||
(answer-from-zone q zone start-of-authority recursion-desired?
|
||||
k
|
||||
|
|
@ -200,7 +213,6 @@
|
|||
(let ((best-nameserver (random-element best-nameservers)))
|
||||
(network-query q zone best-nameserver
|
||||
(lambda (enhanced-zone)
|
||||
(write `(BACK-FROM-NETWORK-QUERY (original-question ,q) (best-nameserver ,best-nameserver) (qr ,enhanced-zone))) (newline)
|
||||
(if (eq? enhanced-zone #f)
|
||||
;; name-error received!
|
||||
(k #f)
|
||||
|
|
|
|||
13
test-rrs.rkt
13
test-rrs.rkt
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
(require "api.rkt")
|
||||
|
||||
(provide test-soa-rr test-rrs)
|
||||
(provide test-soa-rr test-rrs test-roots)
|
||||
|
||||
(define test-soa-rr
|
||||
(rr '(#"example") 'soa 'in 30
|
||||
|
|
@ -25,3 +25,14 @@
|
|||
(rr '(#"hello" #"example") 'txt 'in 30 '(#"Hello CRASH"))
|
||||
(rr '(#"subzone" #"example") 'ns 'in 30 '(#"subns" #"example"))
|
||||
(rr '(#"subns" #"example") 'a 'in 30 '#(127 0 0 2))))
|
||||
|
||||
(define test-roots
|
||||
(list (rr '() 'ns 'in 30 '(#"f" #"root-servers" #"net"))
|
||||
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(198 41 0 4))
|
||||
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 228 79 201))
|
||||
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 33 4 12))
|
||||
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 203 230 10))
|
||||
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 112 36 4))
|
||||
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(128 63 2 53))
|
||||
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 58 128 30))
|
||||
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(193 0 14 129))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue