From d24ca2a2c8833d33df8d4464c00fd2121edd93aa Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Mon, 16 Jan 2012 18:12:26 -0500 Subject: [PATCH] os-big-bang version of simplified-driver.rkt --- big-bang-driver.rkt | 170 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 170 insertions(+) create mode 100644 big-bang-driver.rkt diff --git a/big-bang-driver.rkt b/big-bang-driver.rkt new file mode 100644 index 0000000..1715d5f --- /dev/null +++ b/big-bang-driver.rkt @@ -0,0 +1,170 @@ +#lang racket/base + +;; DNS server using os-big-bang.rkt and os-udp.rkt. + +(require racket/unit) +(require racket/match) +(require racket/set) +(require racket/bool) +(require "../racket-bitsyntax/main.rkt") +(require "api.rkt") +(require "codec.rkt") +(require "zonedb.rkt") +(require "network-query-sig.rkt") +(require "resolver-unit.rkt") +(require "dump-bytes.rkt") +(require "os-big-bang.rkt") +(require "os-udp.rkt") + +(define-unit network-query@ + (import) + (export network-query^) + (define (network-query/addresses q db ns-rr addresses) + (error 'network-query/addresses "Forbidden to invoke resolver in server"))) + +(define-values/invoke-unit/infer + (link resolver@ network-query@)) + +;; 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 +;; authoritatively. Never caches information, never performs recursive +;; queries. + +;; Rules: + +;; - Answers authoritative NXDOMAIN answers for queries falling within +;; its zone. (This is the only responder entitled to answer NXDOMAIN!) +;; - Answers with referrals for queries falling in subzones. It +;; 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) + +;; start-server : UInt16 RR ListOf -> 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 +;; in the soa-rr given. +(require racket/pretty) +(define (start-server port-number soa-rr rrs) + ;; Compile the zone hash table + (define zone (compile-zone-db (cons soa-rr rrs))) + (pretty-print zone) + + ;; TODO: STACKED VMS for different layers! + ;; That will let us do this: + ;; (lambda (unhandled state) + ;; (error 'dns-server "Unhandled packet ~v" unhandled)) + + (define boot-server + (os-big-bang 'no-state + (send-message `(request create-server-socket (udp new ,port-number 512))) + (subscribe 'wait-for-server-socket + (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)) + (subscribe 'packet-handler (packet-handler s)))])))) + + (define (packet-handler s) + (message-handlers old-state + [(? bad-dns-packet? p) + (pretty-print p) ;; TODO: perhaps use metalevel events? perhaps don't bother though + old-state] + [(? dns-request? r) + (transition old-state + (map send-message + (handle-request soa-rr zone r)))])) + + (ground-vm (os-big-bang (void) + (spawn udp-driver) + (spawn boot-server)))) + +(define (dns-read-driver s) + (os-big-bang 'no-state + (subscribe 'packet-reader + (message-handlers w + [(udp-packet source (== s) body) + (transition w + (send-message + (with-handlers ((exn? (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 + (send-message + (with-handlers ((exn? (lambda (e) (bad-dns-packet message s sink + 'unencodable)))) + (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) + + (define (make-reply name send-name-error? answers authorities additional) + (dns-message (dns-message-id request-message) + 'response + 'query + (if (in-bailiwick? name soa-rr) 'authoritative 'non-authoritative) + 'not-truncated + (dns-message-recursion-desired request-message) + 'no-recursion-available + (if send-name-error? 'name-error 'no-error) + (dns-message-questions request-message) + (rr-set->list answers) + (rr-set->list authorities) + (rr-set->list additional))) + + (define (answer-question q make-reply) + ;; Notice that we claim to be authoritative for our configured + ;; zone. If we ever answer name-error, that means there are no RRs + ;; *at all* for the queried name. If there are RRs for the queried + ;; name, but they happen not to be the ones asked for, name-error + ;; must *not* be returned: instead, a normal no-error reply is + ;; sent with an empty answer section. + ;; + ;; If we wanted to support caching of negative replies, we'd + ;; follow the guidelines in section 4.3.4 "Negative response + ;; caching" of RFC1034, adding our zone SOA with an appropriate + ;; TTL to the additional section of the reply. + ;; + ;; TODO: We support returning out-of-bailiwick records (glue) + ;; here. Reexamine the rules for doing so. + (match (resolve-from-zone q zone soa-rr #f (set)) + [#f + (make-reply (question-name q) + #t + (set) + (set) + (set))] + [(question-result _ _ answers authorities additional) + (make-reply (question-name q) + #f + answers + authorities + additional)])) + + ;; 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)) + (first-only (dns-message-questions request-message)))) + +(require "test-rrs.rkt") +(start-server 5555 test-soa-rr test-rrs)