Add unparsing of packets, symmetrically with what used to be called classification.
This commit is contained in:
parent
5181e0fce0
commit
94486f4dba
|
@ -17,7 +17,7 @@
|
|||
;; be sent.
|
||||
(struct udp-packet (body host port) #:prefab)
|
||||
|
||||
;; TODO: Should packet-classifier be permitted to examine (or possibly
|
||||
;; TODO: Should parse-packet be permitted to examine (or possibly
|
||||
;; even transform!) the ServerState?
|
||||
|
||||
;; A Handler is a ClassifiedPacket ServerState -> ListOf<ClassifiedPacket> ServerState.
|
||||
|
@ -34,7 +34,11 @@
|
|||
;; Starts a generic request/reply UDP server on the given port.
|
||||
(define (start-udp-service
|
||||
port-number ;; Uint16
|
||||
packet-classifier ;; UdpPacket -> ClassifiedPacket
|
||||
parse-packet ;; UdpPacket -> ClassifiedPacket
|
||||
;--------------------------------------------------
|
||||
unparse-packet? ;; ClassifiedPacket -> Boolean
|
||||
unparse-packet ;; ClassifiedPacket -> UdpPacket
|
||||
;--------------------------------------------------
|
||||
event-handlers ;; ListOf<Pair<ClassifiedPacket -> Boolean, Handler>>
|
||||
default-handler ;; Handler
|
||||
initial-state ;; ServerState
|
||||
|
@ -44,8 +48,9 @@
|
|||
(udp-bind! s #f port-number) ;; bind it to the port we were given
|
||||
|
||||
(set! event-handlers ;; TEMPORARY while I figure out I/O
|
||||
(cons (cons udp-packet?
|
||||
(lambda (p state)
|
||||
(cons (cons unparse-packet?
|
||||
(lambda (event state)
|
||||
(define p (unparse-packet event))
|
||||
(match-define (udp-packet body host port) p)
|
||||
(printf "<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~n~v~n" body)
|
||||
(dump-bytes! body (bytes-length body))
|
||||
|
@ -57,12 +62,12 @@
|
|||
(define (dispatch-events events next-events-rev old-state)
|
||||
(if (null? events)
|
||||
(check-for-io (reverse next-events-rev) old-state)
|
||||
(let ((classified-packet (car events)))
|
||||
(let ((event (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)]
|
||||
[(null? handlers) (default-handler event old-state)]
|
||||
[((caar handlers) event) ((cdar handlers) event old-state)]
|
||||
[else (search (cdr handlers))])))
|
||||
(dispatch-events (cdr events)
|
||||
(append-reverse new-events next-events-rev)
|
||||
|
@ -81,8 +86,8 @@
|
|||
|
||||
(define packet-and-source
|
||||
(udp-packet packet source-hostname source-port))
|
||||
(define classified-packet (packet-classifier packet-and-source))
|
||||
(list classified-packet)]))
|
||||
(define event (parse-packet packet-and-source))
|
||||
(list event)]))
|
||||
(if (null? pending-events)
|
||||
never-evt ;; Nothing waiting to be done, don't wake up until sth external arrives
|
||||
(handle-evt (system-idle-evt)
|
||||
|
|
|
@ -72,21 +72,21 @@
|
|||
|
||||
(start-udp-service
|
||||
port-number
|
||||
classify-dns-packet
|
||||
parse-dns-event
|
||||
dns-reply?
|
||||
unparse-dns-event
|
||||
(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)])
|
||||
(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 (classify-dns-packet packet)
|
||||
(define (parse-dns-event packet)
|
||||
(match-define (udp-packet body host port) packet)
|
||||
(with-handlers ((exn? (lambda (e) (bad-dns-packet body host port 'unparseable))))
|
||||
(define message (packet->dns-message body))
|
||||
|
@ -94,6 +94,10 @@
|
|||
((request) (dns-request message host port))
|
||||
((response) (bad-dns-packet message host port 'unexpected-dns-response)))))
|
||||
|
||||
(define (unparse-dns-event event)
|
||||
(match-define (dns-reply message host port) event)
|
||||
(udp-packet (dns-message->packet message) host port))
|
||||
|
||||
(define (handle-request soa-rr zone request)
|
||||
(match-define (dns-request request-message request-host request-port) request)
|
||||
|
||||
|
|
Loading…
Reference in New Issue