More consistent naming (event -> message, etc)
This commit is contained in:
parent
97ca27fb16
commit
7f44278cf6
|
@ -8,7 +8,7 @@
|
|||
(require "dump-bytes.rkt")
|
||||
|
||||
(provide (struct-out udp-packet)
|
||||
event-handlers
|
||||
message-handlers
|
||||
start-udp-service)
|
||||
|
||||
;; A UdpPacket is a (udp-packet Bytes String Uint16), and represents
|
||||
|
@ -17,12 +17,12 @@
|
|||
;; be sent.
|
||||
(struct udp-packet (body host port) #:prefab)
|
||||
|
||||
;; TODO: Should parse-packet be permitted to examine (or possibly
|
||||
;; TODO: Should packet->message be permitted to examine (or possibly
|
||||
;; even transform!) the ServerState?
|
||||
|
||||
;; A Handler is a Message ServerState -> ListOf<Message> ServerState.
|
||||
|
||||
(define-syntax event-handlers
|
||||
(define-syntax message-handlers
|
||||
(syntax-rules ()
|
||||
((_ old-state-var (pattern body ...) ...)
|
||||
(list (cons (match-lambda (pattern #t) (_ #f))
|
||||
|
@ -34,48 +34,48 @@
|
|||
;; Starts a generic request/reply UDP server on the given port.
|
||||
(define (start-udp-service
|
||||
port-number ;; Uint16
|
||||
parse-packet ;; UdpPacket -> Message
|
||||
;--------------------------------------------------
|
||||
unparse-packet? ;; Message -> Boolean
|
||||
unparse-packet ;; Message -> UdpPacket
|
||||
;--------------------------------------------------
|
||||
event-handlers ;; ListOf<Pair<Message -> Boolean, Handler>>
|
||||
packet->message ;; UdpPacket -> Message
|
||||
;;--------------------------------------------------
|
||||
outbound-message? ;; Message -> Boolean
|
||||
message->packet ;; Message -> UdpPacket
|
||||
;;--------------------------------------------------
|
||||
message-handlers ;; ListOf<Pair<Message -> Boolean, Handler>>
|
||||
default-handler ;; Handler
|
||||
initial-state ;; ServerState
|
||||
#:packet-size-limit
|
||||
[packet-size-limit 65536])
|
||||
[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! event-handlers ;; TEMPORARY while I figure out I/O
|
||||
(cons (cons unparse-packet?
|
||||
(lambda (event state)
|
||||
(define p (unparse-packet event))
|
||||
(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)))
|
||||
event-handlers))
|
||||
message-handlers))
|
||||
|
||||
(define (dispatch-events events next-events-rev old-state)
|
||||
(if (null? events)
|
||||
(check-for-io (reverse next-events-rev) old-state)
|
||||
(let ((event (car events)))
|
||||
(define-values (new-events new-state)
|
||||
(let search ((handlers event-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 event old-state)]
|
||||
[((caar handlers) event) ((cdar handlers) event old-state)]
|
||||
[(null? handlers) (default-handler message old-state)]
|
||||
[((caar handlers) message) ((cdar handlers) message old-state)]
|
||||
[else (search (cdr handlers))])))
|
||||
(dispatch-events (cdr events)
|
||||
(append-reverse new-events next-events-rev)
|
||||
new-state))))
|
||||
(dispatch-messages (cdr messages)
|
||||
(append-reverse new-messages next-messages-rev)
|
||||
new-state))))
|
||||
|
||||
(define (check-for-io pending-events old-state)
|
||||
(define (check-for-io pending-messages old-state)
|
||||
(define buffer (make-bytes packet-size-limit))
|
||||
(define new-events
|
||||
(define new-messages
|
||||
(sync (handle-evt (udp-receive!-evt s buffer)
|
||||
(match-lambda
|
||||
[(list packet-length source-hostname source-port)
|
||||
|
@ -86,12 +86,12 @@
|
|||
|
||||
(define packet-and-source
|
||||
(udp-packet packet source-hostname source-port))
|
||||
(define event (parse-packet packet-and-source))
|
||||
(list event)]))
|
||||
(if (null? pending-events)
|
||||
(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-events (append new-events pending-events) '() old-state))
|
||||
(dispatch-messages (append new-messages pending-messages) '() old-state))
|
||||
|
||||
(check-for-io '() initial-state))
|
||||
|
|
|
@ -72,21 +72,21 @@
|
|||
|
||||
(start-udp-service
|
||||
port-number
|
||||
parse-dns-event
|
||||
udp-packet->dns-message
|
||||
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->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 (parse-dns-event packet)
|
||||
(define (udp-packet->dns-message 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,8 +94,8 @@
|
|||
((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)
|
||||
(define (dns-reply->udp-packet r)
|
||||
(match-define (dns-reply message host port) r)
|
||||
(udp-packet (dns-message->packet message) host port))
|
||||
|
||||
(define (handle-request soa-rr zone request)
|
||||
|
|
Loading…
Reference in New Issue