2011-12-14 19:21:19 +00:00
|
|
|
#lang racket/base
|
|
|
|
|
|
|
|
;; Simple imperative UDP server harness.
|
|
|
|
|
2011-12-15 17:22:59 +00:00
|
|
|
(require racket/match)
|
2011-12-14 19:21:19 +00:00
|
|
|
(require racket/udp)
|
2011-12-15 21:21:07 +00:00
|
|
|
(require (only-in srfi/1 append-reverse))
|
2011-12-14 19:21:19 +00:00
|
|
|
(require "dump-bytes.rkt")
|
|
|
|
|
|
|
|
(provide (struct-out udp-packet)
|
2011-12-15 18:02:10 +00:00
|
|
|
event-handlers
|
2011-12-14 19:21:19 +00:00
|
|
|
start-udp-service)
|
|
|
|
|
|
|
|
;; A UdpPacket is a (udp-packet Bytes String Uint16), and represents
|
|
|
|
;; either a received UDP packet and the source of the packet, or a UDP
|
|
|
|
;; packet ready to be sent along with the address to which it should
|
|
|
|
;; be sent.
|
2011-12-15 18:00:37 +00:00
|
|
|
(struct udp-packet (body host port) #:prefab)
|
2011-12-14 19:21:19 +00:00
|
|
|
|
2011-12-16 16:30:18 +00:00
|
|
|
;; TODO: Should parse-packet be permitted to examine (or possibly
|
2011-12-15 17:18:14 +00:00
|
|
|
;; even transform!) the ServerState?
|
|
|
|
|
2011-12-15 18:02:10 +00:00
|
|
|
;; 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 ...))))
|
|
|
|
...))))
|
|
|
|
|
2011-12-14 19:21:19 +00:00
|
|
|
;; Starts a generic request/reply UDP server on the given port.
|
|
|
|
(define (start-udp-service
|
|
|
|
port-number ;; Uint16
|
2011-12-16 16:30:18 +00:00
|
|
|
parse-packet ;; UdpPacket -> ClassifiedPacket
|
|
|
|
;--------------------------------------------------
|
|
|
|
unparse-packet? ;; ClassifiedPacket -> Boolean
|
|
|
|
unparse-packet ;; ClassifiedPacket -> UdpPacket
|
|
|
|
;--------------------------------------------------
|
2011-12-15 18:02:10 +00:00
|
|
|
event-handlers ;; ListOf<Pair<ClassifiedPacket -> Boolean, Handler>>
|
|
|
|
default-handler ;; Handler
|
2011-12-14 19:21:19 +00:00
|
|
|
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
|
|
|
|
|
2011-12-15 18:02:10 +00:00
|
|
|
(set! event-handlers ;; TEMPORARY while I figure out I/O
|
2011-12-16 16:30:18 +00:00
|
|
|
(cons (cons unparse-packet?
|
|
|
|
(lambda (event state)
|
|
|
|
(define p (unparse-packet event))
|
2011-12-15 18:02:10 +00:00
|
|
|
(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))
|
|
|
|
|
2011-12-15 21:21:07 +00:00
|
|
|
(define (dispatch-events events next-events-rev old-state)
|
2011-12-15 18:02:10 +00:00
|
|
|
(if (null? events)
|
2011-12-15 21:21:07 +00:00
|
|
|
(check-for-io (reverse next-events-rev) old-state)
|
2011-12-16 16:30:18 +00:00
|
|
|
(let ((event (car events)))
|
2011-12-15 18:02:10 +00:00
|
|
|
(define-values (new-events new-state)
|
|
|
|
(let search ((handlers event-handlers))
|
|
|
|
(cond
|
2011-12-16 16:30:18 +00:00
|
|
|
[(null? handlers) (default-handler event old-state)]
|
|
|
|
[((caar handlers) event) ((cdar handlers) event old-state)]
|
2011-12-15 18:02:10 +00:00
|
|
|
[else (search (cdr handlers))])))
|
2011-12-15 21:21:07 +00:00
|
|
|
(dispatch-events (cdr events)
|
|
|
|
(append-reverse new-events next-events-rev)
|
|
|
|
new-state))))
|
2011-12-15 18:02:10 +00:00
|
|
|
|
2011-12-15 21:21:07 +00:00
|
|
|
(define (check-for-io pending-events old-state)
|
2011-12-14 19:21:19 +00:00
|
|
|
(define buffer (make-bytes packet-size-limit))
|
2011-12-15 21:21:07 +00:00
|
|
|
(define new-events
|
|
|
|
(sync (handle-evt (udp-receive!-evt s buffer)
|
|
|
|
(match-lambda
|
|
|
|
[(list packet-length source-hostname source-port)
|
|
|
|
(define packet (subbytes buffer 0 packet-length))
|
|
|
|
(printf ">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>~n~v~n" packet)
|
|
|
|
(dump-bytes! buffer packet-length)
|
|
|
|
(flush-output)
|
2011-12-14 19:21:19 +00:00
|
|
|
|
2011-12-15 21:21:07 +00:00
|
|
|
(define packet-and-source
|
|
|
|
(udp-packet packet source-hostname source-port))
|
2011-12-16 16:30:18 +00:00
|
|
|
(define event (parse-packet packet-and-source))
|
|
|
|
(list event)]))
|
2011-12-15 21:21:07 +00:00
|
|
|
(if (null? pending-events)
|
|
|
|
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))
|
2011-12-14 19:21:19 +00:00
|
|
|
|
2011-12-15 21:21:07 +00:00
|
|
|
(check-for-io '() initial-state))
|