diff --git a/simple-udp-service.rkt b/simple-udp-service.rkt index be04f71..55ac8e9 100644 --- a/simple-udp-service.rkt +++ b/simple-udp-service.rkt @@ -7,6 +7,7 @@ (require "dump-bytes.rkt") (provide (struct-out udp-packet) + event-handlers start-udp-service) ;; A UdpPacket is a (udp-packet Bytes String Uint16), and represents @@ -18,42 +19,64 @@ ;; TODO: Should packet-classifier be permitted to examine (or possibly ;; even transform!) the ServerState? +;; A Handler is a ClassifiedPacket ServerState -> ListOf ServerState. + +(define-syntax event-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-classifier ;; UdpPacket -> Maybe - bad-packet-handler ;; UdpPacket ServerState -> ListOf ServerState - good-packet-handler ;; ClassifiedPacket ServerState -> ListOf ServerState - packet-encoder ;; ClassifiedPacket -> UdpPacket + packet-classifier ;; UdpPacket -> ClassifiedPacket + event-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 - (define (read-and-process-request old-state) + (set! event-handlers ;; TEMPORARY while I figure out I/O + (cons (cons udp-packet? + (lambda (p state) + (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))) + event-handlers)) + + (define (dispatch-events events old-state) + (if (null? events) + (read-and-dispatch old-state) + (let ((classified-packet (car events))) + (define-values (new-events new-state) + (let search ((handlers event-handlers)) + (cond + [(null? handlers) (default-handler classified-packet old-state)] + [((caar handlers) classified-packet) ((cdar handlers) classified-packet old-state)] + [else (search (cdr handlers))]))) + (dispatch-events (append (cdr events) new-events) new-state)))) + + (define (read-and-dispatch old-state) (define buffer (make-bytes packet-size-limit)) (define-values (packet-length source-hostname source-port) (udp-receive! s buffer)) (define packet (subbytes buffer 0 packet-length)) - (printf "----------------------------------------~n~v~n" packet) + (printf ">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>~n~v~n" packet) (dump-bytes! buffer packet-length) (flush-output) (define packet-and-source (udp-packet packet source-hostname source-port)) (define classified-packet (packet-classifier packet-and-source)) + (dispatch-events (list classified-packet) old-state)) - (define-values (reply-packets new-state) - (cond - ((eq? classified-packet #f) (bad-packet-handler packet-and-source old-state)) - (else (good-packet-handler classified-packet old-state)))) - - (for-each (lambda (p) - (match-define (udp-packet body host port) (packet-encoder p)) - (udp-send-to s host port body)) - reply-packets) - new-state) - - (let service-loop ((state initial-state)) - (service-loop (read-and-process-request state)))) + (read-and-dispatch initial-state)) diff --git a/simplified-driver.rkt b/simplified-driver.rkt index d8c9b31..66f5870 100644 --- a/simplified-driver.rkt +++ b/simplified-driver.rkt @@ -56,6 +56,10 @@ (define (listset-union xs1 xs2) (set->list (set-union (list->set xs1) (list->set xs2)))) +(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 @@ -69,28 +73,29 @@ (start-udp-service port-number classify-dns-packet - (lambda (packet old-state) (values (log-error packet) old-state)) - (lambda (message old-state) (values (handle-request soa-rr zone message) old-state)) - encode-dns-packet + (event-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)] + [(dns-reply message host port) + (values (list (udp-packet (dns-message->packet message) host port)) old-state)]) + (lambda (unhandled state) + (error 'dns-server "Unhandled packet ~v" unhandled)) #f #:packet-size-limit 512)) (define (classify-dns-packet packet) (match-define (udp-packet body host port) packet) - (with-handlers ((exn? (lambda (e) #f))) - (list (packet->dns-message body) host port))) + (with-handlers ((exn? (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))))) -(define (encode-dns-packet data) - (match-define (list message host port) data) - (udp-packet (dns-message->packet message) host port)) - -;; UdpPacket -> ListOf -(define (log-error packet) - (pretty-print `(bad-packet-received ,packet)) - (list)) - -(define (handle-request soa-rr zone request-data) - (match-define (list request-message request-host request-port) request-data) +(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) @@ -164,7 +169,7 @@ ;; TODO: check opcode and direction in request ;; TODO: think again about multiple questions in one packet (map (lambda (q) - (list (answer-question q make-reply) request-host request-port)) + (dns-reply (answer-question q make-reply) request-host request-port)) (dns-message-questions request-message))) (start-server 5555