os-big-bang version of simplified-driver.rkt

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<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
+;; 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)