374 lines
14 KiB
Racket
374 lines
14 KiB
Racket
#lang scheme/gui
|
|
|
|
(require (for-syntax "syn-aux.ss")
|
|
"checked-cell.ss"
|
|
"check-aux.ss"
|
|
"timer.ss"
|
|
"last.ss"
|
|
htdp/error
|
|
(only-in mzlib/etc evcase)
|
|
string-constants)
|
|
|
|
(provide universe%)
|
|
|
|
;
|
|
;
|
|
;
|
|
; ; ; ;
|
|
; ; ; ;
|
|
; ; ;
|
|
; ; ; ;;;; ; ; ; ;;; ; ;; ;;; ;;;
|
|
; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ;;;;; ; ; ;;; ;;;;;
|
|
; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ;;; ; ; ; ; ;;; ; ;;; ;;;
|
|
;
|
|
;
|
|
;
|
|
|
|
(define universe%
|
|
(last-mixin
|
|
(clock-mixin
|
|
(class* object% (start-stop<%>) (inspect #f) (super-new)
|
|
(init-field ;; type Result
|
|
; = (make-bundle [Listof World] Universe [Listof Mail])
|
|
universe0 ;; the initial state of the universe
|
|
on-new ;; Universe World -> Result
|
|
on-msg ;; Universe World Message -> Result
|
|
tick ;; Universe -> Result
|
|
(state #f) ;; Boolean
|
|
(on-disconnect ;; Universe World -> Result
|
|
(lambda (u w) (make-bundle u '() '())))
|
|
(to-string #f) ;; Universe -> String
|
|
(check-with True) ;; Any -> Boolean
|
|
)
|
|
|
|
(field
|
|
[universe
|
|
(new checked-cell% [msg "UniSt"] [value0 universe0] [ok? check-with]
|
|
[display (and state "your server's state")])])
|
|
|
|
;; -----------------------------------------------------------------------
|
|
;; dealing with events
|
|
(define-syntax-rule
|
|
;; A B ... -> Void
|
|
(def/cback pub (pname a ...)
|
|
;; Universe A B ... -> (cons Universe Mail)
|
|
;; effect: change server state, broadcast mails
|
|
name body ...)
|
|
(begin
|
|
(pub pname)
|
|
(define (pname a ...)
|
|
(define (handler e) (stop! e))
|
|
(with-handlers ([exn? handler])
|
|
(define ___ (begin 'dummy body ...))
|
|
(define n (if (object-name name) (object-name name) name))
|
|
(define-values (u mails bad)
|
|
(bundle> n (name (send universe get) a ...)))
|
|
(send universe set (format "~a callback" 'name) u)
|
|
(unless (boolean? to-string) (send gui add (to-string u)))
|
|
(broadcast mails)
|
|
(for-each (lambda (iw)
|
|
(iworld-close iw)
|
|
(set! iworlds (remq iw iworlds)))
|
|
bad)))))
|
|
|
|
;; [Listof Mail] -> Void
|
|
;; send payload of messages to designated worlds
|
|
(define/private (broadcast lm)
|
|
(for-each (lambda (p+m)
|
|
(define w (mail-to p+m))
|
|
(define p (mail-content p+m))
|
|
(define n (iworld-name w))
|
|
(if (not (memq w iworlds))
|
|
(send gui add (format "~s not on list" n))
|
|
(with-handlers ((exn:fail? (lambda (e) (kill w))))
|
|
(iworld-send w p)
|
|
(send gui add (format "-> ~a: ~a" n p)))))
|
|
lm))
|
|
|
|
(def/cback private (pnew iworld) on-new
|
|
(set! iworlds (cons iworld iworlds))
|
|
(send gui add (format "~a signed up" (iworld-name iworld))))
|
|
|
|
(def/cback private (pmsg iworld r) on-msg
|
|
(send gui add (format "~a ->: ~a" (iworld-name iworld) r)))
|
|
|
|
(def/cback private (pdisconnect iworld) on-disconnect
|
|
(kill iworld))
|
|
|
|
(def/cback public (ptock) tick)
|
|
|
|
;; IWorld -> Void
|
|
;; effect: remove from given iworld from iworlds
|
|
;; and shut down all connections
|
|
(define/private (kill w)
|
|
(send gui add (format "~a !! closed port" (iworld-name w)))
|
|
(set! iworlds (remq w iworlds))
|
|
(iworld-close w))
|
|
|
|
;; -----------------------------------------------------------------------
|
|
;; start and stop server, start and stop the universe
|
|
|
|
(field [iworlds '()] ;; [Listof World]
|
|
[gui (new gui%
|
|
[stop-server (lambda () (stop! (send universe get)))]
|
|
[stop-and-restart (lambda () (restart))])]
|
|
[dr:custodian (current-custodian)]
|
|
[the-custodian (make-custodian)])
|
|
|
|
;; start the universe, enable registrations and message exchanges
|
|
(define/public (start!)
|
|
(set! the-custodian (make-custodian))
|
|
(parameterize ([current-custodian the-custodian])
|
|
(define (loop)
|
|
(apply sync
|
|
(handle-evt (tcp-accept-evt tcp-listener) add-iworld)
|
|
(map(lambda (p)
|
|
(handle-evt (iworld-in p) (process-message p)))
|
|
iworlds)))
|
|
;;; WHERE
|
|
(define tcp-listener
|
|
(with-handlers ((exn:fail:network? (lambda (x) (stop! x))))
|
|
(tcp-listen SQPORT 4 #t)))
|
|
;; (list IPort OPort) -> Void
|
|
(define (add-iworld in-out)
|
|
(define in (first in-out))
|
|
(define out (second in-out))
|
|
;; is it possible to kill the server with lots of bad connections?
|
|
(with-handlers ((tcp-eof? (lambda _ (loop)))
|
|
(exn? (lambda (e)
|
|
(printf "process registration failed!\n~a"
|
|
(exn-message e))
|
|
(loop))))
|
|
(tcp-process-registration
|
|
in out (lambda (info) (pnew (create-iworld in out info))))
|
|
(loop)))
|
|
;; IWorld -> [IPort -> Void]
|
|
(define (process-message p)
|
|
(lambda (in)
|
|
(define (disc e)
|
|
(pdisconnect p)
|
|
(if (null? iworlds) (restart) (loop)))
|
|
(with-handlers ((tcp-eof? disc))
|
|
(pmsg p (tcp-receive in))
|
|
(loop))))
|
|
;; --- go universe go ---
|
|
(set! iworlds '())
|
|
(send universe set "initial value" universe0)
|
|
(send gui add "a new universe is up and running")
|
|
(thread loop)))
|
|
|
|
(define/private (restart)
|
|
;; I am running in a custodian that is about to be killed,
|
|
;; so let's switch to one up in the hierarchy
|
|
(let ([old-t (current-thread)]
|
|
[go (make-semaphore)])
|
|
(parameterize ([current-custodian dr:custodian])
|
|
(thread (lambda ()
|
|
(sync old-t go)
|
|
(start!))))
|
|
(send gui add "stopping the universe")
|
|
(send gui add "----------------------------------")
|
|
(for-each iworld-close iworlds)
|
|
(custodian-shutdown-all the-custodian)
|
|
(semaphore-post go)))
|
|
|
|
(define/public (stop! msg)
|
|
(send gui show #f)
|
|
(custodian-shutdown-all the-custodian))
|
|
|
|
;; -----------------------------------------------------------------------
|
|
;; initialize the universe and run
|
|
(send gui show #t)
|
|
(start!)))))
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
; ; ; ; ;
|
|
; ; ; ; ;
|
|
; ; ; ; ;
|
|
; ; ; ;;; ; ;; ; ;;;; ;;;
|
|
; ; ; ; ; ;; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ;;;
|
|
; ;; ;; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ;;; ; ;; ;;;; ;;;
|
|
;
|
|
;
|
|
;
|
|
|
|
(provide
|
|
iworld? ;; Any -> Boolean
|
|
iworld=? ;; World World -> Boolean
|
|
iworld-name ;; World -> Symbol
|
|
iworld1 ;; sample worlds
|
|
iworld2
|
|
iworld3)
|
|
|
|
;; --- the server representation of a world ---
|
|
(define-struct iworld (in out name info) #; #:transparent)
|
|
;; World = (make-iworld IPort OPort Symbol [Listof Sexp])
|
|
|
|
(define (iw* n) (make-iworld (current-input-port) (current-output-port) n '()))
|
|
(define iworld1 (iw* "iworld1"))
|
|
(define iworld2 (iw* "iworld2"))
|
|
(define iworld3 (iw* "iworld3"))
|
|
|
|
(define (iworld=? u v)
|
|
(check-arg 'iworld=? (iworld? u) 'iworld "first" u)
|
|
(check-arg 'iworld=? (iworld? v) 'iworld "second" v)
|
|
(eq? u v))
|
|
|
|
;; IWorld -> Void
|
|
(define (iworld-close p)
|
|
(close-output-port (iworld-out p))
|
|
(close-input-port (iworld-in p)))
|
|
|
|
;; IPort OPort Sexp -> IWorld
|
|
(define (create-iworld i o info)
|
|
(if (and (pair? info) (string? (car info)))
|
|
(make-iworld i o (car info) (cdr info))
|
|
(make-iworld i o (symbol->string (gensym 'iworld)) info)))
|
|
|
|
;; Player S-exp -> Void
|
|
(define (iworld-send p sexp)
|
|
(tcp-send (iworld-out p) sexp))
|
|
|
|
;
|
|
;
|
|
;
|
|
; ;;; ; ; ;
|
|
; ; ; ; ; ;
|
|
; ; ; ; ;
|
|
; ; ; ; ;
|
|
; ; ;; ; ; ;
|
|
; ; ; ; ; ;
|
|
; ; ; ; ; ;
|
|
; ; ; ; ; ;
|
|
; ;;; ;;; ;
|
|
;
|
|
;
|
|
;
|
|
|
|
;; effect: create and show a gui with two buttons and an editor for logging
|
|
(define gui%
|
|
(class frame%
|
|
(init stop-server stop-and-restart)
|
|
(inherit show)
|
|
(define/augment (on-close) (end))
|
|
(super-new [label "Universe"][width 500][height 300][style '(metal)])
|
|
(field
|
|
[end (lambda _ (show #f) (stop-server))]
|
|
[panel (new horizontal-panel% [parent this] [stretchable-height #f]
|
|
[alignment '(center center)])]
|
|
[stop (new button% [parent panel] [label "stop"] [callback end])]
|
|
[s&re (new button% [parent panel] [label "stop and restart"]
|
|
[callback (lambda (but evt) (stop-and-restart))])]
|
|
[text (new text%)]
|
|
[edit (new editor-canvas% [parent this] [editor text]
|
|
[style '(no-border no-hscroll auto-vscroll)])])
|
|
|
|
;; add lines to the end of the text
|
|
(define/public (add str)
|
|
(queue-callback
|
|
(lambda ()
|
|
(send text lock #f)
|
|
(send text insert (format "~a\n" str) (send text last-position))
|
|
(send text lock #t))))
|
|
|
|
;; -------------------------------------------------------------------------
|
|
;; add menu, lock, and show
|
|
(copy-and-paste this)
|
|
(send text lock #t)))
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; Frame Text -> Void
|
|
;; add menu bar to frame for copying all of the text
|
|
(require string-constants)
|
|
|
|
(define (copy-and-paste frame)
|
|
(define mb (new menu-bar% [parent frame]))
|
|
(define edit (new menu%
|
|
[label (string-constant edit-menu-label)]
|
|
[parent mb]))
|
|
(new menu-item%
|
|
[label (string-constant copy-menu-item)]
|
|
[parent edit]
|
|
[shortcut #\c]
|
|
[callback (lambda (m e)
|
|
(define t (send frame get-focus-object))
|
|
(when (is-a? t editor<%>)
|
|
(send t copy)))])
|
|
(new menu-item%
|
|
[label (string-constant select-all-menu-item)]
|
|
[parent edit]
|
|
[shortcut #\a]
|
|
[callback (lambda (m e)
|
|
(define t (send frame get-focus-object))
|
|
(when (is-a? t text%)
|
|
(send t set-position 0 (send t last-position))))])
|
|
(void))
|
|
|
|
;
|
|
;
|
|
; ;;; ;;; ; ;;
|
|
; ;; ;; ;
|
|
; ;; ;; ;;; ;;; ;
|
|
; ; ; ; ; ; ; ;
|
|
; ; ; ; ;;;; ; ;
|
|
; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ;
|
|
; ;;; ;;; ;;;;; ;;;;; ;;;;;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
|
|
(provide
|
|
;; type Bundle = (make-bundle [Listof World] Universe [Listof Mail])
|
|
;; type Mail = (make-mail World S-expression)
|
|
make-bundle ;; [Listof World] Universe [Listof Mail] -> Bundle
|
|
bundle? ;; is this a bundle?
|
|
make-mail ;; World S-expression -> Mail
|
|
mail? ;; is this a real mail?
|
|
)
|
|
|
|
(define-struct bundle (state mails bad) #:transparent)
|
|
|
|
(set! make-bundle
|
|
(let ([make-bundle make-bundle])
|
|
(lambda (state mails bads)
|
|
(check-arg-list 'make-bundle mails mail? "mail" "second")
|
|
(check-arg-list 'make-bundle bads iworld? "iworld" "third")
|
|
(make-bundle state mails bads))))
|
|
|
|
;; Symbol Any (Any -> Boolean) String String -> Void
|
|
;; raise a TP exception if low is not a list of world? elements
|
|
(define (check-arg-list tag low iworld? msg rank)
|
|
(check-arg tag (list? low) (format "list [of ~as]" msg) rank low)
|
|
(for-each (lambda (c)
|
|
(check-arg tag (iworld? c) msg (format "(elements of) ~a" rank) c))
|
|
low))
|
|
|
|
;; Symbol Any ->* Universe [Listof Mail] [Listof IWorld]
|
|
(define (bundle> tag r)
|
|
(unless (bundle? r)
|
|
(raise
|
|
(make-exn
|
|
(format "error: bundle expected from ~a, given: ~e" tag r)
|
|
(current-continuation-marks))))
|
|
(values (bundle-state r) (bundle-mails r) (bundle-bad r)))
|
|
|
|
(define-struct mail (to content) #:transparent)
|
|
|
|
(set! make-mail
|
|
(let ([make-mail make-mail])
|
|
(lambda (to content)
|
|
(check-arg 'make-mail (iworld? to) 'iworld "first" to)
|
|
(check-arg 'make-mail (sexp? content) 'S-expression "second" content)
|
|
(make-mail to content))))
|