racket-dns-2012/simple-udp-service.rkt

#lang racket/base

;; Simple imperative UDP server harness.

(require racket/match)
(require racket/udp)
(require (only-in srfi/1 append-reverse))
(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
;; 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.
(struct udp-packet (body host port) #:prefab)

;; TODO: Should parse-packet be permitted to examine (or possibly
;; even transform!) the ServerState?

;; A Handler is a Message ServerState -> ListOf<Message> 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
	 parse-packet ;; UdpPacket -> Message
	 ;--------------------------------------------------
	 unparse-packet? ;; Message -> Boolean
	 unparse-packet ;; Message -> UdpPacket
	 ;--------------------------------------------------
	 event-handlers ;; ListOf<Pair<Message -> 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

  (set! event-handlers ;; TEMPORARY while I figure out I/O
	(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))
		      (flush-output)
		      (udp-send-to s host port body)
		      (values '() state)))
	      event-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))
	      (cond
	       [(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)
			   new-state))))

  (define (check-for-io pending-events old-state)
    (define buffer (make-bytes packet-size-limit))
    (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)

			  (define packet-and-source
			    (udp-packet packet source-hostname source-port))
			  (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)
			    (lambda (dummy) '())))))
    (dispatch-events (append new-events pending-events) '() old-state))

  (check-for-io '() initial-state))