#lang racket/base

;; DNS server using os-big-bang.rkt and os-udp.rkt.

(require racket/match)
(require racket/set)
(require racket/bool)
(require "../racket-bitsyntax/main.rkt")
(require "api.rkt")
(require "codec.rkt")
(require "zonedb.rkt")
(require "resolver.rkt")
(require "../racket-matrix/os.rkt")
(require "../racket-matrix/os-big-bang.rkt")
(require "../racket-matrix/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
;; 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.

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

  (define boot-server
    (os-big-bang 'no-state
		 (send-meta-message `(request create-server-socket (udp new ,port-number 512)))
		 (subscribe/fresh wait-id
		   (meta-message-handlers w
		     [`(reply create-server-socket ,s)
		      (transition w
			(unsubscribe wait-id)
			(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 (nested-vm boot-server)))))

(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-sink) request)

  (define (make-reply name send-name-error? answers authorities additional)
    (dns-message (dns-message-id request-message)
		 'response
		 'query
		 (if (in-bailiwick? name (rr-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-define (question qname qtype qclass) q)

    (define (expand-cnames worklist ans)
      (match worklist
	['()
	 (match-define (complete-answer ns us ds) ans)
	 (make-reply qname #f ns us ds)]
	[(cons next-cname rest)
	 (define a (resolve-from-zone (question next-cname qtype qclass) zone soa-rr (set)))
	 (incorporate-answer a rest ans)]))

    (define (incorporate-answer this-answer worklist ans)
      (match this-answer
	[(partial-answer new-info more-cnames)
	 (expand-cnames (append worklist more-cnames)
			(merge-answers new-info ans))]
	[(? complete-answer?)
	 (expand-cnames worklist
			(merge-answers this-answer ans))]
	[_ ;; #f or a referral
	 (expand-cnames worklist ans)]))

    (match (resolve-from-zone q zone soa-rr (set))
      [#f ;; Signal name-error/NXDOMAIN
       (make-reply qname #t (set) (set) (set))]
      [(referral _ ns-rrs additional)
       (make-reply qname #f ns-rrs (set soa-rr) additional)]
      [this-answer
       (incorporate-answer this-answer '() (empty-complete-answer))]))

  ;; 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-sink request-source))
       (first-only (dns-message-questions request-message))))

(require "test-rrs.rkt")
(start-server (test-port-number) test-soa-rr test-rrs)