From 8ad9dd34a2bb001ffe6b53816e593e86897c0184 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 31 Oct 2012 16:48:43 -0400 Subject: [PATCH] First steps of port to typed-matrix kernel. --- api.rkt | 2 +- codec.rkt | 2 +- driver.rkt | 35 +++++++++++------------ os2-dns.rkt | 63 ---------------------------------------- proxy.rkt | 2 +- simple-udp-service.rkt | 2 +- simplified-driver.rkt | 2 +- stress.rkt | 2 +- tk-dns.rkt | 65 ++++++++++++++++++++++++++++++++++++++++++ zonedb.rkt | 2 +- 10 files changed, 88 insertions(+), 89 deletions(-) delete mode 100644 os2-dns.rkt create mode 100644 tk-dns.rkt diff --git a/api.rkt b/api.rkt index fe8a34b..4eb972a 100644 --- a/api.rkt +++ b/api.rkt @@ -54,7 +54,7 @@ #:transparent #:property prop:equal+hash (list domain=? domain-hash-1/2 domain-hash-1/2)) -(require "../racket-matrix/struct-map.rkt") +(require racket-typed-matrix/struct-map) (install-struct-mapper! struct:domain (lambda (f seed x) (let-values (((labels seed) (f (domain-labels x) seed))) diff --git a/codec.rkt b/codec.rkt index 40894da..e4ea2d1 100644 --- a/codec.rkt +++ b/codec.rkt @@ -18,7 +18,7 @@ (require "mapping.rkt") (require racket/match) -(require "../racket-bitsyntax/main.rkt") +(require racket-bitsyntax) ;; An Opcode is a Symbol or a Number, one of the possibilities given ;; in the following define-mapping. It represents a DNS message diff --git a/driver.rkt b/driver.rkt index 5fb97ce..265b784 100644 --- a/driver.rkt +++ b/driver.rkt @@ -5,14 +5,15 @@ (require racket/match) (require racket/set) (require racket/bool) -(require "../racket-bitsyntax/main.rkt") +(require racket-bitsyntax) (require "api.rkt") (require "codec.rkt") (require "zonedb.rkt") (require "resolver.rkt") -(require "../racket-matrix/os2.rkt") -(require "../racket-matrix/os2-udp.rkt") -(require "os2-dns.rkt") +(require racket-typed-matrix/sugar-untyped) +(require racket-typed-matrix/support/spy) +(require racket-typed-matrix/drivers/udp-untyped) +(require "tk-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 @@ -39,21 +40,17 @@ (display ";; Ready.\n") - (ground-vm - (transition 'no-state - ;; (spawn udp-spy #:debug-name 'udp-spy) - (spawn udp-driver #:debug-name 'udp-driver) - (spawn (nested-vm #:debug-name 'dns-vm - (transition 'no-state - (spawn dns-spy #:debug-name 'dns-spy) - (spawn (dns-read-driver local-addr) #:debug-name 'dns-read-driver) - (spawn (dns-write-driver local-addr) #:debug-name 'dns-write-driver) - (role (topic-subscriber (bad-dns-packet (wild) (wild) (wild) (wild))) - [p (begin (log-error (pretty-format p)) - '())]) - (role (topic-subscriber (dns-request (wild) (wild) (wild))) - [r (map send-message (handle-request soa-rr zone r))]))) - #:debug-name 'dns-vm)))) + (ground-vm (udp-driver) + (generic-spy 'UDP) + (nested-vm + (dns-spy) + (spawn #:child (dns-read-driver local-addr)) + (spawn #:child (dns-write-driver local-addr)) + (endpoint #:subscriber (bad-dns-packet (wild) (wild) (wild) (wild)) + [p (begin (log-error (pretty-format p)) + '())]) + (endpoint #:subscriber (dns-request (wild) (wild) (wild)) + [r (map send-message (handle-request soa-rr zone r))])))) (define (handle-request soa-rr zone request) (match-define (dns-request request-message request-source request-sink) request) diff --git a/os2-dns.rkt b/os2-dns.rkt deleted file mode 100644 index a92a204..0000000 --- a/os2-dns.rkt +++ /dev/null @@ -1,63 +0,0 @@ -#lang racket/base -;; DNS drivers using os2.rkt and os2-udp.rkt. - -(require racket/set) -(require racket/match) -(require "codec.rkt") -(require "../racket-matrix/os2.rkt") -(require "../racket-matrix/os2-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) - (transition 'no-state - (at-meta-level - (role (topic-subscriber (udp-packet (wild) s (wild))) - [(udp-packet source (== s) #"") - (log-info "Debug dump packet received") - (send-message `(debug-dump))] - [(udp-packet source (== s) body) - (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))))) - (at-meta-level - (send-message (udp-packet s sink (dns-message->packet message)))))) - (transition 'no-state - (role (set (topic-subscriber (dns-request (wild) s (wild))) - (topic-subscriber (dns-reply (wild) s (wild)))) - [(dns-request message (== s) sink) (translate message sink)] - [(dns-reply message (== s) sink) (translate message sink)]))) - -(define dns-spy - (transition 'none - (role (topic-subscriber (wild) #:monitor? #t) - [(dns-request message source sink) - (log-info (format "DNS: ~v asks ~v ~v~n : ~v" - source sink (dns-message-id message) - (dns-message-questions message))) - (void)] - [(dns-reply message source sink) - (log-info (format "DNS: ~v answers ~v~n : ~v" - source sink - message)) - (void)] - [x - (log-info (format "DNS: ~v" x)) - (void)]))) diff --git a/proxy.rkt b/proxy.rkt index 844df25..edf843d 100644 --- a/proxy.rkt +++ b/proxy.rkt @@ -5,7 +5,7 @@ (require racket/match) (require racket/set) (require racket/bool) -(require "../racket-bitsyntax/main.rkt") +(require racket-bitsyntax) (require "api.rkt") (require "codec.rkt") (require "zonedb.rkt") diff --git a/simple-udp-service.rkt b/simple-udp-service.rkt index f8bb5f3..09fe0e2 100644 --- a/simple-udp-service.rkt +++ b/simple-udp-service.rkt @@ -5,7 +5,7 @@ (require racket/match) (require racket/udp) (require (only-in srfi/1 append-reverse)) -(require "../racket-matrix/dump-bytes.rkt") +(require racket-typed-matrix/support/dump-bytes) (provide (struct-out udp-packet) message-handlers diff --git a/simplified-driver.rkt b/simplified-driver.rkt index 145b45b..ca679f3 100644 --- a/simplified-driver.rkt +++ b/simplified-driver.rkt @@ -6,7 +6,7 @@ (require racket/match) (require racket/set) (require racket/bool) -(require "../racket-bitsyntax/main.rkt") +(require racket-bitsyntax) (require "api.rkt") (require "codec.rkt") (require "zonedb.rkt") diff --git a/stress.rkt b/stress.rkt index b4a0327..22dd9c4 100644 --- a/stress.rkt +++ b/stress.rkt @@ -5,7 +5,7 @@ (require racket/udp) (require racket/set) -(require "../racket-bitsyntax/main.rkt") +(require racket-bitsyntax) (require "api.rkt") (require "codec.rkt") (require "test-rrs.rkt") diff --git a/tk-dns.rkt b/tk-dns.rkt new file mode 100644 index 0000000..885b941 --- /dev/null +++ b/tk-dns.rkt @@ -0,0 +1,65 @@ +#lang racket/base +;; DNS drivers using racket-typed-matrix. + +(require racket/set) +(require racket/match) +(require "codec.rkt") +(require racket-typed-matrix/sugar-untyped) +(require racket-typed-matrix/drivers/udp-untyped) + +(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) + (transition 'no-state + (at-meta-level + (endpoint #:subscriber (udp-packet-pattern (wild) s (wild)) + [(udp-packet source (== s) #"") + (begin (log-info "Debug dump packet received") + (send-message `(debug-dump)))] + [(udp-packet source (== s) body) + (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))))) + (at-meta-level + (send-message (udp-packet s sink (dns-message->packet message)))))) + (transition 'no-state + (endpoint #:subscriber (dns-request (wild) s (wild)) + [(dns-request message (== s) sink) (translate message sink)]) + (endpoint #:subscriber (dns-reply (wild) s (wild)) + [(dns-reply message (== s) sink) (translate message sink)]))) + +(define (dns-spy) + (spawn #:child + (transition 'none + (endpoint #:subscriber (wild) #:observer + [(dns-request message source sink) + (begin (log-info (format "DNS: ~v asks ~v ~v~n : ~v" + source sink (dns-message-id message) + (dns-message-questions message))) + (void))] + [(dns-reply message source sink) + (begin (log-info (format "DNS: ~v answers ~v~n : ~v" + source sink + message)) + (void))] + [x + (begin (log-info (format "DNS: ~v" x)) + (void))])))) diff --git a/zonedb.rkt b/zonedb.rkt index be98d43..ab9c1a1 100644 --- a/zonedb.rkt +++ b/zonedb.rkt @@ -6,7 +6,7 @@ (require racket/match) (require "api.rkt") (require "codec.rkt") -(require "../racket-bitsyntax/main.rkt") +(require racket-bitsyntax) (provide zone-ref zone-includes-name?