racket-dns-2012/os-userland-example.rkt

#lang racket/base

(require racket/port)
(require "os-userland.rkt")

(define (rpc req)
  (define reply-addr (gensym 'reply-addr)) ;;; !!! TODO: remove side-effect?
  (send `(request ,reply-addr ,req))
  (wait (message-handlers
	 [`(reply ,(? (lambda (v) (eq? v reply-addr))) ,v)
	  v])))

(define-syntax rpc-service
  (syntax-rules ()
    [(_ pattern body ...)
     (let loop ()
       (wait (message-handlers
	      [`(request ,reply-addr ,pattern)
	       (spawn (lambda ()
			(define answer (let () body ...))
			(send `(reply ,reply-addr ,answer))))
	       (loop)])))]))

(define (display-driver)
  (define message (wait (message-handlers [`(display ,message) message])))
  (meta-send (lambda ()
	       (display message)
	       (flush-output)))
  (display-driver))

(define (read-line-driver)
  (rpc-service `read-line
	       (wait (message-handlers)
		     (meta-message-handlers
		      [((read-line-evt (current-input-port) 'any) => line)
		       line]))))

(define (time-evt msecs)
  (wrap-evt (alarm-evt msecs) (lambda (_) (current-inexact-milliseconds))))

(define (wait-until-time msecs)
  (wait (message-handlers)
	(meta-message-handlers
	 [((time-evt msecs) => current-time)
	  current-time])))

(define (current-time)
  (wait-until-time 0))

(define (sleep-driver)
  (rpc-service `(sleep ,msecs)
	       (send `(display (Sleeping ,msecs)))
	       (define now (wait-until-time (+ (current-time) msecs)))
	       (send `(display "\n"))
	       now))

(define (main)
  (spawn display-driver)
  (spawn read-line-driver)
  (spawn sleep-driver)
  (spawn (lambda ()
	   (send `(display "HI\n"))
	   (rpc `(sleep 1000))
	   (send `(display "THERE\n"))))
  (poll) ;; Wait for drivers to become ready (!)
	 ;; The Right Way to do this is to have presence integrated with subscription
  (send `(display "Hello! Enter your name:\n"))
  (define name (rpc 'read-line))
  (send `(display "Hello, "))
  (send `(display ,name))
  (send `(display "!\n"))
  (rpc `(sleep 1000))
  (send `(display "Goodbye\n")))

(ground-vm/userland (lambda (p m) (p m)) ;; pattern-predicate
		    main)