#lang racket/base

;; Simple imperative UDP server harness.

(require racket/match)
(require racket/udp)
(require (only-in srfi/1 append-reverse))
(require "../racket-matrix/dump-bytes.rkt")

(provide (struct-out udp-packet)
	 message-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 packet->message be permitted to examine (or possibly
;; even transform!) the ServerState?

;; A Handler is a Message ServerState -> ListOf<Message> ServerState.

(define-syntax message-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->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])
  (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! 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)))
	      message-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 message old-state)]
	       [((caar handlers) message) ((cdar handlers) message old-state)]
	       [else (search (cdr handlers))])))
	  (dispatch-messages (cdr messages)
			     (append-reverse new-messages next-messages-rev)
			     new-state))))

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

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