diff --git a/experiments/EDLS.png b/experiments/EDLS.png
deleted file mode 100644
index e9601e2..0000000
Binary files a/experiments/EDLS.png and /dev/null differ
diff --git a/experiments/edls.rkt b/experiments/edls.rkt
deleted file mode 100644
index 510bca6..0000000
--- a/experiments/edls.rkt
+++ /dev/null
@@ -1,242 +0,0 @@
-#lang racket/base
-;; Extensible Denotational Language Specifications
-
-;; The paper "Extensible Denotational Language Specifications", by
-;; Cartwright & Felleisen (1994), henceforth "EDLS", presents a
-;; picture of an extensible interpreter for programming languages. The
-;; interpreter can be extended with new syntactic forms (and their
-;; meanings), new actions (and their effects), and new kinds of
-;; resources to be placed under its control.
-
-;; Rather than interpreting an extensible collection of syntax here,
-;; we call Racket code directly. Extension at the syntactic level is
-;; provided by Racket's macros. The purpose of this code is to provide
-;; a structured model of the extensible actions and extensible
-;; resource-management facets of the EDLS design. We use delimited
-;; continuations to transfer control between the "pure" facet (the
-;; interpretation of programs) and the impure or operational facets
-;; (the performing of actions, and management of resources).
-
-;; TODO: investigate continuation barriers, to avoid throws out
-;; through the current interpreter/VM. Actually, think harder about
-;; what even needs protecting - it's not clear.
-
-;; TODO: what happens when an interactor, performing an action, raises
-;; an exception? What should happen? In some sense it's the fault of
-;; the invoker of the action, isn't it? Consider binding a UDP socket
-;; to a port already in use. Alternatively, consider some internal
-;; error in the interactor: then it's not the fault of the invoker at
-;; all.
-
-;; TODO: pull in scheduler and event-stream ideas from Olin's papers
-
-;; TODO: consider splitting lookup from apply in
-;; action-handlers. Consider, for instance, replicating action
-;; streams: you might want to check for DNU before replicating the
-;; pending action.
-
-;; TODO: think about using a private prompt tag, and what the
-;; consequences for cross-virtual-level interaction are if multiple
-;; prompt tags are in play. This will force some thinking about
-;; continuation barriers, too.
-
-;; TODO: think about how a weak table might be exposed as a
-;; resource. Its implementation depends on primitive weakness! (Or on
-;; a transitively-provided weak service.)
-
-#|
-
-Things that can wake up some continuations:
-
- - external events (CML-style, timeouts)
- - internal events (completion of a write or similar)
- - unguarded continuations (spawned threads, basically)
-
-
-Are these containery things the conversation/chatrooms of racket-ssh?
-
-|#
-
-;; From the fine manual: "The protocol for vs supplied to an abort is
-;; specific to the prompt-tag. When abort-current-continuation is used
-;; with (default-continuation-prompt-tag), generally, a single thunk
-;; should be supplied that is suitable for use with the default prompt
-;; handler. Similarly, when call-with-continuation-prompt is used with
-;; (default-continuation-prompt-tag), the associated handler should
-;; generally accept a single thunk argument."
-
-;; Semantic framework from EDLS:
-;;
-;; computation : (+ (make-value value) (make-effect action (-> value computation)))
-;; program-meaning : (-> program (* (+ value error) resources)
-;; expression-meaning : (-> expr env computation)
-;; admin : (-> (* computation resources) (* (+ value error) resources))
-;; handler : (-> computation (-> value computation) computation)
-;;
-;; Handler is used to stitch stack frames together into a composed
-;; continuation, something that we're doing here natively with
-;; Racket's composable continuations.
-;;
-;; If we're going to make values self-representing, then we need to
-;; ensure that all effects are disjoint from values. The way to do
-;; that is to control the abort/prompt-tag protocol closely, so that
-;; regular values returned are distinguished from actions thrown. That
-;; way, no value is forbidden to the userland, including descriptions
-;; of actions.
-
-;; Can we say that the *communications facility* in EDLS is
-;; underpowered? It's point-to-point and relies on noninterference
-;; between action-handling extensions. Since each extension is
-;; logically managing its own resources, it feels like we have a kind
-;; of network-layer here IF we enforce separation of the managed
-;; resources so there are no cross-channels.
-;;
-;; The reason I'm interested in this approach is to get some kind of
-;; objcap-oriented interface not only to the substrate but to the
-;; extensions embedded in the substrate. Consider the DNS-server case,
-;; where a socket needs to be opened and then straight-line
-;; interactions with the socket take place. Now consider the DNS-proxy
-;; case, where not only does a socket (or more than one!) need to be
-;; created, but complex conversional contexts are built up as each
-;; query arrives and is processed. As DJB observes, a single query can
-;; in principle result in unbounded recursion as "glue" records are
-;; looked up. It kind of makes sense to have each conversational
-;; context as a separate entity, managing its own resources, embedded
-;; in the substrate.
-
-(require racket/match)
-(require racket/class)
-
-(define interactor<%>
- (interface ()
- perform-action))
-
-(define action-prompt (make-continuation-prompt-tag 'interactor-action))
-
-(define (perform-action . action-pieces)
- (call-with-composable-continuation
- (lambda (k)
- (abort-current-continuation action-prompt
- (lambda () (values action-pieces k))))
- action-prompt))
-
-(define (run/interactor boot interactor)
- (call-with-continuation-barrier
- (lambda ()
- (let loop ((next-step-thunk (lambda () (values (boot) #f)))
- (interactor interactor))
- (define-values (computation-step-result computation-step-continuation)
- (call-with-continuation-prompt next-step-thunk action-prompt))
- (cond
- ((eq? computation-step-continuation #f)
- ;; The computation is finished, and has yielded a result.
- computation-step-result)
- (else
- ;; The computation is not finished, but is waiting for an
- ;; action to complete.
- (send interactor perform-action
- computation-step-result
- (lambda (action-result-value new-interactor)
- (loop (lambda () (computation-step-continuation action-result-value))
- new-interactor))
- (lambda ()
- (error 'run/interactor "Action not interpretable by context: ~v"
- computation-step-result)))))))))
-
-(define cells%
- (class* object% (interactor<%>)
- (init-field next-name)
- (init-field mapping)
- (super-new)
- (define/public (perform-action action k-ok k-dnu)
- (match action
- (`(new ,initial-value)
- (k-ok next-name (make-object cells%
- (+ next-name 1)
- (hash-set mapping next-name initial-value))))
- (`(get ,n)
- (if (hash-has-key? mapping n)
- (k-ok (hash-ref mapping n) this)
- (error 'cells% "Cell name ~v not found (on get)" n)))
- (`(set ,n ,new-value)
- (if (hash-has-key? mapping n)
- (k-ok new-value (make-object cells%
- next-name
- (hash-set mapping n new-value)))
- (error 'cells% "Cell name ~v not found (on set)" n)))
- (else
- (k-dnu))))))
-
-(define (new-cell [initial-value (void)])
- (perform-action 'new initial-value))
-
-(define (get-cell c)
- (perform-action 'get c))
-
-(define (set-cell! c v)
- (perform-action 'set c v))
-
-(define (empty-cells)
- (make-object cells% 0 (hash)))
-
-(define combine%
- (class* object% (interactor<%>)
- (init-field children)
- (super-new)
- (define/public (perform-action action k-ok k-dnu)
- (let search ((remaining children)
- (examined '()))
- (cond
- ((null? remaining) (k-dnu))
- (else
- (define child (car remaining))
- (define rest (cdr remaining))
- (send child perform-action
- action
- (lambda (result new-child)
- (k-ok result
- (make-object combine% (append (reverse examined) (cons new-child rest)))))
- (lambda ()
- (search rest (cons child examined))))))))))
-
-(define (combine-interactors is)
- (make-object combine% is))
-
-(define udp%
- (class* object% (interactor<%>)
- (struct handle (socket)) ;; generative: new predicate etc. per udp% instance!
- (super-new)
- (define/public (perform-action action k-ok k-dnu)
- (match action
- (`(new)
- (k-ok (handle (udp-open-socket #f #f)) this))
- (`(bind ,(handle s) ,port)
- (k-ok (udp-bind! s #f port) this))
- (`(send ,(handle s) ,host ,port ,packet)
- (k-ok (udp-send-to s host port packet) this))
- (`(recv ,(handle s) ,packet-size-limit)
- (define buffer (make-bytes packet-size-limit))
- (define-values (packet-length source-hostname source-port)
- (udp-receive! s buffer))
- (k-ok (list source-hostname source-port (subbytes buffer 0 packet-length)) this))
- (else (k-dnu))))))
-
-(run/interactor (lambda () 1234)
- (empty-cells))
-
-(run/interactor (lambda ()
- (let ((x (new-cell)))
- (set-cell! x 1)
- (set-cell! x (+ 1 (get-cell x)))
- (+ 1000 (get-cell x))))
- (empty-cells))
-
-(run/interactor (lambda ()
- (let ((x (new-cell 'initial-x-value))
- (y (new-cell 'initial-y-value)))
- (set-cell! x 1)
- (set-cell! y 1000)
- (set-cell! x (+ 1 (get-cell x)))
- (+ (get-cell x)
- (get-cell y))))
- (combine-interactors (list (empty-cells))))
diff --git a/experiments/quadratic-choice-evt-fold.rkt b/experiments/quadratic-choice-evt-fold.rkt
deleted file mode 100644
index 2c8450c..0000000
--- a/experiments/quadratic-choice-evt-fold.rkt
+++ /dev/null
@@ -1,25 +0,0 @@
-(require srfi/1)
-
-(define (c v acc) acc)
-(define (c v acc) (choice-evt never-evt acc))
-(define (c v acc) (choice-evt (handle-evt always-evt void) acc))
-
-(define-values (c1 c2) (values values list))
-(define-values (c1 c2) (values (lambda (i) never-evt) choice-evt))
-(define-values (c1 c2) (values (lambda (i) (handle-evt always-evt void)) choice-evt))
-
-(for-each (lambda (n)
- (define limit (* 128 (expt 2 n)))
- (write limit)
- (newline)
- (time (do ((i 0 (+ i 1))
- (e never-evt (c i e)))
- ((= i limit) e))))
- (iota 16))
-
-(for-each (lambda (n)
- (define limit (* 128 (expt 2 n)))
- (write limit)
- (newline)
- (time (apply c2 (map c1 (iota limit)))))
- (iota 16))
\ No newline at end of file
diff --git a/experiments/sfclient.rkt b/experiments/sfclient.rkt
deleted file mode 100644
index ff19c63..0000000
--- a/experiments/sfclient.rkt
+++ /dev/null
@@ -1,42 +0,0 @@
-#lang racket/base
-
-(require "os-big-bang.rkt")
-(require "os-udp.rkt")
-(require "os-timer.rkt" racket/match)
-
-(define getter
- (os-big-bang 'none
- (send-message `(request create-echo-socket (udp new 0 65536)))
- (subscribe/fresh sub
- (message-handlers w
- [`(reply create-echo-socket ,sname)
- (transition w
- (unsubscribe sub)
- (send-message (udp-packet sname (udp-address "127.0.0.1" 5678) #"get"))
- (send-message (set-timer 'timeout 500 #t))
- (subscribe 'reply-waiter
- (message-handlers w
- [(udp-packet source (== sname) reply-bytes)
- (define counter (integer-bytes->integer reply-bytes #f))
- (write counter)
- (newline)
- (transition w
- (send-message 'quit)
- (unsubscribe 'reply-waiter))]
- [(timer-expired 'timeout _)
- (write 'timed-out)
- (newline)
- (transition w
- (send-message 'quit)
- (unsubscribe 'reply-waiter))])))]))))
-
-(ground-vm
- (os-big-bang 'none
- (spawn (os-big-bang 'none
- (subscribe 'quit-waiter
- (message-handlers w
- ['quit
- (exit)]))))
- (spawn udp-driver)
- (spawn (timer-driver))
- (spawn getter)))
diff --git a/experiments/sfclient2.rkt b/experiments/sfclient2.rkt
deleted file mode 100644
index c0bd55f..0000000
--- a/experiments/sfclient2.rkt
+++ /dev/null
@@ -1,14 +0,0 @@
-#lang racket/base
-
-(require racket/match)
-(require racket/udp)
-
-(define s (udp-open-socket #f #f))
-(udp-send-to s "127.0.0.1" 5678 #"get")
-(define buffer (make-bytes 8))
-(sync/timeout 0.5
- (wrap-evt (udp-receive!-evt s buffer)
- (match-lambda
- [(list 8 _ _)
- (write (integer-bytes->integer buffer #f))
- (newline)])))
diff --git a/experiments/sfclient3.rkt b/experiments/sfclient3.rkt
deleted file mode 100644
index f496a75..0000000
--- a/experiments/sfclient3.rkt
+++ /dev/null
@@ -1,24 +0,0 @@
-#lang racket/base
-
-(require racket/match)
-(require racket/udp)
-
-(define s (udp-open-socket #f #f))
-(define buffer (make-bytes 8))
-(define nrepeats 3500)
-
-(for-each
- (lambda (x) (write `(,x milliseconds in ,nrepeats repeats =
- ,(exact->inexact (/ x nrepeats)))) (newline))
- (cdr
- (call-with-values (lambda ()
- (time-apply
- (lambda ()
- (for ([i (in-range nrepeats)])
- (udp-send-to s "127.0.0.1" 5678 #"get")
- (sync/timeout 0.5
- (wrap-evt (udp-receive!-evt s buffer)
- (match-lambda
- [(list 8 _ _) 'ok])))))
- '()))
- list)))
diff --git a/experiments/sfserver.rkt b/experiments/sfserver.rkt
deleted file mode 100644
index 0f028ea..0000000
--- a/experiments/sfserver.rkt
+++ /dev/null
@@ -1,25 +0,0 @@
-#lang racket
-
-(require "os-big-bang.rkt")
-(require "os-udp.rkt")
-
-(define counter
- (os-big-bang 0
- (send-message `(request create-echo-socket (udp new 5678 65536)))
- (subscribe/fresh sub
- (message-handlers current-counter
- [`(reply create-echo-socket ,sname)
- (transition current-counter
- (unsubscribe sub)
- (subscribe 'packet-handler
- (message-handlers current-counter
- [(udp-packet source (== sname) #"get")
- (transition (+ current-counter 1)
- (send-message
- (udp-packet sname source
- (integer->integer-bytes current-counter 8 #f))))])))]))))
-
-(ground-vm
- (os-big-bang 'none
- (spawn udp-driver)
- (spawn counter)))
diff --git a/experiments/sfserver2.rkt b/experiments/sfserver2.rkt
deleted file mode 100644
index a3f93ec..0000000
--- a/experiments/sfserver2.rkt
+++ /dev/null
@@ -1,29 +0,0 @@
-#lang racket
-
-(require "os-big-bang.rkt")
-(require "os-udp.rkt")
-
-(define (counter server-socket)
- (os-big-bang 0
- (subscribe 'packet-handler
- (message-handlers current-counter
- [(udp-packet source (== server-socket) #"get")
- (transition (+ current-counter 1)
- (send-message
- (udp-packet server-socket source
- (integer->integer-bytes current-counter 8 #f))))]))))
-
-(define main
- (os-big-bang 'no-state
- (send-message `(request create-echo-socket (udp new 5678 65536)))
- (subscribe/fresh sub
- (message-handlers w
- [`(reply create-echo-socket ,server-socket)
- (transition w
- (unsubscribe sub)
- (spawn (counter server-socket)))]))))
-
-(ground-vm
- (os-big-bang 'none
- (spawn udp-driver)
- (spawn main)))
diff --git a/prototype/dns.rkt b/prototype/dns.rkt
deleted file mode 100644
index 30d382b..0000000
--- a/prototype/dns.rkt
+++ /dev/null
@@ -1,619 +0,0 @@
-#lang racket/base
-
-(require (planet tonyg/bitsyntax))
-(require racket/udp)
-(require racket/match)
-
-(require "mapping.rkt")
-
-;; Protocol data taken from RFC-1035. (See also RFC-1034.)
-;; Blocks of text inside ... also from RFC-1035.
-;; RFC-3596 specifies "DNS Extensions to Support IP Version 6".
-
-;; RFC-2782 specifies the DNS SRV record, though weirdly it omits a
-;; wire-level definition of the format! Presumably people have just
-;; copied what they see everyone else do here!
-
-(provide (struct-out dns-message)
- (struct-out question)
- (struct-out rr)
- (struct-out hinfo)
- (struct-out minfo)
- (struct-out mx)
- (struct-out soa)
- (struct-out wks)
- (struct-out srv)
-
- value->query-opcode query-opcode->value
- value->query-response-code query-response-code->value
- type->value value->type
- qtype->value value->qtype
- class->value value->class
- qclass->value value->qclass
-
- packet->dns-message
- dns-message->packet
-
- make-dns-query
- make-dns-response
-
- raw-dns-query)
-
-;;---------------------------------------------------------------------------
-;; Data definitions
-
-;; A DomainName is a ListOf, representing a domain name. The
-;; head of the list is the leftmost label; for example, www.google.com
-;; is represented as '(#"www" #"google" #"com").
-
-;; A ShortString is a String with length 255 or shorter.
-
-;; An IPv4 is a (vector Byte Byte Byte Byte), representing an IPv4
-;; address. For example, 127.0.0.1 is represented as (vector 127 0 0
-;; 1).
-
-;; An IPv6 is a Vector of length 16 containing Bytes, representing an
-;; IPv6 address. For example, 2001:0db8:85a3:0000:0000:8a2e:0370:7334
-;; is represented as (vector #x20 #x01 #x0d #xb8 #x85 #xa3 #x00 #x00
-;; #x00 #x00 #x8a #x2e #x03 #x70 #x73 #x34).
-
-;; A DNSMessage is a
-;; (dns-message Uint16 Direction Opcode Authoritativeness
-;; Truncatedness RecursionDesired RecursionAvailable ResponseCode
-;; ListOf ListOf ListOf ListOf).
-;;
-;; Interpreted as either a DNS request or reply, depending on the
-;; Direction.
-(struct dns-message (id
- direction
- opcode
- authoritative
- truncated
- recursion-desired
- recursion-available
- response-code
- questions
- answers
- authorities
- additional)
- #:transparent)
-
-;; A Question is a (question DomainName QueryType QueryClass),
-;; representing a DNS question: "What are the RRs for the given name,
-;; type and class?"
-(struct question (name type class) #:transparent)
-
-;; An RR is a (rr DomainName RRType RRClass Uint32 RData),
-;; representing a resource record.
-(struct rr (name type class ttl rdata) #:transparent)
-
-;; An RData is one of
-;; - an IPv4, an "A" record
-;; - an IPv6, an "AAAA" record
-;; - (hinfo ShortString ShortString), a host information record [O]
-;; - (minfo DomainName DomainName), a mailbox information record [O]
-;; - (mx Uint16 DomainName), a mail exchanger record
-;; - (soa DomainName DomainName Uint32 Uint32 Uint32 Uint32 Uint32), a
-;; start-of-authority record
-;; - (wks IPv4 Byte Bytes), a Well-Known Service [O]
-;; - (srv Uint16 Uint16 Uint16 DomainName), an "SRV" record
-;;
-;; In each case, the RData's variant MUST line up correctly with the
-;; type field of any RR containing it.
-;;
-;; Many of these variants are obsolete in today's DNS database (marked
-;; [O] above).
-(struct hinfo (cpu os) #:transparent)
-(struct minfo (rmailbx emailbx) #:transparent)
-(struct mx (preference exchange) #:transparent)
-(struct soa (mname rname serial refresh retry expire minimum) #:transparent)
-(struct wks (address protocol bitmap) #:transparent)
-(struct srv (priority weight port target) #:transparent)
-
-;; An Opcode is a Symbol or a Number, one of the possibilities given
-;; in the following define-mapping. It represents a DNS message
-;; operation; see the RFC for details.
-(define-mapping value->query-opcode query-opcode->value
- #:forward-default values
- #:backward-default values
- (0 query)
- (1 iquery)
- (2 status))
-
-;; A ResponseCode is a Symbol or a Number, one of the possibilities
-;; given in the following define-mapping. It represents the outcome of
-;; a DNS query.
-(define-mapping value->query-response-code query-response-code->value
- (0 no-error)
- (1 format-error)
- (2 server-failure)
- (3 name-error)
- (4 not-implemented)
- (5 refused))
-
-;; An RRType is a Symbol or a Number, one of the possibilities given
-;; in the following define-mapping. It represents the type of an
-;; RR. When used in an RR with an RData, the RRType and the RData
-;; variant must correspond.
-(define-mapping type->value value->type
- #:forward-default values
- #:backward-default values
- (a 1)
- (ns 2)
- (md 3)
- (mf 4)
- (cname 5)
- (soa 6)
- (mb 7)
- (mg 8)
- (mr 9)
- (null 10)
- (wks 11)
- (ptr 12)
- (hinfo 13)
- (minfo 14)
- (mx 15)
- (txt 16)
- (aaaa 28)
- (srv 33))
-
-;; A QueryType is a Symbol or Number (as given in the following
-;; define-mapping) or an RRType. It specifies the kinds of records
-;; being sought after in a DNS query.
-(define-mapping qtype->value value->qtype
- #:forward-default type->value
- #:backward-default value->type
- (axfr 252)
- (mailb 253)
- (maila 254)
- (* 255))
-
-;; An RRClass is a Symbol or a Number, one of the possibilities given
-;; in the following define-mapping. It represents the "class" of DNS
-;; records being discussed. All classes except 'in are obsolete in
-;; today's DNS databases.
-(define-mapping class->value value->class
- #:forward-default values
- #:backward-default values
- (in 1)
- (cs 2)
- (ch 3)
- (hs 4))
-
-;; A QueryClass is a Symbol or Number (as given in the following
-;; define-mapping) or an RRClass. It specifies the "class" of records
-;; being sought after in a DNS query.
-(define-mapping qclass->value value->qclass
- #:forward-default class->value
- #:backward-default value->class
- (* 255))
-
-;;---------------------------------------------------------------------------
-;; DNS message codec
-
-;;
-;; All communications inside of the domain protocol are carried in a single
-;; format called a message. The top level format of message is divided
-;; into 5 sections (some of which are empty in certain cases) shown below:
-;;
-;; +---------------------+
-;; | Header |
-;; +---------------------+
-;; | Question | the question for the name server
-;; +---------------------+
-;; | Answer | RRs answering the question
-;; +---------------------+
-;; | Authority | RRs pointing toward an authority
-;; +---------------------+
-;; | Additional | RRs holding additional information
-;; +---------------------+
-;;
-
-;;
-;; The header contains the following fields:
-;;
-;; 1 1 1 1 1 1
-;; 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5
-;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;; | ID |
-;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;; |QR| Opcode |AA|TC|RD|RA| Z | RCODE |
-;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;; | QDCOUNT |
-;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;; | ANCOUNT |
-;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;; | NSCOUNT |
-;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;; | ARCOUNT |
-;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;;
-
-(define (bit->value n if0 if1)
- (if (positive? n) if1 if0))
-
-(define (value->bit b if0 if1)
- (cond
- ((eq? b if0) 0)
- ((eq? b if1) 1)
- (else (error 'value->bit "Value supplied is neither ~v nor ~v: ~v" if0 if1 b))))
-
-(define (packet->dns-message packet)
- (bit-string-case packet
- ([ (id :: bits 16)
- (qr :: bits 1)
- (opcode :: bits 4)
- (aa :: bits 1)
- (tc :: bits 1)
- (rd :: bits 1)
- (ra :: bits 1)
- (= 0 :: bits 3)
- (rcode :: bits 4)
- (qdcount :: bits 16)
- (ancount :: bits 16)
- (nscount :: bits 16)
- (arcount :: bits 16)
- (sections4 :: binary) ]
- (let*-values (((q-section sections3)
- (parse-section packet decode-question qdcount sections4))
- ((a-section sections2)
- (parse-section packet decode-rr ancount sections3))
- ((auth-section sections1)
- (parse-section packet decode-rr nscount sections2))
- ((additional-section sections0)
- (parse-section packet decode-rr arcount sections1)))
- (when (not (zero? (bit-string-length sections0)))
- (error 'packet->dns-message "Packet too long"))
- (dns-message id
- (bit->value qr 'request 'response)
- (value->query-opcode opcode)
- (bit->value aa 'non-authoritative 'authoritative)
- (bit->value tc 'not-truncated 'truncated)
- (bit->value rd 'no-recursion-desired 'recursion-desired)
- (bit->value ra 'no-recursion-available 'recursion-available)
- (value->query-response-code rcode)
- q-section
- a-section
- auth-section
- additional-section)))))
-
-(define (dns-message->packet m)
- (bit-string->bytes
- (bit-string ((dns-message-id m) :: bits 16)
- ((value->bit (dns-message-direction m)
- 'request 'response) :: bits 1)
- ((query-opcode->value (dns-message-opcode m)) :: bits 4)
- ((value->bit (dns-message-authoritative m)
- 'non-authoritative 'authoritative) :: bits 1)
- ((value->bit (dns-message-truncated m)
- 'not-truncated 'truncated) :: bits 1)
- ((value->bit (dns-message-recursion-desired m)
- 'no-recursion-desired 'recursion-desired) :: bits 1)
- ((value->bit (dns-message-recursion-available m)
- 'no-recursion-available 'recursion-available) :: bits 1)
- (0 :: bits 3)
- ((query-response-code->value (dns-message-response-code m)) :: bits 4)
- ((length (dns-message-questions m)) :: bits 16)
- ((length (dns-message-answers m)) :: bits 16)
- ((length (dns-message-authorities m)) :: bits 16)
- ((length (dns-message-additional m)) :: bits 16)
- ((bit-string-append
- (encode-section encode-question (dns-message-questions m))
- (encode-section encode-rr (dns-message-answers m))
- (encode-section encode-rr (dns-message-authorities m))
- (encode-section encode-rr (dns-message-additional m))) :: binary))))
-
-(define (parse-section packet parser remaining-records input)
- (let loop ((count remaining-records)
- (input input))
- (cond
- ((positive? count)
- (let*-values (((record remainder) (parser packet input))
- ((records final-remainder) (loop (sub1 count) remainder)))
- (values (cons record records) final-remainder)))
- (else
- (values '() input)))))
-
-(define (encode-section encoder records)
- (cond
- ((null? records) (bytes))
- ((null? (cdr records)) (encoder (car records)))
- (else (bit-string-append (encoder (car records))
- (encode-section encoder (cdr records))))))
-
-;; Domain-names use a strange "compressed" encoding.
-;; We have to be careful not to get stuck in a pointer loop here.
-
-(define (parse-domain-name whole-packet input pointers-followed)
- (bit-string-case input
-
- ([(= 3 :: bits 2) (offset :: bits 14) (rest :: binary)]
- (if (member offset pointers-followed)
- (error 'parse-domain-name "DNS compressed-pointer loop detected")
- (let-values (((lhs rhs) (bit-string-split-at whole-packet (* 8 offset))))
- (let-values (((labels ignored-tail)
- (parse-domain-name whole-packet rhs (cons offset pointers-followed))))
- (values labels rest)))))
-
- ([(= 0 :: bits 8) (rest :: binary)]
- (values '() rest))
-
- ([(= 0 :: bits 2) (len :: bits 6) (label :: binary bytes len) (rest :: binary)]
- ;; TODO: validate labels: make sure they conform to the prescribed syntax
- (let-values (((labels leftover)
- (parse-domain-name whole-packet rest pointers-followed)))
- (values (cons (bit-string->bytes label) labels) leftover)))))
-
-(define (parse-single-domain-name whole-packet input)
- (let-values (((name remainder) (parse-domain-name whole-packet input '())))
- (if (bit-string-empty? remainder)
- name
- (error 'parse-single-domain-name
- "Expected just the one name, but got some trailing junk"))))
-
-(define (extract-domain-names whole-packet input)
- (if (bit-string-empty? input)
- (let-values (((name remainder) (parse-domain-name whole-packet input '())))
- (cons name (extract-domain-names whole-packet remainder)))
- '()))
-
-(define (encode-domain-name labels)
- (cond
- ((null? labels) (bytes 0))
- (else (bit-string-append (encode-label (car labels))
- (encode-domain-name (cdr labels))))))
-
-(define (encode-label label)
- (encode-pascal-string "Label" 64 label))
-
-(define (encode-pascal-string string-kind length-limit s)
- (let ((len (bytes-length s)))
- (when (>= len length-limit)
- (error 'encode-pascal-string "~s too long: ~v" string-kind s))
- (bytes-append (bytes len) s)))
-
-;; Character strings are pascal-style length-byte-prefixed strings.
-
-(define (extract-character-strings input)
- (bit-string-case input
- ([]
- '())
- ([len (body :: binary bytes len) (rest :: binary)]
- (cons (bit-string->bytes body)
- (extract-character-strings rest)))))
-
-(define (encode-character-string bs)
- (encode-pascal-string "Character-string" 256 bs))
-
-;;
-;; The question section is used to carry the "question" in most queries,
-;; i.e., the parameters that define what is being asked. The section
-;; contains QDCOUNT (usually 1) entries, each of the following format:
-;;
-;; 1 1 1 1 1 1
-;; 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5
-;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;; | |
-;; / QNAME /
-;; / /
-;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;; | QTYPE |
-;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;; | QCLASS |
-;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;;
-
-(define (decode-question whole-packet input)
- (let-values (((qname remainder) (parse-domain-name whole-packet input '())))
- (bit-string-case remainder
- ([(qtype :: bits 16)
- (qclass :: bits 16)
- (tail :: binary)]
- (values (question qname
- (value->qtype qtype)
- (value->qclass qclass))
- tail)))))
-
-(define (encode-question q)
- (bit-string-append (encode-domain-name (question-name q))
- (bit-string ((qtype->value (question-type q)) :: bits 16)
- ((qclass->value (question-class q)) :: bits 16))))
-
-;;
-;; All RRs have the same top level format shown below:
-;;
-;; 1 1 1 1 1 1
-;; 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5
-;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;; | |
-;; / /
-;; / NAME /
-;; | |
-;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;; | TYPE |
-;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;; | CLASS |
-;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;; | TTL |
-;; | |
-;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;; | RDLENGTH |
-;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--|
-;; / RDATA /
-;; / /
-;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;;
-
-(define (decode-rr whole-packet input)
- (let-values (((name remainder) (parse-domain-name whole-packet input '())))
- (bit-string-case remainder
- ([(type-number :: bits 16)
- (class :: bits 16)
- (ttl :: bits 32)
- (rdlength :: bits 16)
- (rdata :: binary bytes rdlength)
- (tail :: binary)]
- (let ((type (value->type type-number)))
- (values (rr name
- type
- (value->class class)
- ttl
- (decode-rdata whole-packet type rdata))
- tail))))))
-
-(define (decode-rdata whole-packet type rdata)
- (case type
- ((cname mb md mf mg mr ns ptr) (parse-single-domain-name whole-packet rdata))
- ((hinfo) (apply hinfo (extract-character-strings rdata)))
- ((minfo) (apply minfo (extract-domain-names whole-packet rdata)))
- ((mx) (bit-string-case rdata
- ([(preference :: bits 16) (exchange :: binary)]
- (mx preference (parse-single-domain-name whole-packet exchange)))))
- ((null) (bit-string->bytes rdata))
- ((soa) (let*-values (((mname rdata1) (parse-domain-name whole-packet rdata '()))
- ((rname rdata2) (parse-domain-name whole-packet rdata1 '())))
- (bit-string-case rdata2
- ([(serial :: bits 32)
- (refresh :: bits 32)
- (retry :: bits 32)
- (expire :: bits 32)
- (minimum :: bits 32)]
- (soa mname rname serial refresh retry expire minimum)))))
- ((txt) (extract-character-strings rdata))
- ((a) (bit-string-case rdata
- ([a b c d]
- (vector a b c d))))
- ((aaaa) (bit-string-case rdata
- ([(ipv6-addr :: binary bits 128)]
- (list->vector (bytes->list (bit-string->bytes ipv6-addr))))))
- ((wks) (bit-string-case rdata
- ([a b c d protocol (bitmap :: binary)]
- (wks (vector a b c d) protocol bitmap))))
- ((srv) (bit-string-case rdata
- ([(priority :: bits 16)
- (weight :: bits 16)
- (port :: bits 16)
- (target :: binary)]
- (srv priority weight port (parse-single-domain-name whole-packet target)))))
- (else (bit-string->bytes rdata))))
-
-(define (encode-rr rr)
- (let ((encoded-rdata (encode-rdata (rr-type rr) (rr-rdata rr))))
- (bit-string-append (encode-domain-name (rr-name rr))
- (bit-string ((type->value (rr-type rr)) :: bits 16)
- ((class->value (rr-class rr)) :: bits 16)
- ((rr-ttl rr) :: bits 32)
- ((/ (bit-string-length encoded-rdata) 8) :: bits 16)
- (encoded-rdata :: binary)))))
-
-(define (encode-rdata type rdata)
- (case type
- ((cname mb md mf mg mr ns ptr) (encode-domain-name rdata))
- ((hinfo) (bit-string-append (encode-character-string (hinfo-cpu rdata))
- (encode-character-string (hinfo-os rdata))))
- ((minfo) (bit-string-append (encode-character-string (minfo-rmailbx rdata))
- (encode-character-string (minfo-emailbx rdata))))
- ((mx) (bit-string ((mx-preference rdata) :: bits 16)
- ((encode-domain-name (mx-exchange rdata)) :: binary)))
- ((null) rdata)
- ((soa) (bit-string-append (encode-domain-name (soa-mname rdata))
- (encode-domain-name (soa-rname rdata))
- (bit-string ((soa-serial rdata) :: bits 32)
- ((soa-refresh rdata) :: bits 32)
- ((soa-retry rdata) :: bits 32)
- ((soa-expire rdata) :: bits 32)
- ((soa-minimum rdata) :: bits 32))))
- ((txt)
- ;; TODO: write and use bit-string-append* instead of using apply here
- (foldl (lambda (s acc) (bit-string-append acc (encode-character-string s)))
- (car rdata)
- (cdr rdata)))
- ((a) (match rdata ((vector a b c d) (bit-string a b c d))))
- ((aaaa) (bit-string ((list->bytes (vector->list rdata)) :: binary bits 128)))
- ((wks) (match (wks-address rdata)
- ((vector a b c d)
- (bit-string a b c d (wks-protocol rdata) ((wks-bitmap rdata) :: binary)))))
- ((srv) (bit-string ((srv-priority rdata) :: bits 16)
- ((srv-weight rdata) :: bits 16)
- ((srv-port rdata) :: bits 16)
- ((encode-domain-name (srv-target rdata)) :: binary)))
- (else rdata)))
-
-;;---------------------------------------------------------------------------
-
-(define (make-dns-query questions
- [recursion-desired 'no-recursion-desired])
- (dns-message (random 65536)
- 'request
- 'query
- 'non-authoritative
- 'not-truncated
- recursion-desired
- 'no-recursion-available
- 'no-error
- questions
- '()
- '()
- '()))
-
-(define (make-dns-response query response-code answers authoritative
- [recursion-available 'no-recursion-available]
- [authorities '()]
- [additional '()])
- (dns-message (dns-message-id query)
- 'response
- (dns-message-opcode query)
- authoritative
- 'not-truncated
- (dns-message-recursion-desired query)
- recursion-available
- response-code
- (dns-message-questions query)
- answers
- authorities
- additional))
-
-(define (next-timeout timeout)
- (case timeout
- ((3) 11)
- ((11) 45)
- ((45) #f)))
-
-(define *total-port-finding-attempts* 100) ;; TODO: eliminate arbitrary 100?
-
-(define (bind-to-random-port! s)
- (let find-a-port ((remaining-tries *total-port-finding-attempts*))
- (if (zero? remaining-tries)
- (error 'bind-to-random-port! "Could not find a free UDP port in ~v tries"
- *total-port-finding-attempts*)
- (let ((port-number (+ 1024 (random (- 65536 1024)))))
- (with-handlers [(exn:fail:network?
- (lambda (e)
- ;; Bind failure. Port in use?
- (find-a-port (- remaining-tries 1))))]
- (udp-bind! s #f port-number))))))
-
-(define (raw-dns-query query [servers '("127.0.0.1")])
- (let ((s (udp-open-socket #f #f)))
- (bind-to-random-port! s)
- ;; TODO: randomize ordering of servers in list.
- (let search ((timeout 3)
- (remaining-servers servers))
- (if (null? remaining-servers)
- (let ((new-timeout (next-timeout timeout)))
- (if new-timeout
- (search new-timeout servers)
- #f))
- (let ((server (car remaining-servers)))
- (let ((server-hostname (if (string? server) server (car server)))
- (server-port (if (string? server) 53 (cadr server))))
- ;;(write `(querying ,server-hostname ,server-port with timeout ,timeout)) (newline)
- (udp-send-to s server-hostname server-port (dns-message->packet query))
- (let ((buffer (make-bytes 512))) ;; maximum DNS reply length
- (let ((result (sync/timeout timeout (udp-receive!-evt s buffer))))
- ;; TODO: maybe receive only specifically from the queried IP address?
- ;;(write `(response ,result)) (newline)
- (if result
- (let ((reply-length (car result)))
- (packet->dns-message (sub-bit-string buffer 0 (* 8 reply-length))))
- (search timeout (cdr remaining-servers)))))))))))
diff --git a/prototype/mapping.rkt b/prototype/mapping.rkt
deleted file mode 100644
index 9189f16..0000000
--- a/prototype/mapping.rkt
+++ /dev/null
@@ -1,35 +0,0 @@
-#lang racket/base
-
-(provide define-mapping)
-
-(define-syntax check-defaults
- (syntax-rules ()
- ((_ fn bn fd bd #:forward-default new-fd rest ...)
- (check-defaults fn bn new-fd bd rest ...))
- ((_ fn bn fd bd #:backward-default new-bd rest ...)
- (check-defaults fn bn fd new-bd rest ...))
- ((_ fn bn fd bd (lhs rhs) ...)
- (begin
- (define (fn l)
- (case l
- ((lhs) 'rhs) ...
- (else (fd l))))
- (define (bn r)
- (case r
- ((rhs) 'lhs) ...
- (else (bd r))))))))
-
-(define (die-with-mapping-name n)
- (lambda (v)
- (raise (exn:fail:contract
- (format "~v: Mapping not found for ~v" n v)
- (current-continuation-marks)))))
-
-(define-syntax define-mapping
- (syntax-rules ()
- ((_ forward-name backward-name rest ...)
- (check-defaults forward-name
- backward-name
- (die-with-mapping-name 'forward-name)
- (die-with-mapping-name 'backward-name)
- rest ...))))
diff --git a/prototype/test-dns.rkt b/prototype/test-dns.rkt
deleted file mode 100644
index 3e7b16c..0000000
--- a/prototype/test-dns.rkt
+++ /dev/null
@@ -1,248 +0,0 @@
-#lang racket/base
-
-(require "dns.rkt")
-
-;; Wed Jun 29 16:33:58 2011 (4e0b8c36): UDP: localhost sent 28 bytes:
-;; 00000000: 66 3A 01 00 00 01 00 00 : 00 00 00 00 06 67 6F 6F f:...........goo
-;; 00000010: 67 6C 65 03 63 6F 6D 00 : 00 FF 00 01 gle.com.....
-;; 0000001C:
-
-(define (q-google-in-any)
- (bytes #x66 #x3A #x01 #x00 #x00 #x01 #x00 #x00
- #x00 #x00 #x00 #x00 #x06 #x67 #x6F #x6F
- #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00
- #x00 #xFF #x00 #x01))
-
-;; Wed Jun 29 16:33:58 2011 (4e0b8c36): UDP: dslrouter.westell.com sent 494 bytes:
-;; 00000000: 66 3A 81 80 00 01 00 0F : 00 00 00 07 06 67 6F 6F f:...........goo
-;; 00000010: 67 6C 65 03 63 6F 6D 00 : 00 FF 00 01 C0 0C 00 10 gle.com.........
-;; 00000020: 00 01 00 00 0C 2F 00 52 : 51 76 3D 73 70 66 31 20 ...../.RQv=spf1
-;; 00000030: 69 6E 63 6C 75 64 65 3A : 5F 6E 65 74 62 6C 6F 63 include:_netbloc
-;; 00000040: 6B 73 2E 67 6F 6F 67 6C : 65 2E 63 6F 6D 20 69 70 ks.google.com ip
-;; 00000050: 34 3A 32 31 36 2E 37 33 : 2E 39 33 2E 37 30 2F 33 4:216.73.93.70/3
-;; 00000060: 31 20 69 70 34 3A 32 31 : 36 2E 37 33 2E 39 33 2E 1 ip4:216.73.93.
-;; 00000070: 37 32 2F 33 31 20 7E 61 : 6C 6C C0 0C 00 01 00 01 72/31 ~all......
-;; 00000080: 00 00 01 1D 00 04 4A 7D : E2 92 C0 0C 00 01 00 01 ......J}........
-;; 00000090: 00 00 01 1D 00 04 4A 7D : E2 94 C0 0C 00 01 00 01 ......J}........
-;; 000000A0: 00 00 01 1D 00 04 4A 7D : E2 91 C0 0C 00 01 00 01 ......J}........
-;; 000000B0: 00 00 01 1D 00 04 4A 7D : E2 93 C0 0C 00 01 00 01 ......J}........
-;; 000000C0: 00 00 01 1D 00 04 4A 7D : E2 90 C0 0C 00 02 00 01 ......J}........
-;; 000000D0: 00 03 A5 1D 00 06 03 6E : 73 32 C0 0C C0 0C 00 02 .......ns2......
-;; 000000E0: 00 01 00 03 A5 1D 00 06 : 03 6E 73 33 C0 0C C0 0C .........ns3....
-;; 000000F0: 00 02 00 01 00 03 A5 1D : 00 06 03 6E 73 31 C0 0C ...........ns1..
-;; 00000100: C0 0C 00 02 00 01 00 03 : A5 1D 00 06 03 6E 73 34 .............ns4
-;; 00000110: C0 0C C0 0C 00 0F 00 01 : 00 00 00 2A 00 11 00 14 ...........*....
-;; 00000120: 04 61 6C 74 31 05 61 73 : 70 6D 78 01 6C C0 0C C0 .alt1.aspmx.l...
-;; 00000130: 0C 00 0F 00 01 00 00 00 : 2A 00 09 00 1E 04 61 6C ........*.....al
-;; 00000140: 74 32 C1 25 C0 0C 00 0F : 00 01 00 00 00 2A 00 04 t2.%.........*..
-;; 00000150: 00 0A C1 25 C0 0C 00 0F : 00 01 00 00 00 2A 00 09 ...%.........*..
-;; 00000160: 00 28 04 61 6C 74 33 C1 : 25 C0 0C 00 0F 00 01 00 .(.alt3.%.......
-;; 00000170: 00 00 2A 00 09 00 32 04 : 61 6C 74 34 C1 25 C0 E8 ..*...2.alt4.%..
-;; 00000180: 00 01 00 01 00 03 A2 CF : 00 04 D8 EF 24 0A C0 FA ............$...
-;; 00000190: 00 01 00 01 00 03 A2 CF : 00 04 D8 EF 20 0A C1 0C ............ ...
-;; 000001A0: 00 01 00 01 00 03 A2 CF : 00 04 D8 EF 26 0A C0 D6 ............&...
-;; 000001B0: 00 01 00 01 00 03 A2 CF : 00 04 D8 EF 22 0A C1 3D ............"..=
-;; 000001C0: 00 01 00 01 00 00 00 F0 : 00 04 4A 7D 27 1B C1 25 ..........J}'..%
-;; 000001D0: 00 01 00 01 00 00 00 F6 : 00 04 4A 7D 73 1B C1 20 ..........J}s..
-;; 000001E0: 00 01 00 01 00 00 00 21 : 00 04 4A 7D 4D 1B .......!..J}M.
-;; 000001EE:
-
-(define (a-google-in-any)
- (bytes
- #x66 #x3A #x81 #x80 #x00 #x01 #x00 #x0F #x00 #x00 #x00 #x07 #x06 #x67 #x6F #x6F
- #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #xFF #x00 #x01 #xC0 #x0C #x00 #x10
- #x00 #x01 #x00 #x00 #x0C #x2F #x00 #x52 #x51 #x76 #x3D #x73 #x70 #x66 #x31 #x20
- #x69 #x6E #x63 #x6C #x75 #x64 #x65 #x3A #x5F #x6E #x65 #x74 #x62 #x6C #x6F #x63
- #x6B #x73 #x2E #x67 #x6F #x6F #x67 #x6C #x65 #x2E #x63 #x6F #x6D #x20 #x69 #x70
- #x34 #x3A #x32 #x31 #x36 #x2E #x37 #x33 #x2E #x39 #x33 #x2E #x37 #x30 #x2F #x33
- #x31 #x20 #x69 #x70 #x34 #x3A #x32 #x31 #x36 #x2E #x37 #x33 #x2E #x39 #x33 #x2E
- #x37 #x32 #x2F #x33 #x31 #x20 #x7E #x61 #x6C #x6C #xC0 #x0C #x00 #x01 #x00 #x01
- #x00 #x00 #x01 #x1D #x00 #x04 #x4A #x7D #xE2 #x92 #xC0 #x0C #x00 #x01 #x00 #x01
- #x00 #x00 #x01 #x1D #x00 #x04 #x4A #x7D #xE2 #x94 #xC0 #x0C #x00 #x01 #x00 #x01
- #x00 #x00 #x01 #x1D #x00 #x04 #x4A #x7D #xE2 #x91 #xC0 #x0C #x00 #x01 #x00 #x01
- #x00 #x00 #x01 #x1D #x00 #x04 #x4A #x7D #xE2 #x93 #xC0 #x0C #x00 #x01 #x00 #x01
- #x00 #x00 #x01 #x1D #x00 #x04 #x4A #x7D #xE2 #x90 #xC0 #x0C #x00 #x02 #x00 #x01
- #x00 #x03 #xA5 #x1D #x00 #x06 #x03 #x6E #x73 #x32 #xC0 #x0C #xC0 #x0C #x00 #x02
- #x00 #x01 #x00 #x03 #xA5 #x1D #x00 #x06 #x03 #x6E #x73 #x33 #xC0 #x0C #xC0 #x0C
- #x00 #x02 #x00 #x01 #x00 #x03 #xA5 #x1D #x00 #x06 #x03 #x6E #x73 #x31 #xC0 #x0C
- #xC0 #x0C #x00 #x02 #x00 #x01 #x00 #x03 #xA5 #x1D #x00 #x06 #x03 #x6E #x73 #x34
- #xC0 #x0C #xC0 #x0C #x00 #x0F #x00 #x01 #x00 #x00 #x00 #x2A #x00 #x11 #x00 #x14
- #x04 #x61 #x6C #x74 #x31 #x05 #x61 #x73 #x70 #x6D #x78 #x01 #x6C #xC0 #x0C #xC0
- #x0C #x00 #x0F #x00 #x01 #x00 #x00 #x00 #x2A #x00 #x09 #x00 #x1E #x04 #x61 #x6C
- #x74 #x32 #xC1 #x25 #xC0 #x0C #x00 #x0F #x00 #x01 #x00 #x00 #x00 #x2A #x00 #x04
- #x00 #x0A #xC1 #x25 #xC0 #x0C #x00 #x0F #x00 #x01 #x00 #x00 #x00 #x2A #x00 #x09
- #x00 #x28 #x04 #x61 #x6C #x74 #x33 #xC1 #x25 #xC0 #x0C #x00 #x0F #x00 #x01 #x00
- #x00 #x00 #x2A #x00 #x09 #x00 #x32 #x04 #x61 #x6C #x74 #x34 #xC1 #x25 #xC0 #xE8
- #x00 #x01 #x00 #x01 #x00 #x03 #xA2 #xCF #x00 #x04 #xD8 #xEF #x24 #x0A #xC0 #xFA
- #x00 #x01 #x00 #x01 #x00 #x03 #xA2 #xCF #x00 #x04 #xD8 #xEF #x20 #x0A #xC1 #x0C
- #x00 #x01 #x00 #x01 #x00 #x03 #xA2 #xCF #x00 #x04 #xD8 #xEF #x26 #x0A #xC0 #xD6
- #x00 #x01 #x00 #x01 #x00 #x03 #xA2 #xCF #x00 #x04 #xD8 #xEF #x22 #x0A #xC1 #x3D
- #x00 #x01 #x00 #x01 #x00 #x00 #x00 #xF0 #x00 #x04 #x4A #x7D #x27 #x1B #xC1 #x25
- #x00 #x01 #x00 #x01 #x00 #x00 #x00 #xF6 #x00 #x04 #x4A #x7D #x73 #x1B #xC1 #x20
- #x00 #x01 #x00 #x01 #x00 #x00 #x00 #x21 #x00 #x04 #x4A #x7D #x4D #x1B))
-
-(require racket/pretty)
-(pretty-print (packet->dns-message (q-google-in-any)))
-(pretty-print (packet->dns-message (a-google-in-any)))
-
-(pretty-print (dns-message->packet (packet->dns-message (a-google-in-any))))
-
-;; Wed Jun 29 20:59:17 2011 (4e0bca65): UDP: localhost sent 28 bytes:
-;; 00000000: 47 16 01 00 00 01 00 00 : 00 00 00 00 06 67 6F 6F G............goo
-;; 00000010: 67 6C 65 03 63 6F 6D 00 : 00 1C 00 01 gle.com.....
-;; 0000001C:
-;; Wed Jun 29 20:59:17 2011 (4e0bca65): UDP: pass through succeeded
-;; Wed Jun 29 20:59:17 2011 (4e0bca65): UDP: google-public-dns-a.google.com sent 78 bytes:
-;; 00000000: 47 16 81 80 00 01 00 00 : 00 01 00 00 06 67 6F 6F G............goo
-;; 00000010: 67 6C 65 03 63 6F 6D 00 : 00 1C 00 01 C0 0C 00 06 gle.com.........
-;; 00000020: 00 01 00 00 02 52 00 26 : 03 6E 73 31 C0 0C 09 64 .....R.&.ns1...d
-;; 00000030: 6E 73 2D 61 64 6D 69 6E : C0 0C 00 16 33 23 00 00 ns-admin....3#..
-;; 00000040: 1C 20 00 00 07 08 00 12 : 75 00 00 00 01 2C . ......u....,
-;; 0000004E:
-
-(pretty-print
- (packet->dns-message
- (bytes
- #x47 #x16 #x01 #x00 #x00 #x01 #x00 #x00 #x00 #x00 #x00 #x00 #x06 #x67 #x6F #x6F
- #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #x1C #x00 #x01)))
-
-(pretty-print
- (packet->dns-message
- (bytes
- #x47 #x16 #x81 #x80 #x00 #x01 #x00 #x00 #x00 #x01 #x00 #x00 #x06 #x67 #x6F #x6F
- #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #x1C #x00 #x01 #xC0 #x0C #x00 #x06
- #x00 #x01 #x00 #x00 #x02 #x52 #x00 #x26 #x03 #x6E #x73 #x31 #xC0 #x0C #x09 #x64
- #x6E #x73 #x2D #x61 #x64 #x6D #x69 #x6E #xC0 #x0C #x00 #x16 #x33 #x23 #x00 #x00
- #x1C #x20 #x00 #x00 #x07 #x08 #x00 #x12 #x75 #x00 #x00 #x00 #x01 #x2C)))
-
-;; Wed Jun 29 21:05:03 2011 (4e0bcbbf): UDP: localhost sent 32 bytes:
-;; 00000000: 12 70 01 00 00 01 00 00 : 00 00 00 00 03 77 77 77 .p...........www
-;; 00000010: 06 67 6F 6F 67 6C 65 03 : 63 6F 6D 00 00 1C 00 01 .google.com.....
-;; 00000020:
-;; Wed Jun 29 21:05:03 2011 (4e0bcbbf): UDP: pass through succeeded
-;; Wed Jun 29 21:05:03 2011 (4e0bcbbf): UDP: ns1.google.com sent 52 bytes:
-;; 00000000: 12 70 85 00 00 01 00 01 : 00 00 00 00 03 77 77 77 .p...........www
-;; 00000010: 06 67 6F 6F 67 6C 65 03 : 63 6F 6D 00 00 1C 00 01 .google.com.....
-;; 00000020: C0 0C 00 05 00 01 00 09 : 3A 80 00 08 03 77 77 77 ........:....www
-;; 00000030: 01 6C C0 10 : .l..
-;; 00000034:
-
-(pretty-print
- (packet->dns-message
- (bytes
- #x12 #x70 #x01 #x00 #x00 #x01 #x00 #x00 #x00 #x00 #x00 #x00 #x03 #x77 #x77 #x77
- #x06 #x67 #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #x1C #x00 #x01)))
-
-(pretty-print
- (packet->dns-message
- (bytes
- #x12 #x70 #x85 #x00 #x00 #x01 #x00 #x01 #x00 #x00 #x00 #x00 #x03 #x77 #x77 #x77
- #x06 #x67 #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #x1C #x00 #x01
- #xC0 #x0C #x00 #x05 #x00 #x01 #x00 #x09 #x3A #x80 #x00 #x08 #x03 #x77 #x77 #x77
- #x01 #x6C #xC0 #x10)))
-
-;; Wed Jun 29 21:07:46 2011 (4e0bcc62): UDP: ns1.google.com sent 82 bytes:
-;; 00000000: 23 79 85 00 00 01 00 02 : 00 00 00 00 04 69 70 76 #y...........ipv
-;; 00000010: 36 06 67 6F 6F 67 6C 65 : 03 63 6F 6D 00 00 1C 00 6.google.com....
-;; 00000020: 01 C0 0C 00 05 00 01 00 : 09 3A 80 00 09 04 69 70 .........:....ip
-;; 00000030: 76 36 01 6C C0 11 C0 2D : 00 1C 00 01 00 00 01 2C v6.l...-.......,
-;; 00000040: 00 10 20 01 48 60 80 0F : 00 00 00 00 00 00 00 00 .. .H`..........
-;; 00000050: 00 68 : .h
-;; 00000052:
-
-(pretty-print
- (packet->dns-message
- (bytes
- #x23 #x79 #x85 #x00 #x00 #x01 #x00 #x02 #x00 #x00 #x00 #x00 #x04 #x69 #x70 #x76
- #x36 #x06 #x67 #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #x1C #x00
- #x01 #xC0 #x0C #x00 #x05 #x00 #x01 #x00 #x09 #x3A #x80 #x00 #x09 #x04 #x69 #x70
- #x76 #x36 #x01 #x6C #xC0 #x11 #xC0 #x2D #x00 #x1C #x00 #x01 #x00 #x00 #x01 #x2C
- #x00 #x10 #x20 #x01 #x48 #x60 #x80 #x0F #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
- #x00 #x68)))
-
-(pretty-print
- (dns-message->packet
- (packet->dns-message
- (bytes
- #x23 #x79 #x85 #x00 #x00 #x01 #x00 #x02 #x00 #x00 #x00 #x00 #x04 #x69 #x70 #x76
- #x36 #x06 #x67 #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #x1C #x00
- #x01 #xC0 #x0C #x00 #x05 #x00 #x01 #x00 #x09 #x3A #x80 #x00 #x09 #x04 #x69 #x70
- #x76 #x36 #x01 #x6C #xC0 #x11 #xC0 #x2D #x00 #x1C #x00 #x01 #x00 #x00 #x01 #x2C
- #x00 #x10 #x20 #x01 #x48 #x60 #x80 #x0F #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
- #x00 #x68))))
-
-;; Thu Jun 30 15:12:45 2011 (4e0ccaad): UDP: asgard.ccs.neu.edu sent 486 bytes:
-;; 00000000: 13 CA 81 80 00 01 00 05 : 00 04 00 09 0C 5F 78 6D ............._xm
-;; 00000010: 70 70 2D 73 65 72 76 65 : 72 04 5F 74 63 70 06 67 pp-server._tcp.g
-;; 00000020: 6F 6F 67 6C 65 03 63 6F : 6D 00 00 21 00 01 C0 0C oogle.com..!....
-;; 00000030: 00 21 00 01 00 00 03 72 : 00 21 00 14 00 00 14 95 .!.....r.!......
-;; 00000040: 0C 78 6D 70 70 2D 73 65 : 72 76 65 72 34 01 6C 06 .xmpp-server4.l.
-;; 00000050: 67 6F 6F 67 6C 65 03 63 : 6F 6D 00 C0 0C 00 21 00 google.com....!.
-;; 00000060: 01 00 00 03 72 00 20 00 : 05 00 00 14 95 0B 78 6D ....r. .......xm
-;; 00000070: 70 70 2D 73 65 72 76 65 : 72 01 6C 06 67 6F 6F 67 pp-server.l.goog
-;; 00000080: 6C 65 03 63 6F 6D 00 C0 : 0C 00 21 00 01 00 00 03 le.com....!.....
-;; 00000090: 72 00 21 00 14 00 00 14 : 95 0C 78 6D 70 70 2D 73 r.!.......xmpp-s
-;; 000000A0: 65 72 76 65 72 31 01 6C : 06 67 6F 6F 67 6C 65 03 erver1.l.google.
-;; 000000B0: 63 6F 6D 00 C0 0C 00 21 : 00 01 00 00 03 72 00 21 com....!.....r.!
-;; 000000C0: 00 14 00 00 14 95 0C 78 : 6D 70 70 2D 73 65 72 76 .......xmpp-serv
-;; 000000D0: 65 72 32 01 6C 06 67 6F : 6F 67 6C 65 03 63 6F 6D er2.l.google.com
-;; 000000E0: 00 C0 0C 00 21 00 01 00 : 00 03 72 00 21 00 14 00 ....!.....r.!...
-;; 000000F0: 00 14 95 0C 78 6D 70 70 : 2D 73 65 72 76 65 72 33 ....xmpp-server3
-;; 00000100: 01 6C 06 67 6F 6F 67 6C : 65 03 63 6F 6D 00 C1 02 .l.google.com...
-;; 00000110: 00 02 00 01 00 01 54 24 : 00 06 03 6E 73 33 C1 02 ......T$...ns3..
-;; 00000120: C1 02 00 02 00 01 00 01 : 54 24 00 06 03 6E 73 34 ........T$...ns4
-;; 00000130: C1 02 C1 02 00 02 00 01 : 00 01 54 24 00 06 03 6E ..........T$...n
-;; 00000140: 73 32 C1 02 C1 02 00 02 : 00 01 00 01 54 24 00 06 s2..........T$..
-;; 00000150: 03 6E 73 31 C1 02 C0 6D : 00 01 00 01 00 00 01 1A .ns1...m........
-;; 00000160: 00 04 4A 7D 99 7D C0 99 : 00 01 00 01 00 00 06 F6 ..J}.}..........
-;; 00000170: 00 04 4A 7D 35 7D C0 C6 : 00 01 00 01 00 00 06 F6 ..J}5}..........
-;; 00000180: 00 04 4A 7D 2F 7D C0 F3 : 00 01 00 01 00 00 06 F6 ..J}/}..........
-;; 00000190: 00 04 4A 7D 2D 7D C0 40 : 00 01 00 01 00 00 06 F6 ..J}-}.@........
-;; 000001A0: 00 04 4A 7D 2D 7D C1 50 : 00 01 00 01 00 00 0A B1 ..J}-}.P........
-;; 000001B0: 00 04 D8 EF 20 0A C1 3E : 00 01 00 01 00 00 0A B1 .... ..>........
-;; 000001C0: 00 04 D8 EF 22 0A C1 1A : 00 01 00 01 00 00 0A B1 ...."...........
-;; 000001D0: 00 04 D8 EF 24 0A C1 2C : 00 01 00 01 00 00 0A B1 ....$..,........
-;; 000001E0: 00 04 D8 EF 26 0A : ....&.
-;; 000001E6:
-
-;; ANSWER SECTION:
-;;_xmpp-server._tcp.google.com. 900 IN SRV 5 0 5269 xmpp-server.l.google.com.
-;;_xmpp-server._tcp.google.com. 900 IN SRV 20 0 5269 xmpp-server1.l.google.com.
-;;_xmpp-server._tcp.google.com. 900 IN SRV 20 0 5269 xmpp-server2.l.google.com.
-;;_xmpp-server._tcp.google.com. 900 IN SRV 20 0 5269 xmpp-server3.l.google.com.
-;;_xmpp-server._tcp.google.com. 900 IN SRV 20 0 5269 xmpp-server4.l.google.com.
-
-(pretty-print
- (packet->dns-message
- (bytes
- #x13 #xCA #x81 #x80 #x00 #x01 #x00 #x05 #x00 #x04 #x00 #x09 #x0C #x5F #x78 #x6D
- #x70 #x70 #x2D #x73 #x65 #x72 #x76 #x65 #x72 #x04 #x5F #x74 #x63 #x70 #x06 #x67
- #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #x21 #x00 #x01 #xC0 #x0C
- #x00 #x21 #x00 #x01 #x00 #x00 #x03 #x72 #x00 #x21 #x00 #x14 #x00 #x00 #x14 #x95
- #x0C #x78 #x6D #x70 #x70 #x2D #x73 #x65 #x72 #x76 #x65 #x72 #x34 #x01 #x6C #x06
- #x67 #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #xC0 #x0C #x00 #x21 #x00
- #x01 #x00 #x00 #x03 #x72 #x00 #x20 #x00 #x05 #x00 #x00 #x14 #x95 #x0B #x78 #x6D
- #x70 #x70 #x2D #x73 #x65 #x72 #x76 #x65 #x72 #x01 #x6C #x06 #x67 #x6F #x6F #x67
- #x6C #x65 #x03 #x63 #x6F #x6D #x00 #xC0 #x0C #x00 #x21 #x00 #x01 #x00 #x00 #x03
- #x72 #x00 #x21 #x00 #x14 #x00 #x00 #x14 #x95 #x0C #x78 #x6D #x70 #x70 #x2D #x73
- #x65 #x72 #x76 #x65 #x72 #x31 #x01 #x6C #x06 #x67 #x6F #x6F #x67 #x6C #x65 #x03
- #x63 #x6F #x6D #x00 #xC0 #x0C #x00 #x21 #x00 #x01 #x00 #x00 #x03 #x72 #x00 #x21
- #x00 #x14 #x00 #x00 #x14 #x95 #x0C #x78 #x6D #x70 #x70 #x2D #x73 #x65 #x72 #x76
- #x65 #x72 #x32 #x01 #x6C #x06 #x67 #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D
- #x00 #xC0 #x0C #x00 #x21 #x00 #x01 #x00 #x00 #x03 #x72 #x00 #x21 #x00 #x14 #x00
- #x00 #x14 #x95 #x0C #x78 #x6D #x70 #x70 #x2D #x73 #x65 #x72 #x76 #x65 #x72 #x33
- #x01 #x6C #x06 #x67 #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #xC1 #x02
- #x00 #x02 #x00 #x01 #x00 #x01 #x54 #x24 #x00 #x06 #x03 #x6E #x73 #x33 #xC1 #x02
- #xC1 #x02 #x00 #x02 #x00 #x01 #x00 #x01 #x54 #x24 #x00 #x06 #x03 #x6E #x73 #x34
- #xC1 #x02 #xC1 #x02 #x00 #x02 #x00 #x01 #x00 #x01 #x54 #x24 #x00 #x06 #x03 #x6E
- #x73 #x32 #xC1 #x02 #xC1 #x02 #x00 #x02 #x00 #x01 #x00 #x01 #x54 #x24 #x00 #x06
- #x03 #x6E #x73 #x31 #xC1 #x02 #xC0 #x6D #x00 #x01 #x00 #x01 #x00 #x00 #x01 #x1A
- #x00 #x04 #x4A #x7D #x99 #x7D #xC0 #x99 #x00 #x01 #x00 #x01 #x00 #x00 #x06 #xF6
- #x00 #x04 #x4A #x7D #x35 #x7D #xC0 #xC6 #x00 #x01 #x00 #x01 #x00 #x00 #x06 #xF6
- #x00 #x04 #x4A #x7D #x2F #x7D #xC0 #xF3 #x00 #x01 #x00 #x01 #x00 #x00 #x06 #xF6
- #x00 #x04 #x4A #x7D #x2D #x7D #xC0 #x40 #x00 #x01 #x00 #x01 #x00 #x00 #x06 #xF6
- #x00 #x04 #x4A #x7D #x2D #x7D #xC1 #x50 #x00 #x01 #x00 #x01 #x00 #x00 #x0A #xB1
- #x00 #x04 #xD8 #xEF #x20 #x0A #xC1 #x3E #x00 #x01 #x00 #x01 #x00 #x00 #x0A #xB1
- #x00 #x04 #xD8 #xEF #x22 #x0A #xC1 #x1A #x00 #x01 #x00 #x01 #x00 #x00 #x0A #xB1
- #x00 #x04 #xD8 #xEF #x24 #x0A #xC1 #x2C #x00 #x01 #x00 #x01 #x00 #x00 #x0A #xB1
- #x00 #x04 #xD8 #xEF #x26 #x0A)))
diff --git a/prototype/test-mapping.rkt b/prototype/test-mapping.rkt
deleted file mode 100644
index 6f31f1e..0000000
--- a/prototype/test-mapping.rkt
+++ /dev/null
@@ -1,25 +0,0 @@
-#lang racket/base
-
-(require "mapping.rkt")
-(require rackunit)
-
-(define-mapping a->b b->a
- (a b))
-
-(check-equal? (a->b 'a) 'b)
-(check-equal? (b->a 'b) 'a)
-(check-exn exn:fail:contract? (lambda () (a->b 123)))
-(check-exn exn:fail:contract? (lambda () (a->b 'b)))
-(check-exn exn:fail:contract? (lambda () (b->a 123)))
-(check-exn exn:fail:contract? (lambda () (b->a 'a)))
-
-(define-mapping c->d d->c
- #:forward-default (lambda (x) 'default-d)
- #:backward-default (lambda (x) 'default-c)
- (c 123)
- (e 234))
-
-(check-equal? (c->d 'c) 123)
-(check-equal? (d->c 234) 'e)
-(check-equal? (c->d 'other) 'default-d)
-(check-equal? (d->c '235) 'default-c)
diff --git a/simple-udp-service.rkt b/simple-udp-service.rkt
deleted file mode 100644
index 09fe0e2..0000000
--- a/simple-udp-service.rkt
+++ /dev/null
@@ -1,97 +0,0 @@
-#lang racket/base
-
-;; Simple imperative UDP server harness.
-
-(require racket/match)
-(require racket/udp)
-(require (only-in srfi/1 append-reverse))
-(require racket-typed-matrix/support/dump-bytes)
-
-(provide (struct-out udp-packet)
- message-handlers
- start-udp-service)
-
-;; A UdpPacket is a (udp-packet Bytes String Uint16), and represents
-;; either a received UDP packet and the source of the packet, or a UDP
-;; packet ready to be sent along with the address to which it should
-;; be sent.
-(struct udp-packet (body host port) #:prefab)
-
-;; TODO: Should packet->message be permitted to examine (or possibly
-;; even transform!) the ServerState?
-
-;; A Handler is a Message ServerState -> ListOf ServerState.
-
-(define-syntax message-handlers
- (syntax-rules ()
- ((_ old-state-var (pattern body ...) ...)
- (list (cons (match-lambda (pattern #t) (_ #f))
- (lambda (v old-state-var)
- (match v
- (pattern body ...))))
- ...))))
-
-;; Starts a generic request/reply UDP server on the given port.
-(define (start-udp-service
- port-number ;; Uint16
- packet->message ;; UdpPacket -> Message
- ;;--------------------------------------------------
- outbound-message? ;; Message -> Boolean
- message->packet ;; Message -> UdpPacket
- ;;--------------------------------------------------
- message-handlers ;; ListOf Boolean, Handler>>
- default-handler ;; Handler
- initial-state ;; ServerState
- #:packet-size-limit
- [packet-size-limit 65536])
- (define s (udp-open-socket #f #f)) ;; the server socket
- (udp-bind! s #f port-number) ;; bind it to the port we were given
-
- (set! message-handlers ;; TEMPORARY while I figure out I/O
- (cons (cons outbound-message?
- (lambda (message state)
- (define p (message->packet message))
- (match-define (udp-packet body host port) p)
- (printf "<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~n~v~n" body)
- (dump-bytes! body (bytes-length body))
- (flush-output)
- (udp-send-to s host port body)
- (values '() state)))
- message-handlers))
-
- (define (dispatch-messages messages next-messages-rev old-state)
- (if (null? messages)
- (check-for-io (reverse next-messages-rev) old-state)
- (let ((message (car messages)))
- (define-values (new-messages new-state)
- (let search ((handlers message-handlers))
- (cond
- [(null? handlers) (default-handler message old-state)]
- [((caar handlers) message) ((cdar handlers) message old-state)]
- [else (search (cdr handlers))])))
- (dispatch-messages (cdr messages)
- (append-reverse new-messages next-messages-rev)
- new-state))))
-
- (define (check-for-io pending-messages old-state)
- (define buffer (make-bytes packet-size-limit))
- (define new-messages
- (sync (handle-evt (udp-receive!-evt s buffer)
- (match-lambda
- [(list packet-length source-hostname source-port)
- (define packet (subbytes buffer 0 packet-length))
- (printf ">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>~n~v~n" packet)
- (dump-bytes! buffer packet-length)
- (flush-output)
-
- (define packet-and-source
- (udp-packet packet source-hostname source-port))
- (define message (packet->message packet-and-source))
- (list message)]))
- (if (null? pending-messages)
- never-evt ;; Nothing waiting to be done, don't wake up until sth external arrives
- (handle-evt (system-idle-evt)
- (lambda (dummy) '())))))
- (dispatch-messages (append new-messages pending-messages) '() old-state))
-
- (check-for-io '() initial-state))
diff --git a/simplified-driver.rkt b/simplified-driver.rkt
deleted file mode 100644
index ca679f3..0000000
--- a/simplified-driver.rkt
+++ /dev/null
@@ -1,156 +0,0 @@
-#lang racket/base
-
-;; DNS server using simple-udp-service.rkt.
-
-(require racket/unit)
-(require racket/match)
-(require racket/set)
-(require racket/bool)
-(require racket-bitsyntax)
-(require "api.rkt")
-(require "codec.rkt")
-(require "zonedb.rkt")
-(require "resolver.rkt")
-(require "simple-udp-service.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.
-
-(struct bad-dns-packet (detail host port reason) #:prefab)
-(struct dns-request (message host port) #:prefab)
-(struct dns-reply (message host port) #: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)
-
- (start-udp-service
- port-number
- udp-packet->dns-message
- dns-reply?
- dns-reply->udp-packet
- (message-handlers old-state
- [(? bad-dns-packet? p)
- (pretty-print p)
- (values '() old-state)]
- [(? dns-request? r)
- (values (handle-request soa-rr zone r) old-state)])
- (lambda (unhandled state)
- (error 'dns-server "Unhandled packet ~v" unhandled))
- #f
- #:packet-size-limit 512))
-
-(define (udp-packet->dns-message packet)
- (match-define (udp-packet body host port) packet)
- (with-handlers ((exn:fail? (lambda (e) (bad-dns-packet body host port 'unparseable))))
- (define message (packet->dns-message body))
- (case (dns-message-direction message)
- ((request) (dns-request message host port))
- ((response) (bad-dns-packet message host port 'unexpected-dns-response)))))
-
-;; TODO: dns-reply->udp-packet may fail! The server may supply some
-;; value that isn't a proper DNSMessage. In that case we might like to
-;; not send a UDP packet, but instead send out a bad-dns-packet local
-;; message for logging etc. (Glossing over the issue of identifying
-;; the direction of the message for now.)
-;;
-;; Once we move to pluggable external-event-sources/relays this will
-;; go away: they'll be handlers like anything else, that just happen
-;; to have a side effect in some containing (or if not containing, at
-;; least *in-scope*) network.
-
-(define (dns-reply->udp-packet r)
- (match-define (dns-reply message host port) r)
- (udp-packet (dns-message->packet message) host port))
-
-(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-host request-port) 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 #f) 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 q) 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-host request-port))
- (first-only (dns-message-questions request-message))))
-
-(require "test-rrs.rkt")
-(start-server (test-port-number) test-soa-rr test-rrs)
diff --git a/stress.rkt b/stress.rkt
deleted file mode 100644
index 22dd9c4..0000000
--- a/stress.rkt
+++ /dev/null
@@ -1,75 +0,0 @@
-#lang racket/base
-
-;; Simple stress-tester and performance measurement tool for DNS
-;; implementations.
-
-(require racket/udp)
-(require racket/set)
-(require racket-bitsyntax)
-(require "api.rkt")
-(require "codec.rkt")
-(require "test-rrs.rkt")
-
-(require racket/pretty)
-
-(define latencies (make-vector 200 0))
-(define latency-pos 0)
-(define (record-latency-ms! ms)
- (vector-set! latencies latency-pos ms)
- (set! latency-pos (modulo (+ latency-pos 1) (vector-length latencies)))
- (when (zero? latency-pos)
- (for-each display (list ";; Mean latency "(/ (for/fold
- ((sum 0))
- ((i latencies))
- (+ sum i))
- (vector-length latencies))"ms\n"))))
-
-(define (stress hostname port-number count rate)
- (define s (udp-open-socket #f #f))
-
- (define start-time (current-inexact-milliseconds))
- (let loop ((remaining count))
- (define request-message (dns-message (random 65536)
- 'request
- 'query
- 'non-authoritative
- 'not-truncated
- 'recursion-desired
- 'no-recursion-available
- 'no-error
- (list (question (domain '(#"www" #"google" #"com"))
- 'a
- 'in
- #f))
- '()
- '()
- '()))
-
- (define now (current-inexact-milliseconds))
- (define sent-count (- count remaining))
- (define delta-ms (- now start-time))
- (define current-rate (/ sent-count (/ delta-ms 1000.0)))
-
- (when (> current-rate rate)
- (define target-delta-sec (/ sent-count rate))
- (sleep (- target-delta-sec (/ delta-ms 1000))))
-
- (when (zero? (modulo sent-count rate))
- (for-each display (list ";; Sent "sent-count" at target "rate"Hz, actual "
- current-rate"Hz, in "delta-ms"ms\n")))
-
- (when (positive? remaining)
- (define sent-time (current-inexact-milliseconds))
- (udp-send-to s hostname port-number (dns-message->packet request-message))
-
- (define buffer (make-bytes 512))
- (define-values (packet-length source-hostname source-port)
- (udp-receive! s buffer))
- (define received-time (current-inexact-milliseconds))
- (define reply (packet->dns-message (sub-bit-string buffer 0 (* 8 packet-length))))
-
- ;;(pretty-print reply)
- (record-latency-ms! (- received-time sent-time))
- (loop (- remaining 1)))))
-
-(stress "localhost" (test-port-number) 100000 500)