Generalise event handlers: extensible event types, fixed set of handlers.

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<ClassifiedPacket> 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<ClassifiedPacket>
-	 bad-packet-handler ;; UdpPacket ServerState -> ListOf<ClassifiedPacket> ServerState
-	 good-packet-handler ;; ClassifiedPacket ServerState -> ListOf<ClassifiedPacket> ServerState
-	 packet-encoder ;; ClassifiedPacket -> UdpPacket
+	 packet-classifier ;; UdpPacket -> ClassifiedPacket
+	 event-handlers ;; ListOf<Pair<ClassifiedPacket -> 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))

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<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
@@ -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<UdpPacket>
-(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